How to suppress errors/outputs from a TCL thread? - multithreading

I have created a thread :
set t1 [thread::create]
thread::send $t1 {
proc myProc {command args} {
exec {*}[auto_execok $command] {*}$args >& /dev/null
}
}
And then tried to send an asynchronous command :
thread::send -async $t1 [list myProc <command args>]
But the error/output from the command is getting displayed in output.
How to hide the errors/outputs from the command that is send to the async thread ?

The simplest method is to catch the errors.
thread::send $t1 {
proc myProc {command args} {
catch {
exec {*}[auto_execok $command] {*}$args >& /dev/null
}
}
}
Be aware that this makes any problems significantly more difficult to debug! It's better if you can identify what errors you expect and just try to catch them, so unexpected errors are still things you see and have to handle.
thread::send $t1 {
proc myProc {command args} {
try {
exec {*}[auto_execok $command] {*}$args >& /dev/null
} trap CHILDSTATUS {} {
# Ignore a non-zero exit?
}
}
}
For this specific case (which is very much I/O-bound from Tcl's perspective) you might be better off just adding & to the end of the exec call and not running in a separate thread. Can't really say for sure without knowing exactly what you're doing, but it is worth considering.

Related

tcl thread::send -async not works

I want to send message to thread in synchronous mode and get result using trace variable metohd. The problem is that I dont get any response from thread. When I send message in normal mode (thread:: send thread_id {command} var) then I also get the result which is saved in var. Could anyone point out where I make mistake ? Below I pass my code :
trace add variable res write {apply {{v1 v2 op} {
upvar 1 $v1 v
puts "updated variable to $v"}}}
set th [thread::create {
puts "new thread id : [thread::id]"
proc fun {n} {
return [expr {$n*2}]
}
thread::wait
}]
# thread::send $th [list fun $t] res
thread::send -async $th [list fun 43] res
Are you waiting for events in the source/main thread? If you aren't, you'll never process the asynchronous response message that causes the res variable to be set.

Handling spawn thru thread in tcl

I am trying to handle spawn process thru thread , but its throwing error "invalid command" .
But without thread its working fine .
set listner [thread::create {
package require Expect
proc router_config {s filename} {
set command_router "{Password: } {abc#123\r}
{Router>} {en\r}
{Password: } {abc#123\r}"
spawn telnet 1.1.1.1
foreach {exp_prompt send_cmd} $command_router {
expect "$exp_prompt"
exp_send "$send_cmd"
}
return 1
}
[thread::wait]
}]
set commandString "xyz"
eval [subst {thread::send -async $listner \
{router_config 0 [list $commandString ]}}]
puts "--------->> releasing thread [thread::id] [thread::release]"
exit 0
Please suggest some way to handle .

expect program send commands from file

How to make send command of "expect" program to read from a file and use each line as argument.
I want to use a loop like structure in expect program which may look like below(NOTE:- while loop is imaginary.)
spawn /my/program
expect {
-re EBtxjjmEcQTxc0SLd4TdXxjUduxCOLZBwEme2Z.*password: {
while read_line in FILE;
do
send $read-line;
done
}
How to program the while-loop part equivalent using "expect"
Note in your question, you were missing a close brace, and you mis-typed your variable name (read_line and read-line)
Expect is a Tcl extension, so you have all the Tcl commands at your disposal
spawn /my/program
expect {
-re EBtxjjmEcQTxc0SLd4TdXxjUduxCOLZBwEme2Z.*password: {
set fh [open FILE r]
while {[gets $fh read_line] != -1} {
send "$read_line\r"
}
close $fh
}
}
If you install tcllib, you can do
package require fileutil
spawn /my/program
expect {
-re EBtxjjmEcQTxc0SLd4TdXxjUduxCOLZBwEme2Z.*password: {
fileutil::foreachLine read_line FILE {
send "$read_line\r"
}
}
}

fork and waitpid fail on linux. Without hitting the hard or soft limits

I have a process that must create and close threads on demand.
Each thread forks a new process using open2. Sometimes after executing the program for a long time open2 fails to fork the process sometimes and gives a "Can not allocate memory error", sometimes this happens for threads too.I know that the Linux has soft and hard limits but the number of the concurrent threads and processes for my server does not exceed those values.
Is there something like a counter for number of processes and threads that eliminates thread and process creation after sometime?
If it is so how servers like Postgres work for a long period of time?
The project has multiple processes that communicate using TCP, but the part that causes the error that i described in a frond end to mplayer, that is written in Perl. The code is as follows:
use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
use POSIX ":sys_wait_h";
use IPC::Open2;
use 5.010;
use Config;
BEGIN
{
if(!$Config{useithreads})
{
die "Your perl does not compiled with threading support.";
}
}
use threads;
use threads::shared;
use constant
{
SERVER_PORT=>5000,
#Remote request packet fields
PACKET_REQTYPE=>0,
PACKET_FILENAM=>1,
PACKET_VOLMLVL=>2,
PACKET_ENDPOSI=>3,
PACKET_SEEKPOS=>4,
#our request typs
PLAY_REQUEST=>1,
STOP_REQUEST=>2,
INFO_REQUEST=>3,
VOCH_REQUEST=>4,
PAUS_REQUEST=>5,
PLPA_REQUEST=>6,
SEEK_REQUEST=>7,
#Play states
STATE_PAUS=>0,
STATE_PLAY=>1,
STATE_STOP=>2,
};
#The following line must be added because of a bad behavior in the perl thread library that causes a SIGPIPE to be generated under heavy usage of the threads.
$SIG{PIPE} = 'IGNORE';
#This variable holds the server socket object
my $server_socket;
#This array is used to hold objects of our all threads
my #thread_objects;
#create the server socket
$server_socket=IO::Socket::INET->new(LocalPort=>SERVER_PORT,Listen=>20,Proto=>'tcp',Reuse=>1) or
die "Creating socket error ($#)";
#Now try to accept remote connections
print "Server socket created successfully now try to accept remote connections on port: ".SERVER_PORT."\n";
while(my $client_connection=$server_socket->accept())
{
push #thread_objects,threads->create(\&player_thread,$client_connection);
$thread_objects[$#thread_objects]->detach();
}
#This subroutine is used to play something using tcp-based commands
sub player_thread
{
my $client_socket=shift;
#create a new select object
my $selector=IO::Select->new($client_socket);
#this variabe is used to pars our request
my #remote_request;
#getting th thread id of the current thread
my $tid=threads->self()->tid;
#This variable is used to hold the pid of mplayer child
my $mp_pid=-1;
#Mplayer stdin and stdout file descriptors
my ($MP_STDIN,$MP_STDOUT);
#This variable is used to check if we are playing something now or not
my $is_playing=STATE_STOP;
print "Client thread $tid created.\n";
while(1)
{
#check to see if we can read anything from our handler
#print "Before select\n";
#my #ready=$selector->can_read();
#print "After select: #ready\n";
#now the data is ready for reading so we read it here
my $data=<$client_socket>;
#This means if the connection is closed by the remote end
if(!defined($data))
{
print "Remote connection has been closed in thread $tid mplayer id is: $mp_pid and state is: $is_playing.\n";
#if we have an mplayer child when remote connection is closed we must wait for it
#so that is work is done
if($mp_pid!=-1 and $is_playing ==STATE_PLAY)
{
waitpid $mp_pid,0;
$is_playing=STATE_STOP;
}
elsif($is_playing==STATE_PAUS and $mp_pid!=-1)
{
print "thread $tid is in the paused state, we must kill mplayer.\n";
print $MP_STDIN "quit\n";
waitpid $mp_pid,0;
$is_playing=STATE_STOP;
}
last;
}#if
#FIXME:: Here we must validate our argument
#Now we try to execute the command
chomp($data);
#remote_request=split ",",$data;
print "#remote_request\n";
#Trying to reap the death child and change the state of the thread
my $dead_child=-1;
$dead_child=&reaper($mp_pid);
if($dead_child)
{
$is_playing=STATE_STOP;
$mp_pid=-1;
}
given($remote_request[PACKET_REQTYPE])
{
when($_==PLAY_REQUEST)
{
print "Play request\n";
if($is_playing==STATE_STOP)
{
eval{$mp_pid=open2($MP_STDOUT,$MP_STDIN,"mplayer -slave -really-quiet -softvol -volume ".$remote_request[PACKET_VOLMLVL]." -endpos ".$remote_request[PACKET_ENDPOSI]." ./".$remote_request[PACKET_FILENAM]);};
print "Some error occurred in open2 system call: $#\n" if $#;
$is_playing=STATE_PLAY;
print "Mplayer pid: $mp_pid.\n";
}
}
when($_==STOP_REQUEST)
{
print "Stop request\n";
if($is_playing != STATE_STOP)
{
print $MP_STDIN "pausing_keep stop\n";
#FIXME:: Maybe we should use WNOHANG here
my $id=waitpid $mp_pid,0;
print "Mplayer($id) stopped.\n";
$is_playing=STATE_STOP;
$mp_pid=-1;
}
}
when($_==PAUS_REQUEST)
{
print "pause request\n";
if($is_playing !=STATE_STOP)
{
print $MP_STDIN "pausing_keep pause\n";
$is_playing=STATE_PAUS;
}
}
when($_==VOCH_REQUEST)
{
print "volume change request\n";
if($is_playing !=STATE_STOP)
{
print $MP_STDIN "pausing_keep volume ".$remote_request[PACKET_VOLMLVL]." 1\n";
}
}
when($_==INFO_REQUEST)
{
my $id;
$id=&reaper($mp_pid);
if($id > 0)
{
print "Mplayer($id) stopped.\n";
$is_playing=STATE_STOP;
$mp_pid=-1;
}
given($is_playing)
{
when($_==STATE_STOP)
{
print $client_socket "Stopped\n";
}
when($_==STATE_PAUS)
{
print $client_socket "Paused\n";
}
when($_==STATE_PLAY)
{
print $client_socket "Playing\n";
}
}
}
when ($_==PLPA_REQUEST)
{
print "play paused request\n";
if($is_playing==STATE_STOP)
{
eval{$mp_pid=open2($MP_STDOUT,$MP_STDIN,"mplayer -slave -really-quiet -softvol -volume ".$remote_request[PACKET_VOLMLVL]." -endpos ".$remote_request[PACKET_ENDPOSI]." ./".$remote_request[PACKET_FILENAM]);};
print "Some error occurred in open2 system call: $#\n" if $#;
print $MP_STDIN "pausing_keep pause\n";
$is_playing=STATE_PAUS;
}
}
when ($_==SEEK_REQUEST)
{
print "Seek request\n";
if($is_playing != STATE_STOP)
{
my $seek_pos=abs $remote_request[PACKET_SEEKPOS];
print $MP_STDIN "seek $seek_pos 2\n";
$is_playing=STATE_PLAY;
}
}
default
{
warn "Invalid request($_)!!!";
next;
}
}#Given
}#while
$client_socket->close();
print "Thread $tid is exiting now, the child mplayer pid is: $mp_pid and state is: $is_playing.\n";
}
#The following subroutine takes a pid and if that pid is grater than 0 it tries to reap it
#if it is successful returns pid of the reaped process else 0
sub reaper
{
my $pid=shift;
if($pid > 0)
{
my $id=waitpid($pid,WNOHANG);
if($id > 0)
{
return $id;
}
}
return 0;
}
"Can not allocate memory error" is what it says, either the user exceeded its memory quota (check with ulimit -m, compare to ps ux) or you're really out of memory (free).
The limits for max user processes are only indirectly connected - if you fork() more processes then the user's memory quota permits, fork() will fail with ENOMEM.
You also might want to see:
What are some conditions that may cause fork() or system() calls to fail on Linux?
I finally found the problem, it is because of a memory leak in the Perl's thread module that causes the memory to grow after a long time. Then open2 can not allocate memory and fails.

Prevent tcl thread from being blocked by main event loop

I am trying to run a thread continuously and not have it become blocked by the tcl main event loop.
Here is a simple example of what I'm trying to do:
#!/bin/sh
#\
exec tclsh "$0" "$#"
package require Thread
set ::a_thread [thread::create {thread::wait}]
proc start_a {} {
thread::send $::a_thread {
puts "Running a thread"
}
after 1000 a_start
}
proc infinite_loop {} {
while {1} {
puts "Loop"
after 500
}
}
start_a
infinite_loop
vwait forever
In this code, the infinite_loop proc is called and the main event loop runs infinitely. I would like it if the a_thread could still run in the background though. How can I achieve this?
The main event loop is not blocking your thread. Instead you are using the main event loop to shedule scripts to be executed in the thread. Instead, run the scheduler in the thread itself:
Code tested and works as expected:
thread::send $::a_thread {
proc loop {} {
puts "running a thread"
after 1000 loop
}
loop
}
while 1 {
puts "loop"
after 500
}
The answer is, of course, the one given by slebetman. However, one way to debug this sort of thing (especially in more complex cases) is to prefix the messages printed by each thread by the result of thread::id, and to make sure you print a message at the start of each time round the loop. For example:
package require Thread
set ::a_thread [thread::create {thread::wait}]
proc start_a {} {
puts "[thread::id]: Dispatch to $::a_thread"
thread::send $::a_thread {
puts "[thread::id]: Running a thread"
}
after 1000 a_start
}
proc infinite_loop {} {
while {1} {
puts "[thread::id]: Loop"
after 500
}
}
start_a
infinite_loop
puts "[thread::id]: Start main event loop"
vwait forever
That would have told you that the dispatch was happening once, that the running in the other thread is happening synchronously (thread::send waits for the script to finish executing by default), and that the infinite loop is preventing the startup of the main event loop (and hence the rescheduling of the dispatch). Since you didn't know who was doing what, of course there was confusion!

Resources