Perl kill process with timeout ignored - perl

I was testing my source code, in which the child process calls several other programs (some of which are C++).
#Other variables and functions
my $MAX_TIME = 10;#testing 10 minutes
my $timeRemaining = $MAX_TIME * 60;
my $pid = fork();
if ( $pid == 0 ) {
#child process
my $nowTime = localtime;
print "Run started at $nowTime\n";
#This run() calls a for loop in perl, in each iteration there are several C++ programs
run();
setpgrp(0,0);
}
elsif ($pid > 0){
my $nowTime = localtime;
eval{
local $SIG{ALRM} = sub {
kill -9, $pid;
print "Run completed at $nowTime\nJob time out for $MAX_TIME minutes\n";
log();
die "TIMEOUT!\n";
};
alarm $timeRemaining;
waitpid($pid, 0);
};
print "Run completed at $nowTime with no timeout\n";
}
When I checked the print out, I noticed that after 10 minutes, the "Run completed at $nowTime with no timeout\n" part gets printed out, and the child process is still executing. The die "TIMEOUT!\n"; part in the parent process does not get executed.
Is it because of the C++ programs that the perl program calls cannot be killed once it started?

First of all, kill is failing because $pid isn't a process group.
run();
setpgrp(0,0);
should be
setpgrp(0,0);
run();
Secondly, the reason you see
Run completed at $nowTime with no timeout
even when there's a timeout is that you execute
print "Run completed at $nowTime with no timeout\n";
whether there's a timeout or not.
Thirdly, you don't disable the alarm when the child is reaped. Add
alarm(0);
Fourthly, you expect $nowTime to contain the current time without making it so.
Finally, you still need to reap your child even if you kill it. (Ok, this can be skipped if the parent exits immediately anyway.)
Fixed:
use strict;
use warnings;
use POSIX qw( strftime );
sub current_time { strftime("%Y-%m-%d %H:%M:%S", localtime) }
sub run {
print("a\n");
system('perl', '-e', 'sleep 3;');
print("b\n");
system('perl', '-e', 'sleep 3;');
print("c\n");
}
my $MAX_TIME = 5;
my $pid = fork();
die($!) if !defined($pid);
if ($pid) {
if (eval{
local $SIG{ALRM} = sub {
kill KILL => -$pid;
die "TIMEOUT!\n";
};
alarm($MAX_TIME);
waitpid($pid, 0);
alarm(0);
return 1;
}) {
print "[".current_time()."] Run completed.\n";
} else {
die($#) if $# ne "TIMEOUT!\n";
print "[".current_time()."] Run timed out.\n";
waitpid($pid, 0);
print "[".current_time()."] Child reaped.\n";
}
} else {
print "[".current_time()."] Run started.\n";
setpgrp(0,0);
run();
}
Output:
[2017-05-11 14:58:06] Run started.
a
b
[2017-05-11 14:58:11] Run timed out.
[2017-05-11 14:58:11] Child reaped.

Related

How to set timeout for a long running Sybase sp in Perl

I'm calling a stored procedure which deletes data from Sybase DB in a Perl. But the sp takes hours to complete.
I just want the sp to run for 1 hour, then no matter whether it completes or not I want the codes afterwards to be running. How can I implement this?
sub DelRef {
print "starting defRefData\n";
$db = new Sybapi($user, $password, $server, $margin_database);
#the following sql will take hours
$db->exec_sql("exec CPN_Margins..clean_up_refData_db '$XrefCode'");
}
&DelRef();
print "process is done\n";
$db->close();
I'm always wary of using alarm to interrupt a system call, as I find it hard to predict when the signal will be ignored or worse.
An alternative is to run your long-running code in a background process, and monitor its progress in the main process.
# DelRef() might take a while ...
my $start_time = time;
my $pid = fork();
if ($pid == 0) {
# child process
DelRef();
exit 0;
}
# parent process
while (1) {
use POSIX qw( WNOHANG );
my $waitpid = waitpid $pid, WNOHANG;
if ($pid == $waitpid) {
print STDERR "DelRef() finished successfully\n";
last;
}
if (time - $start_time > 3600) {
print STDERR "DelRef() didn't finish in an hour\n";
kill 'TERM',$pid; # optional
last;
}
print STDERR "DelRef() is still running ...\n";
sleep 60;
}
print STDERR "... the rest of the script ...\n";
You can use 'alarm' for this https://perldoc.perl.org/functions/alarm.html
my $timeout = 3600; # 1hr = 3600 sec
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm $timeout;
$db = new Sybapi($user, $password, $server, $margin_database);
$db->exec_sql("exec CPN_Margins..clean_up_refData_db '$XrefCode'");
alarm 0;
};
if ($#) {
die unless $# eq "alarm\n"; # propagate unexpected errors
# timed out
}
else {
# didn't timed out
}
Also what is 'Sybapi'? In the past I have use 'DBD::Sybase' to connect to Sybase ASE(or 'sybperl' in old legacy code), and 'DBD::SQLAnywhere' to connect to Sybase IQ.

execute process in Perl with options for stopping,resuming,killing using IPC

I almost have no idea of forking. I tried to research, but I couldn't find a simple example of how to do these things. For windows I found a good module and wrote this piece of code, which is doing what I want.
Win32::Process::Create( my $ProcessObj,
"$jobs{$id}->{path}", "execute job", 0, NORMAL_PRIORITY_CLASS, "." )
|| die ErrorReport();
print "Available commands:\n1.Suspend\n2.Resume\n3.Kill\n";
while (1) {
chomp( my $input = <STDIN> );
if ( $input eq "1" ) {
$ProcessObj->Suspend();
}
if ( $input eq "2" ) {
$ProcessObj->Resume();
}
if ( $input eq "3" ) {
print "Returned to main menu.\n";
$ProcessObj->Kill(0);
return;
}
}
So my question is if there is a way to do this with forking?
And here is my try for forking:
unless ( $pid = fork) {
unless (fork) {
exec "$jobs{$id}->{path}";
die "exec failed!";
}
exit 0;
}
waitpid($pid, 0);
I have a program which is printing Hello world every 3 seconds and I want to pause it, resume it and kill it, if this example will help.
Forks::Super makes this simple and platform-independent.
use Forks::Super;
...
my $pid = fork { exec => $jobs{$id}->{path} };
...
$pid->suspend;
...
$pid->resume;
...
$pid->kill; # or $pid->kill('TERM'), $pid->kill('QUIT'), etc.
If you must go by hand, the signals to use are 'SIGSTOP' and 'SIGCONT'.
A command-line demo
perl -wE'
$pid = fork // die "Cant fork: $!";
if ($pid == 0) {
for (1..6) { say "\tkid ..."; sleep 1; };
say "\tKID DONE"; exit;
};
sleep 3;
kill "STOP", $pid;
for (1..2) { say "Parent here!"; sleep 1};
kill "CONT", $pid;
wait;
'
prints
kid ...
kid ...
kid ...
Parent here!
Parent here!
kid ...
kid ...
kid ...
KID DONE
Then you'd need to implement this in your STDIN-driven management.
But I suggest to try to resolve the installation of Forks::Super, from mob's answer.
A STDIN controlled example. The forked process and the parent write to a file for a test.
use warnings;
use strict;
use feature 'say';
#use IO::Handle; # needed pre v5.16 (for autoflush)
my $fh_kid;
$SIG{INT} = sub { close $fh_kid; exit 1 };
my $file = 'kidfile.out';
open $fh_kid, '>', $file or die "Can't open $file: $!";
$fh_kid->autoflush;
my $pid = fork // die "Can't fork: $!";
if ($pid == 0) {
$SIG{TERM} = sub { close $fh_kid; exit 1 };
for (1..20) {
say $fh_kid "\tkid, $_";
sleep 1;
}
exit;
}
say "Parent: started $pid";
while (1) {
chomp (my $input = <STDIN>);
if (not $input) {
close $fh_kid;
last;
}
if ($input == 1) {
kill 'STOP', $pid;
say "Parent: STOP-ed $pid";
say $fh_kid "Parent STOP-ed $pid";
}
elsif ($input == 2) {
say "Parent: CONT the $pid";
kill 'CONT', $pid;
}
elsif ($input == 3) {
close $fh_kid;
kill 'TERM', $pid;
say "Parent: TERM-ed the $pid";
}
}
my $gone = waitpid $pid, 0;
if ($gone > 0) { say "Child $gone exited with: $?" }
elsif ($gone < 0) { say "No such process ($gone), reaped already?" }
else { say "Still out there?" }
This needs more detail but it does show what kinds of things get involved.
Output (with comments)
Parent: started 19628
1 # entered a few seconds after starting
Parent: STOP-ed 19628
2 # after waiting for a minute
Parent: CONT the 19628
3 # after waiting for a few more seconds
Parent: TERM-ed the 19628
^C # quit STDIN
We allow the kid to print to a file for a few seconds (so a few times) and then STOP it (1), then wait for a bit and then CONTinue the child (2) and let it print a few more times before killing it (3).
The output kidfile.out has a few lines from the child, then a line from the parent, and then a few more lines from the child, confirming that the child was paused, resumed, and stopped.

How to autorun Perl after killed?

I have script that use multiple $pid. So if too many connection of child spawn, my server hang and program not running.
I want to restart it automatic from cron job at my server, but it's cannot running because I use alternatif cPanel. So I want restart it automatic from it script.
I try to restart it with :
kill 9, $pid;
sleep 60;
and will display output :
Child Spawned : 15945
Killed
But I don't know how to autorun or re-execute
It looks you want a per-forking worker pool. Your server process starts a number of child processes to handle requests, and automatically restarts any that die.
A basic template:
use strict;
use warnings;
use POSIX qw(sigprocmask SIG_BLOCK SIG_UNBLOCK SIGINT SIGTERM WNOHANG);
my $pool_size = 4; # 4 workers
my %pool;
# When one or more workers die, delete them from the pool
$SIG{CHLD} = sub {
while ((my $pid = waitpid(-1, WNOHANG)) > 0) {
delete $pool{$pid};
}
};
# If a fatal signal is sent to the server, kill all children and exit
for my $sig (qw(INT TERM)) {
$SIG{$sig} = sub {
local $SIG{CHLD} = 'IGNORE';
kill $sig => keys %pool;
exit;
};
}
# HUP = restart all workers
$SIG{HUP} = sub {
print "Caught HUP, restarting workers.\n";
kill TERM => keys %pool
};
# Set up pool
make_worker() for (1..$pool_size);
# Maintain population
while (1) {
sleep; # wait for signal
while (keys %pool < $pool_size) {
make_worker();
}
}
exit;
sub make_worker {
# Block INT signal during fork, so parent handler is not called
my $sigset = POSIX::SigSet->new(SIGINT, SIGTERM);
sigprocmask(SIG_BLOCK, $sigset) or die "Couldn't block signals for fork: $!";
my $pid = fork;
die "fork: $!" if !defined $pid;
if ($pid) {
sigprocmask(SIG_UNBLOCK, $sigset) or die "Couldn't unblock signals for fork: $!";
$pool{$pid} = 1;
return;
}
else {
$SIG{$_} = 'DEFAULT' for qw(INT TERM);
sigprocmask(SIG_UNBLOCK, $sigset) or die "Couldn't unblock signals for child: $!";
# Your worker code goes here.
exit;
}
}
For simply restarting a single command in a loop, try;
while(1) {
system("/path/to/your-command", "--args");
}
As soon as the command dies (for any reason), it is re-executed. Processing the exit code of system is not that simple, so I recommend using IPC::System::Simple here.
use IPC::System::Simple qw(system);
use Try::Tiny;
while(1) {
try { system(...) }
catch { "Command failed, restarting: $!" };
}
You should also detect if the command exited too quickly, which would indicate a fatal error.

Killing child and its children when child was created using open

Here's my code, with error handling and other stuff removed for clarity:
sub launch_and_monitor {
my ($script, $timeout) = #_;
sub REAPER {
while ((my $child = waitpid(-1, &WNOHANG)) > 0) {}
$SIG{CHLD} = \&REAPER;
}
$SIG{CHLD} = \&REAPER;
my $pid = fork;
if (defined $pid) {
if ($pid == 0) {
# in child
monitor($timeout);
}
else {
launch($script);
}
}
}
The launch sub executes a shell script which in turn launches other processes, like so:
sub launch($) {
my ($script) = #_;
my $pid = open(PIPE, "$script|");
# write pid to pidfile
if ($pid != 0) {
while(<PIPE>) {
# do stuff with output
}
close(PIPE) or die $!;
}
}
The monitor sub basically just waits for a specified period of time and then attempts to kill the shell script.
sub monitor($) {
my ($timeout) = #_;
sleep $timeout;
# check if script is still running and if so get pid from pidfile
if (...) {
my $pid = getpid(...);
kill 9, $pid;
}
}
This kills the script, however, it does not kill any of its subprocesses. How to fix it?
You can do this with process groups, if your operating system supports them. You need to make the script process become a process group leader. The child processes that it runs will inherit the process group from their parent. You can then use kill to send a signal to each process in the group at the same time.
In launch(), you will need to replace the open line with one that forks. Then in the child, you would call setpgrp() before exec'ing the command. Something like the following should work:
my $pid = open(PIPE, "-|");
if (0 == $pid) {
setpgrp(0, 0);
exec $script;
die "exec failed: $!\n";
}
else {
while(<PIPE>) {
# do stuff with output
}
close(PIPE) or die $!;
}
Later, to kill the script process and its children, negate the process ID that you're signalling:
kill 9, -$pid;
In general, I don't think you can expect signals to be propagated into all child processes; this isn't specific to perl.
That said, you might be able to use the process group signal feature built into perl kill():
...if SIGNAL is negative, it kills process groups instead of processes...
You probably need to use setpgrp() on your (direct) child process, then change your kill call to something like:
kill -9, $pgrp;
Try adding:
use POSIX qw(setsid);
setsid;
at the top of your launch_and_monitor function. This will put your processes in a separate session, and cause things to exit when the session leader (i.e. the master) exits.
Killing a processgroup works, but don't forget the parent can be killed alone too. Assuming child processes have an event loop, they can check the parent socket that was created in a socketpair prior doing the fork() for validness. In fact, select() cleanly exits when the parent socket is gone, all that needs to be done is to check the socket.
E.g.:
use strict; use warnings;
use Socket;
$SIG{CHLD} = sub {};
socketpair(my $p, my $c, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die $!;
print "parent $$, fork 2 kids\n";
for (0..1){
my $kid = fork();
unless($kid){
child_loop($p, $c);
exit;
}
print "parent $$, forked kid $kid\n";
}
print "parent $$, waiting 5s\n";
sleep 5;
print "parent $$ exit, closing sockets\n";
sub child_loop {
my ($p_s, $c_s) = #_;
print "kid: $$\n";
close($c_s);
my $rin = '';
vec($rin, fileno($p_s), 1) = 1;
while(1){
select my $rout = $rin, undef, undef, undef;
if(vec($rout, fileno($p_s), 1)){
print "kid: $$, parent gone, exiting\n";
last;
}
}
}
Runs like this:
tim#mint:~$ perl ~/abc.pl
parent 5638, fork 2 kids
parent 5638, forked kid 5639
kid: 5639
parent 5638, forked kid 5640
parent 5638, waiting 5s
kid: 5640
parent 5638 exit, closing sockets
kid: 5640, parent gone, exiting
kid: 5639, parent gone, exiting
tim#mint:~$

How can I timeout a forked process that might hang?

I am writing a Perl script that will write some inputs and send those inputs to an external program. There is a small but non-zero chance that this program will hang, and I want to time it out:
my $pid = fork;
if ($pid > 0){
eval{
local $SIG{ALRM} = sub { die "TIMEOUT!"};
alarm $num_secs_to_timeout;
waitpid($pid, 0);
alarm 0;
};
}
elsif ($pid == 0){
exec('echo blahblah | program_of_interest');
exit(0);
}
As it stands now, after $num_secs_to_timeout, program_of_interest still persists. I tried to kill it in the anonymous subroutine for $SIG{ALRM} as follows:
local $SIG{ALRM} = sub{kill 9, $pid; die "TIMEOUT!"}
but this doesn't do anything. program_of_interest is still persisting. How do I go about killing this process?
I was able to successfully kill my exec()ed process by killing the process group, as shown as the answer to question In perl, killing child and its children when child was created using open. I modified my code as follows:
my $pid = fork;
if ($pid > 0){
eval{
local $SIG{ALRM} = sub {kill 9, -$PID; die "TIMEOUT!"};
alarm $num_secs_to_timeout;
waitpid($pid, 0);
alarm 0;
};
}
elsif ($pid == 0){
setpgrp(0,0);
exec('echo blahblah | program_of_interest');
exit(0);
}
After timeout, program_of_interest is successfully killed.
The above code (by strictlyrude27) didn't work out of the box, because -$PID is spelt in capitals.
(BTW: there's also: http://www.gnu.org/software/coreutils/manual/html_node/timeout-invocation.html)
Here's an example with test:
#!/usr/bin/perl
use strict;
use warnings;
use File::Basename;
my $prg = basename $0;
my $num_secs_sleep = 2;
my $num_secs_to_timeout = 1;
my $orig_program = "sleep $num_secs_sleep; echo \"Look ma, survived!\"";
my $program = $orig_program;
my $expect = "";
if (#ARGV){
if($ARGV[0] eq "test"){
test();
exit 0;
} elsif (#ARGV == 1) {
$num_secs_to_timeout = $ARGV[0];
} elsif (#ARGV == 2) {
$program = $ARGV[0];
$num_secs_to_timeout = $ARGV[1];
} else {
die "Usage: $prg [ \"test\" | [program] seconds ] "
}
}
if($orig_program eq $program) {
if(#ARGV < 2) {
$expect = $num_secs_to_timeout > $num_secs_sleep ?
"(we expected to survive.)" : "(we expected to TIME OUT!)";
}
print STDERR "sleeping: $num_secs_sleep seconds$/";
}
print STDERR <<END;
timeout after: $num_secs_to_timeout seconds,
running program: '$program'
END
if($orig_program eq $program) {
print STDERR "$expect$/";
}
exit Timed::timed($program, $num_secs_to_timeout);
sub test {
eval "use Test::More qw(no_plan);";
my $stdout;
close STDOUT;
open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!";
Timed::timed("sleep 1", 3);
is($stdout, undef);
Timed::timed("sleep 2", 1);
is($stdout, "TIME OUT!$/");
}
################################################################################
package Timed;
use strict;
use warnings;
sub timed {
my $retval;
my ($program, $num_secs_to_timeout) = #_;
my $pid = fork;
if ($pid > 0){ # parent process
eval{
local $SIG{ALRM} =
sub {kill 9, -$pid; print STDOUT "TIME OUT!$/"; $retval = 124;};
alarm $num_secs_to_timeout;
waitpid($pid, 0);
alarm 0;
};
return defined($retval) ? $retval : $?>>8;
}
elsif ($pid == 0){ # child process
setpgrp(0,0);
exec($program);
} else { # forking not successful
}
}
Hmmm your code works for me, after some minor modifications - which I assume are changes made by yourself to make the code into a generic example.
So that leaves me with two ideas:
You removed the problem when you created the sample code - try creating a small sample that actually runs (I had to change 'program_of_interest' and $num_secs_to_timeout to real values to test it). Make sure the sample has the same problem.
It's something to do with the program_of_interest you're running - as far as I know, you can't mask a kill 9, but maybe there's something going on. Have you tried testing your code with a really simple script. I created one for my testing that goes while (1) { print "hi\n"; sleep 1; }
Something else.
Good luck...
The only way SIGKILL can be ignored is if the process is stuck in a system call which is uninterruptible. Check the state of the hung process (with ps aux) if the state is D, then the process can't be killed.
You might also want to check that the function is being called by outputting something from it.