Stop a thread when another thread stops in Perl - linux

Hi I am trying to stop or kill the thread $t2 when $t1 stops. Here is the code:
#!/usr/local/bin/perl
use strict;
use warnings;
use threads;
use threads::shared;
use Time::HiRes qw( sleep );
print "Starting main program\n";
my #threads;
my $t1 = threads->new(\&c1);
my $t2 = threads->new(\&progress);
#my $t2 = threads->new(\&c2);
push(#threads,$t1);
push(#threads,$t2);
my $ret1 = $t1->join();
print "Thread returned: $ret1\n";
$t2->join();
if (!($t1->is_running()))
{
$t2->exit();
}
print "End of main program\n";
sub c1
{
print "Inside thread 1\n";
sleep 5;
return 245;
}
sub c2
{
print "Inside thread 2\n";
}
sub progress
{
$| = 1; # Disable buffering on STDOUT.
my $BACKSPACE = chr(0x08);
my #seq = qw( | / - \ );
for (;;) {
print $seq[0];
push #seq, shift #seq;
sleep 0.200;
print $BACKSPACE;
}
print "$BACKSPACE $BACKSPACE";
}
But thread $t2 continues running. Please help me out with this.
How to kill thread $t2.
I am confused with join(), detach(), exit()

You can't call exit on thread instance $t2->exit() and module warns you about that,
perl -Mthreads -we '$_->exit(3) and $_->join for async {sleep 4}'
Usage: threads->exit(status) at -e line 1
Perl exited with active threads:
1 running and unjoined
0 finished and unjoined
0 running and detached
However, you can send a signal to thread (check signal list)
# Send a signal to a thread
$thr->kill('SIGUSR1');

You can use a shared variable:
use threads::shared;
my $done : shared;
$done = 0;
my $t1 = threads->new( sub { c1(); $done = 1;} );
And in the progress function:
# ...
for (;!$done;) {
# ....

Related

perl multithreading perl exited with active threads

I write perl script to do a certain but I needed to mutlithread it, but I get this:
Perl exited with active threads:
2 running and unjoined
0 finished and unjoined
0 running and detached
Here is the code:
use Net::Ping;
use threads;
use Benchmark qw(:hireswallclock);
use threads::shared;
my $starttime = Benchmark->new;
my $finishtime;
my $timespent;
my $num_of_threads = 2;
my #threads = initThreads();
my $inFile = $ARGV[0] ;
open(IN , "<$inFile") or die "can not find $inFile" ;
my #output: shared = <IN>;
chomp (#output) ;
my $chunk_size = #output / 2;
print($chunk_size);
#############################
######## PROCEDURES ########
#############################
# Subroutine that intializes an array that will contain all our threads:
sub initThreads{
my #initThreads; # Our array
for(my $i=1; $i<=$num_of_threads; $i++){
push(#initThreads, $i);
}
return #initThreads;
}
sub doScript{
my $id = threads->tid();
print "//////////////////////////////////////////////////////////////////////////////////////////////Starting thread $id\n";
my ($start, $end, $output) = #_;
for my $i ($start .. $end) {
## some stuff done
sleep 1 if 0.2 > rand;
}
print "/////////////////////////////////////////////////////////////////////////////////////////////////////////////////Thread $id done!\n";
threads->exit();
}
########################
######## MAIN ########----------------------------------------------------------------
########################
for my $chunk(1 .. 2){
my $start = ($chunk - 1) * $chunk_size;
push #threads, threads->create(
\&doScript,
$start,
($start + $chunk_size - 1),
\#output,
);
print("finish");
}
# This tells the main program to keep running until all threads have finished.
foreach(#threads){
threads->join();
}
$finishtime = Benchmark->new;
$timespent = timediff($finishtime,$starttime);
print "\nDone!\nSpent ". timestr($timespent);
#print "\nProgram Done!\nPress Enter to exit\n";
$a = <>;
close (IN);
I even replaced the join block with this:
$_->join() for threads->list();
the error was solved but the script seemed not to do anything, threads started and terminated without doing anything.
Can anyone help me with this !
The reason you get that error is exactly as said on the tin - your code exited before the threads were closed. It can commonly happen when an exit or die is triggered early.
In particular I think your problem may lie within your reusing of #threads and initThreads().
The latter returns a list of numbers, not any threads. And then you push a couple more threads to the end of the list later, when you're doing a create.
That looks a lot like some sort of logic error to me.
But the major problem I think will be this:
foreach(#threads){
threads->join();
}
You're not actually joining a specific thread. What you probably want is:
foreach my $thr ( #threads ) {
$thr -> join();
}
At least, you would, if you hadn't manually populated #threads with [1,2] thanks to my #threads = initThreads();

Why are my Perl threads stuck in an infinite loop? (Thread::Queue)

I am using Thread::Queue to push an array onto a queue and process each element of it using threads. Below is a simplified version of my program to demonstrate what is happening.
#!/usr/bin/perl
use strict;
use warnings;
use threads;
use threads::shared;
use Thread::Queue;
# Define queue
my $QUEUE :shared = new Thread::Queue();
# Define values
my #values = qw(string1 string2 string3);
# Enqueue values
$QUEUE->enqueue(#values);
# Get thread limit
my $QUEUE_SIZE = $QUEUE->pending();
my $thread_limit = $QUEUE_SIZE;
# Create threads
for my $i (1 .. $thread_limit) {
my $thread = threads->create(\&work);
}
# Join threads
my $i = 0;
for my $thread (threads->list()) {
$thread->join();
}
print "COMPLETE\n";
# Thread work function
sub work {
while (my $value = $QUEUE->dequeue()) {
print "VALUE: $value\n";
sleep(5);
print "Finished sleeping\n";
}
print "Got out of loop\n";
}
When I run this code I get the following output and then it just hangs forever:
VALUE: string1
VALUE: string2
VALUE: string3
Finished sleeping
Finished sleeping
Finished sleeping
Once the queue reaches its end, the while loop should break and the script should continue but it doesn't appear to ever get out of the loop.
Why is this getting stuck?
Since you never call $QUEUE->end(), your threads are blocking on dequeue() waiting for more entries to appear.
So, ensure you do call $QUEUE->end() after the last call to enqueue, or before joining the threads.

Breaking out of a while loop with system commands in Perl using Ctrl-C (SIGINT)?

Consider the following example, test.pl:
#!/usr/bin/env perl
use 5.10.1;
use warnings;
use strict;
$SIG{'INT'} = sub {print "Caught Ctrl-C - Exit!\n"; exit 1;};
$| = 1; # turn off output line buffering
use Getopt::Long;
my $doSystemLoop = 0;
GetOptions( "dosysloop"=>\$doSystemLoop );
print("$0: doSystemLoop is:$doSystemLoop (use " . (($doSystemLoop)?"system":"Perl") . " loop); starting...\n");
my $i=0;
if (not($doSystemLoop)) { # do Perl loop
while ($i < 1e6) {
print("\tTest value is $i");
$i++;
sleep 1;
print(" ... ");
sleep 1;
print(" ... \n");
}
} else { # do system call loop
while ($i < 1e6) {
system("echo","-ne","\tTest value is $i");
$i++;
system("sleep 1");
system("echo","-ne"," ... ");
system("sleep 1");
system("echo","-e"," ... ");
}
}
So, if I call this program, so it uses a usual Perl loop, everything is as expected:
$ perl test.pl
test.pl: doSystemLoop is:0 (use Perl loop); starting...
Test value is 0 ... ...
Test value is 1 ... ...
Test value is 2 ... ^CCaught Ctrl-C - Exit!
$
... that is, I hit Ctrl-C, program exits instantly.
However, if the while loop's commands consist mostly of system calls, then it becomes nearly impossible to exit with Ctrl-C:
$ perl test.pl --dosysloop
test.pl: doSystemLoop is:1 (use system loop); starting...
Test value is 0 ... ...
Test value is 1 ... ...
Test value is 2 ... ^C ...
Test value is 3 ... ^C ...
Test value is 4 ... ^C ...
Test value is 5^C ... ^C ...
Test value is 6^C ... ^C ...
Test value is 7^C ... ^C ...
Test value is 8^C ... ^C ...
Test value is 9^C ... ^C ...
Test value is 10 ... ^C ...
Test value is 11^C ... ^C ...
Test value is 12^C ... ...
Test value is 13^Z
[1]+ Stopped perl test.pl --dosysloop
$ killall perl
$ fg
perl test.pl --dosysloop
Terminated
$
So in the snippet above, I'm hitting Ctrl-C (the ^C) like mad, and the program ignores me completely :/ Then I cheat by hitting Ctrl-Z (the ^Z), which stops the process and sets in the background; then in the resulting shell I do killall perl, and after that I execute the fg command, which places the Perl job back in the foreground - where it finally terminates due to the killall.
What I would like to have, is run a system loop like this, with the possibility to break out of it/exit it with the usual Ctrl-C. Is this possible to do, and how do I do that?
Perl's signal handling mechanism defers the handling of signals until a safe point. Deferred signals are checked between Opcodes of the perl VM. As system and friends count as a single opcode, signals are only checked once the exec'd command has terminated.
This can be circumvented by forking, and then waiting in a loop for the child process to terminate. The child can also be terminated early via a signal handler.
sub launch_and_wait {
my $wait = 1;
my $child;
local $SIG{CHLD} = sub {
$wait = 0;
};
local $SIG{INT} = sub {
$wait = 0;
kill KILL => $child if defined $child;
};
if ($child = fork()) {
# parent
while ($wait) {
print "zzz\n";
sleep 1;
}
wait; # try to join the child
} else {
# child
exec {$_[0]} #_;
}
}
launch_and_wait sleep => 60;
print "Done\n";
There are probably lots of ways this can go wrong (getting a SIGINT before the child was spawned…). I also omitted any error handling.
Check the exit status of the system() command for any signals. An external command interrupted with SIGINT will get a "2" here:
while () {
system("sleep", 1);
if ($? & 127) {
my $sig = $? & 127;
die "Caught signal INT" if $sig == 2; # you may also abort on other signals if you like
}
}

Control+C handling in multithread perl script

I'm new in perl and I have a problem with handling ^C in my perl script. When I'm trying to continue script execution after recieving ^C during the sleep I have only output before $FLAG = 2; and nothing after:
# perl test.pl
sleeping...
^Cawaiking... =
#
instead of:
# perl test.pl
sleeping...
awaiking... ====
some..
#
It seams that ^C is killing the progres bar thread and after it dies no actions but print could be performed in the main thread. Could anyone help me with this problem?
$SIG{INT} = 'IGNORE';
our $FLAG : shared = 1;
...
sub call1{
$FLAG = 1;
my $pBar = threads->new(\&progressBarInit);
$pBar->detach;
print "sleeping...\n";
sleep 5;
print "awaiking...\n";
$FLAG = 2;
print "some..\n";
return #result;
}
call1();
sub progressBarInit{
my $max = 50;
my $counter = 1;
while($FLAG == 1){
progressBar( $counter, $max, 50, '=' );
$counter++;
if($counter > $max){$counter=1;}
sleep 1;
}
}
sub progressBar {
my ( $counter, $max, $width, $char ) = #_;
local $| = 1;
printf " %-${width}s\r", $char x (($width-1)*$counter/$max);
}
I think the problem is that you setup the signal handler in the parent.
According to this: http://perldoc.perl.org/threads.html
Signal handlers need to be set up in the threads for the signals they are expected to act upon. Here's an example for cancelling a thread:
Instead of using a flag you could use signals to communicate:
sub progressBarInit {
# Thread 'cancellation' signal handler
$SIG{'KILL'} = sub { threads->exit(); };
$SIG{INT} = 'IGNORE';
...
}
...
# Signal the thread to terminate, and then detach
# it so that it will get cleaned up automatically
my $pBar = threads->new(\&progressBarInit);
print "sleeping...\n";
sleep 5;
print "awaiking...\n";
$pBar->kill('KILL')->detach();

Perl trapping Ctrl-C with threads in bash

While I see how to have Perl trap Ctrl-C (sigint) in bash; I'm getting lost at why does it fail with threads; I'm trying the following script:
#!/usr/bin/env perl
use threads;
use threads::shared; # for shared variables
my $cnt :shared = 0;
sub counter() {
while (1) {
$cnt++;
print "thread: $cnt \n";
sleep 1;
}
}
sub finisher{
### Thread exit! ...
print "IIII";
threads->exit();
die;
};
# any of these will cause stop of reaction to Ctrl-C
$SIG{INT} = \&finisher;
$SIG{INT} = sub {print "EEE\n" ;} ;
$SIG{INT} = 'IGNORE';
# setting to DEFAULT, brings usual behavior back
#~ $SIG{INT} = 'DEFAULT';
my $mthr = threads->create(\&counter);
$mthr->join();
... and as soon as the SIGINT handler is set to anything else than the default (where Ctrl-C causes exit), it basically causes for the script to stop reacting on Ctrl-C any longer:
$ ./test.pl
thread: 1
^Cthread: 2
^C^Cthread: 3
^C^C^C^Cthread: 4
thread: 5
thread: 6
thread: 7
thread: 8
Terminated
... and I have to sudo killall perl in order to terminate the script.
There is a bit on threads and Ctrl-C in these links:
Sending sig INT ( control C ) to threads - Dev Shed
SOLVED: Is this a bug of perl threads ? - Perl Monks
How do we capture CTRL ^ C - Perl Monks
Is the signal handler supposed to work like this?
... but I cannot say if it conclusively answers whether "capturing" Ctrl-C under perl in bash is definitely impossible?
Thanks in advance for any answers,
Cheers!
Ok, I think I got it (but I'm leaving the previous entry (below) for reference ...)
The trick turns out to be that, from the main SIGINT handler, one must signal the thread via kill - AND then thread also needs to have a separate SIGINT handler (from the first link in OP); AND instead of just join(), one needs to use the code in the answer by #ikegami:
#!/usr/bin/env perl
use threads;
use threads::shared; # for shared variables
my $cnt :shared = 0;
my $toexit :shared = 0;
sub counter() {
$SIG{'INT'} = sub { print "Thread exit\n"; threads->exit(); };
my $lexit = 0;
while (not($lexit)) {
{ lock($toexit);
$lexit = $toexit;
}
$cnt++;
print "thread: $cnt \n";
sleep 1;
}
print "out\n";
}
my $mthr;
sub finisher{
{ lock($toexit);
$toexit = 1;
}
$mthr->kill('INT');
};
$SIG{INT} = \&finisher;
$mthr = threads->create(\&counter);
print "prejoin\n";
#~ $mthr->join();
while (threads->list()) {
my #joinable = threads->list(threads::joinable);
if (#joinable) {
$_->join for #joinable;
} else {
sleep(0.050);
}
}
print "postjoin\n";
I may be overkilling it with the $toexit there, but at least now this is the result:
$ ./test.pl
prejoin
thread: 1
thread: 2
thread: 3
^CThread exit
postjoin
Many thanks to all for the solution :)
Cheers!
Thanks to the suggestion by #mob for PERL_SIGNALS to unsafe (note, Perl 5.14 does not allow "internal" setting of $ENV{'PERL_SIGNALS'}), I'm getting somewhere - now Ctrl-C is detected - but it either terminates with a segfault, or with error:
#!/usr/bin/env perl
use threads;
use threads::shared; # for shared variables
my $cnt :shared = 0;
my $toexit :shared = 0;
sub counter() {
my $lexit = 0;
while (not($lexit)) {
{ lock($toexit);
$lexit = $toexit;
}
$cnt++;
print "thread: $cnt \n";
sleep 1;
}
print "out\n";
#~ threads->detach(); # Thread 1 terminated abnormally: Cannot detach a joined thread
#~ exit;
}
my $mthr;
# [http://code.activestate.com/lists/perl5-porters/164923/ [perl #92246] Perl 5.14 does not allow "internal" setting of $ENV ...]
sub finisher{
### Thread exit! ...
#~ print "IIII";
# anything here results with: Perl exited with active threads:
#~ threads->exit();
#~ threads->join();
#~ $mthr->exit();
#~ $mthr->join();
#~ $mthr->detach();
#~ $mthr->kill();
#~ threads->exit() if threads->can('exit'); # Thread friendly
#~ die;
{ lock($toexit);
$toexit = 1;
}
#~ threads->join(); #
};
# any of these will cause stop of reaction to Ctrl-C
$SIG{INT} = \&finisher;
#~ $SIG{INT} = sub {print "EEE\n" ; die; } ;
#~ $SIG{INT} = 'IGNORE';
# setting to DEFAULT, brings usual behavior back
#~ $SIG{INT} = 'DEFAULT';
$mthr = threads->create(\&counter);
print "prejoin\n";
$mthr->join();
print "postjoin\n";
With the comments as above, that code react with:
$ PERL_SIGNALS="unsafe" ./testloop06.pl
prejoin
thread: 1
thread: 2
thread: 3
^Cthread: 4
out
Segmentation fault
Result is the same if I add the following that uses Perl::Signals::Unsafe:
$mthr = threads->create(\&counter);
UNSAFE_SIGNALS {
$mthr->join();
};
Almost there, hopefully someone can chime in ... :)
Signal handlers are only called between Perl opcodes. Your code is blocked in $mthr->join();, so it never gets to handle the signal.
Possible solution:
use Time::HiRes qw( sleep );
# Interruptable << $_->join() for threads->list; >>
while (threads->list()) {
my #joinable = threads->list(threads::joinable);
if (#joinable) {
$_->join for #joinable;
} else {
sleep(0.050);
}
}

Resources