I need to create a thread and let it do some stuff. The main reason is to quit from main programm as fast as possible.
But after I detach the thread and end the main programm, the thread dies. In my example the file doesn´t contain expected data.
If I let the main programm sleep for 5 sec everything works fine.
How can I let run the thread after quitting from the main prog?
use threads;
print "Starting main program\n";
my $t = threads->new(\&sub1)->detach();
print "End of main program\n";
sub sub1 {
print "started thread\n";
open (FILE, ">>./test.txt") or die($!);
print FILE localtime(time())."\n";
foreach (1..3){
print FILE "$_\n";
sleep 1;
}
close(FILE);
return 1;
}
Quite simply, you can't.
$thr->detach()
Makes the thread unjoinable, and causes any eventual return value to be discarded. When the program exits, any detached threads that are still running are silently terminated.
But you could do:
threads->new(\&sub1)->join();
But that hardly buys you much. Because threads are mainly meant to be used to do other things while you continue to do some thing. There is little reason to stop the main line of execution, and then run a thread, when you could just as well have called sub1();
You can't use threads, but you could fork and let parent process exit without waiting for the child process to finish:
my $pid = fork();
if ($pid == 0) {
print "child proc\n";
sleep 5;
print "child, 5 seconds older\n";
exit(0);
} else {
print "parent proc. goodbye\n";
}
I don't think this isn't a very good approach since you've now lost control over the child process. Why not just run it main and background the process?
Edit: This of course also has the potential to generate zombie processes, which will consume system resources. and brains.
Related
Below code is supposed to run 2 parallel threads, each thread executes fork(), waits for child process to finish then threads are expected to join (finish) and result is printed.
In reality, first forked child process finishes as expected, but second one hangs on _mutex_lock() trying to exit, thus second thread never joins till you kill second child manually with -9 signal.
Could somebody please explain why this happens, and how to avoid this?
use strict;
use warnings;
use threads;
use Data::Dumper;
sub Run
{
my $tid = threads->tid();
my $log = {};
$log->{"[$$:$tid]:00"} = "started";
my $pid = fork();
if ($pid == 0)
{
print "In child ($$): started\n";
sleep 3;
print "In child ($$): finished\n";
# system("kill -9 $$"); -- brutal way
exit 0;
}
waitpid($pid, 0);
my $exitCode = $? >> 8;
$log->{"[$$:$tid]:01"} = "finished, code=$exitCode";
return $log;
}
my #threads = ();
foreach (1..2)
{
push #threads, threads->new(sub { return Run() });
}
print Dumper($_->join()) for #threads;
On my Linux box, using _exit from POSIX instead of exit works. This solution might be non-portable to other platforms, though.
The linked documentation says:
Note that when using threads and in Linux this is not a good way to exit a thread because in Linux processes and threads are kind of the same thing (Note: while this is the situation in early 2003 there are projects under way to have threads with more POSIXly semantics in Linux). If you want not to return from a thread, detach the thread.
Similarly, perlthrtut - Tutorial on threads in Perl says
Thinking of mixing fork() and threads? Please lie down and wait until the feeling passes. Be aware that the semantics of fork() vary between platforms. For example, some Unix systems copy all the current threads into the child process, while others only copy the thread that called fork(). You have been warned!
I just passed over from php to perl due to my company's request so even if this may be a silly question is kind of nerve wreaking right now.
I have one little perl script deployed on a server through a debian package. I have this all figured out so that's all cool.
Now this script is called from another server through an SSH connection and the script logs back to that server all its actions. I use Log::Log4perl for that.
One of the tasks takes a very long time and also runs some other scripts in the process. The ssh connection has a set timeout of 5 minutes unless I log something back. So I figured out I would create a child process to run the task and let the parent process log back every 90 (or whatever) seconds. My issue is that I don't want to use sleep because if the task is finished sooner it will mess up the log.
I have also tried using Time, Time::HiRes and alarm, but they all mess up my log one way or another.
This is my code:
$log->info("uid $uid: calling the configure script for operation $mode,on $dst_path");
my $pid = fork();
die "Could not fork\n" if not defined $pid;
if ( $pid == 0 ) {
configure( $script_dir, $mode, $node, $uid, $gid); # this also uses a parallel process in its execution, but we don't have a non blocking wait
}
while ( !waitpid( $pid, WNOHANG ) ) {
sleep(90);
if ( !$pid ) {
$log->info("Still waiting for the process to finish"); # this should come up every 90 seconds of so
}
}
$log->info("uid $uid: configure script executed"); # this should come up only once, now I get it every 90 seconds
# do other stuff here after the execution of the configure sub is done
Unfortunately I inherited this architecture as it is and cannot change it because there are a lot of services based on it.
If you don't want to sleep, you can call select with a timeout. To implement this reliably, you can employ the self-pipe trick which involves creating a pipe, writing to the pipe in a SIGCHLD handler, and making the select call wait on the pipe's read handle.
Here's a simple example:
#!/usr/bin/perl
use strict;
use warnings;
use Errno qw(EINTR);
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Symbol qw(gensym);
sub make_non_blocking {
my $handle = shift;
my $flags = fcntl($handle, F_GETFL, 0)
or die("F_GETFL: $!");
fcntl($handle, F_SETFL, $flags | O_NONBLOCK)
or die("F_SETFL: $!");
}
my ($read_handle, $write_handle) = (gensym, gensym);
pipe($read_handle, $write_handle)
or die("pipe: $!");
make_non_blocking($read_handle);
make_non_blocking($write_handle);
local $SIG{CHLD} = sub {
syswrite($write_handle, "\0", 1);
};
my $pid = fork();
die("fork: $!") if !defined($pid);
if ($pid == 0) {
sleep(10);
exit;
}
my $rin = '';
vec($rin, fileno($read_handle), 1) = 1;
while (1) {
my $nfound = select(my $rout = $rin, undef, undef, 2);
if ($nfound < 0) {
# Error. Must restart the select call on EINTR.
die("select: $!") if $! != EINTR;
}
elsif ($nfound == 0) {
# Timeout.
print("still running...\n");
}
else {
# Child exited and pipe was written to.
last;
}
}
waitpid($pid, 0);
close($read_handle);
close($write_handle);
I tried to run the code and noticed a few things that may be your issue, but without knowing what configure does, I can't be sure. Here's what I found:
The child process doesn't exit after calling configure
waitpid does not change the value of $pid, so $pid is always 0 in the child and always the pid of the child in the parent.
What this means is that the parent is never writing out "Still waiting for the process to finish", the child is writing it out every 90 seconds after it completes it's call to configure.
Additionally, the child should print that message ever 90 seconds forever because it's waiting for pid 0 to send it the CHLD signal which won't happen because it doesn't have a child with pid 0.
I updated your code with a few stubs that does what I think you want (on a slightly tighter timeline because I don't like to wait :) ). My code makes the following assumptions that you may wish to change:
Log the waiting message every second
The child always exits with a status value of 0
Here's my code:
#!/usr/bin/env perl
use strict;
use warnings;
use Log::Log4perl qw(:easy);
use POSIX qw(:sys_wait_h);
Log::Log4perl->easy_init();
my ($uid,$mode,$dst_path,$script_dir,$node,$gid) = (0..5);
my $log = get_logger();
$log->info("uid $uid: calling the configure script for operation $mode,on $dst_path");
my $pid = fork();
die "Could not fork\n" if not defined $pid;
if ( $pid == 0 ) {
configure( $script_dir, $mode, $node, $uid, $gid); # this also uses a parallel process in its execution, but we don't have a non blocking wait
exit(0);
}
my $zombie;
while ( ($zombie = waitpid( $pid, WNOHANG ) ) != $pid) {
$log->info("Still waiting for the process to finish"); # this should come up every 90 seconds of so
sleep(1);
}
$log->info("uid $uid: configure script executed"); # this should come up only once, now I get it every 90 seconds
# do other stuff here after the execution of the configure sub is done
sub configure {
sleep 10;
}
When a CHLD signal handler is used in Perl, even uses of system and backticks will send the CHLD signal. But for the system and backticks sub-processes, neither wait nor waitpid seem to set $? within the signal handler on SuSE 11 linux. Is there any way to determine the return code of a backtick command when a CHLD signal handler is active?
Why do I want this? Because I want to fork(?) and start a medium length command and then call a perl package that takes a long time to produce an answer (and which executes external commands with backticks and checks their return code in $?), and know when my command is finished so I can take action, such as starting a second command. (Suggestions for how to accomplish this without using SIGCHLD are also welcome.) But since the signal handler destroys the backtick $? value, that package fails.
Example:
use warnings;
use strict;
use POSIX ":sys_wait_h";
sub reaper {
my $signame = shift #_;
while (1) {
my $pid = waitpid(-1, WNOHANG);
last if $pid <= 0;
my $rc = $?;
print "wait()=$pid, rc=$rc\n";
}
}
$SIG{CHLD} = \&reaper;
# system can be made to work by not using $?, instead using system return value
my $rc = system("echo hello 1");
print "hello \$?=$?\n";
print "hello rc=$rc\n";
# But backticks, for when you need the output, cannot be made to work??
my #IO = `echo hello 2`;
print "hello \$?=$?\n";
exit 0;
Yields a -1 return code in all places I might try to access it:
hello 1
wait()=-1, rc=-1
hello $?=-1
hello rc=0
wait()=-1, rc=-1
hello $?=-1
So I cannot find anywhere to access the backticks return value.
This same issue has been bugging me for a few days now. I believe there are 2 solutions required depending on where you have your backticks.
If you have your backticks inside the child code:
The solution was to put the line below inside the child fork. I think your statement above "if I completely turn off the CHLD handler around the backticks then I might not get the signal if the child ends" is incorrect. You will still get a callback in the parent when the child exits because the signal is only disabled inside the child. So the parent still gets a signal when the child exits. It's just the child doesn't get a signal when the child's child (the part in backticks) exits.
local $SIG{'CHLD'} = 'DEFAULT'
I'm no Perl expert, I have read that you should set the CHLD signal to the string 'IGNORE' but this did not work in my case. In face I believe it may have been causing the problem. Leaving that out completely appears to also solve the problem which I guess is the same as setting it to DEFAULT.
If you have backticks inside the parent code:
Add this line to your reaper function:
local ($!, $?);
What is happening is the reaper is being called when your code inside the backticks completes and the reaper is setting $?. By making $? local it does not set the global $?.
So, building on MikeKull's answer, here is a working example where the fork'd child uses backticks and still gets the proper return code. This example is a better representation of what I was doing, while the original example did not use forks and could not convey the entire issue.
use warnings;
use strict;
use POSIX ":sys_wait_h";
# simple child which returns code 5
open F, ">", "exit5.sh" or die "$!";
print F<<EOF;
#!/bin/bash
echo exit5 pid=\$\$
exit 5
EOF
close F;
sub reaper
{
my $signame = shift #_;
while (1)
{
my $pid = waitpid(-1, WNOHANG);
print "no child waiting\n" if $pid < 0;
last if $pid <= 0;
my $rc = $? >> 8;
print "wait()=$pid, rc=$rc\n";
}
}
$SIG{CHLD} = \&reaper;
if (!fork)
{
print "child pid=$$\n";
{ local $SIG{CHLD} = 'DEFAULT'; print `./exit5.sh`; }
print "\$?=" . ($? >> 8) . "\n";
exit 3;
}
# sig CHLD will interrupt sleep, so do multiple
sleep 2;sleep 2;sleep 2;
exit 0;
The output is:
child pid=32307
exit5 pid=32308
$?=5
wait()=32307, rc=3
no child waiting
So the expected return code 5 was received in the child when the parent's reaper was disabled before calling the child, but as indicated by ikegami the parent still gets the CHLD signal and a proper return code when the child exits.
I am trying to handle timeouts within threads. My script has 4 threads, each thread needs to execute commands, and kill the command process if it takes too long.
What I am doing is:
my $pid;
if (!($pid = fork))
{
my $pid2;
if (!($pid2 = fork))
{
exec_cmd $command;
}
local $SIG{ALRM} = sub {kill 9, $pid2;};
alarm $timeout;
waitpid $pid2, 0;
exit(0);
}
waitpid $pid, 0;
$ret = $?;
This is executed inside a thread, so when the child exits, other threads are still unjoined.
I think you are asking, how can I enforce a time limit on the execution of a child process spawned from a perl thread, and capture that child's exit code?
The easiest thing you could do (on a UNIX system) is to set an alarm on the child process itself:
my $pid = fork();
if (defined($pid) and $pid == 0) {
alarm($timeout); # Preserved across exec()
exec(...);
die "exec(): $!";
}
Exit status will still be available in waitpid/$? as usual.
The safest thing you could do is not to fork while multithreading. It's dangerous both for the application and the implementation. The application, because the child will have running copies of the parent's threads. The implementation, because it's relatively easy to coerce "Unbalanced scopes/saves/tmps/context" errors from threads when doing so.
I am writing a simple Perl script that should run other Perl scripts simultaneously. I don't know how to make the main program wait for running threads. Sleep IS NOT a suitable solution because of many reason. This is my "main" script:
#!/usr/bin/perl
use threads;
main:
{
if ($#ARGV == -1) { usage(); exit(1); }
my $hostname = $ARGV[0];
my $thrssh = threads ->create(\&ssh, $hostname);
my $thrdns = threads ->create(\&dns, $hostname);
my $thrping = threads ->create(\&ping, $hostname);
my $thrsmtp = threads ->create(\&smtp, $hostname);
my $thrproxy = threads ->create(\&proxy, $hostname);
}
sub ssh {
threads->detach();
my $hostname = #_;
#print "SSH\n";
#LAUNCH SSH SCRIPT
}
#OTHER SUBROUTINES...
sub proxy {
threads->detach();
my $hostname = #_;
#print "PROXY\n";
#LAUNCH PROXY SCRIPT
}
If I try to run this script the first thing I can notice is that prints are "sequential", I thought text was messed up but maybe Print is exclusive I don't know. Main problem is that the last two subroutines don't have time to be executed.
SSH
DNS
PING
Perl exited with active threads:
2 running and unjoined
0 finished and unjoined
0 running and detached
If I use join instead of detach the subroutines become "sequential", for example if I put a sleep in sub ssh other threads will wait before starting. I want them to be parallel and the main program to close ONLY when all threads are finished, any help?
I actually have another question, if I have to run multiple threads in a foreach cicle when I am supposed to join them? ie:
my $thrssh;
foreach $mynode ($nodeset->get_nodelist) {
#...
$thrssh = threads ->create(\&ssh, $port, $hostname);
#...
}
$thssh->join();
Is that right?
You need to join all your threads from the main thread after they have all been started. Don't detatch if you don't want the interpreter to exit while the threads are still running.
...
my $thrssh = threads ->create(\&ssh, $hostname);
my $thrdns = threads ->create(\&dns, $hostname);
...
$thrssh->join();
$thrdns->join();
...
Regarding your edit: no, it's not right. You need to keep a reference to each thread you create, otherwise you can't join them.
Do something like:
my #thrs;
foreach $mynode ($nodeset->get_nodelist) {
#...
$thrssh = threads ->create(\&ssh, $port, $hostname);
push #thrs, $thrssh;
#...
}
$_->join() for #thrs;