How can I timeout a forked process that might hang? - perl

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.

Related

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.

Perl kill process with timeout ignored

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.

xargs equivalent in perl

I liked to make something, what xargs in shellscripting does. Thus:
Running external commands by the exec() system calls
as child processes
parallel
waiting their execution (ideally with a timeout)
How can it be done in perl?
You could use the Proc::Background module.
Particularly interesting is the sub timeout_system(..).
Here's an example coming from the Proc::Background module page:
use Proc::Background;
timeout_system($seconds, $command, $arg1);
timeout_system($seconds, "$command $arg1");
my $proc1 = Proc::Background->new($command, $arg1, $arg2);
my $proc2 = Proc::Background->new("$command $arg1 1>&2");
$proc1->alive;
$proc1->die;
$proc1->wait;
my $time1 = $proc1->start_time;
my $time2 = $proc1->end_time;
# Add an option to kill the process with die when the variable is
# DETROYed.
my $opts = {'die_upon_destroy' => 1};
my $proc3 = Proc::Background->new($opts, $command, $arg1, $arg2);
$proc3 = undef;
my #join;
push #join, fasync {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm 10;
# exec(..);
sleep 20;
print "job1\n";
};
push #join, fasync {
print "job2\n";
};
# wait for jobs
$_->() for #join;
sub fasync(&) {
my ($worker) = #_;
my $pid = fork() // die "can't fork!";
if ($pid == 0) {
$worker->();
exit(0);
}
return sub {
my ($flags) = #_;
return waitpid($pid, $flags // 0);
}
}

How to check if command executed with IPC::open3 is hung?

I'm using the following script to capture STDIN, STDOUT and STDERR from the command passed as an argument.
#!/usr/bin/perl
use strict;
use warnings;
use IPC::Open3;
local(*CMD_IN, *CMD_OUT, *CMD_ERR);
my $pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $ARGV[0]);
close(CMD_IN);
my #stdout_output = <CMD_OUT>;
my #stderr_output = <CMD_ERR>;
close(CMD_OUT);
close(CMD_ERR);
waitpid ($pid, 0); # reap the exit code
print "OUT:\n", #stdout_output;
print "ERR:\n", #stderr_output;
It all works good with the exception that I'm not sure how to monitor if the command passed is hung. Could you please suggest a way?
I've borrowed this snippet originally from 'Programming Perl'.
You can use select or IO::Select and provide a timeout. If you want to read both from stdout and stderr, you should do that anyway (see the documentation of IPC::Open3).
Here's an example program using IO::Select:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Select;
use IPC::Open3;
use Symbol 'gensym';
my ($cmd_in, $cmd_out, $cmd_err);
$cmd_err = gensym;
my $pid = open3($cmd_in, $cmd_out, $cmd_err, $ARGV[0]);
close($cmd_in);
my $select = IO::Select->new($cmd_out, $cmd_err);
my $stdout_output = '';
my $stderr_output = '';
while (my #ready = $select->can_read(5)) {
foreach my $handle (#ready) {
if (sysread($handle, my $buf, 4096)) {
if ($handle == $cmd_out) {
$stdout_output .= $buf;
}
else {
$stderr_output .= $buf;
}
}
else {
# EOF or error
$select->remove($handle);
}
}
}
if ($select->count) {
print "Timed out\n";
kill('TERM', $pid);
}
close($cmd_out);
close($cmd_err);
waitpid($pid, 0); # reap the exit code
print "OUT:\n", $stdout_output;
print "ERR:\n", $stderr_output;
Notes:
I use lexical vars for file handles. This requires the use of gensym for the stderr handle.
The argument to can_read is the timeout in seconds.
I use sysread for non-buffered IO.
I terminate the child if there's a read timeout.
I came up with the following solution heavily based on this answer.
However using select and avoiding signals as in nwellnhof's example looks much cleaner which is why I accepted it. I'm posting it here if somebody is interested:
my $pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
if ($pid > 0){
eval{
local $SIG{ALRM} = sub {kill 9, $pid;};
alarm 6;
waitpid($pid, 0);
alarm 0;
};
}

How to multithread seeing if a webpage exists in Perl?

I'm writing a Perl script that takes in a list of URLs and checks to see if they exist. (Note that I only care if they exist; I don’t care what their contents are. Here’s the important part of the program.
use LWP::Simple qw($ua head);
if (head($url))
{
$numberAlive ++;
}
else
{
$numberDead ++;
}
Right now the program works fine; however, I want it to run faster. Thus I'm considering making it multithreaded. I assume that the slow part of my program is contacting the server for each URL; therefore, I'm looking for a way in which I can send out requests to the URLs of other webpages on my list while I'm waiting for the first response. How can I do this? As far as I can tell, the head routine doesn't have a callback that can get called once the server has responded.
Begin with familiar-looking front matter.
#! /usr/bin/env perl
use strict;
use warnings;
use 5.10.0; # for // (defined-or)
use IO::Handle;
use IO::Select;
use LWP::Simple;
use POSIX qw/ :sys_wait_h /;
use Socket;
Global constants control program execution.
my $DEBUG = 0;
my $EXIT_COMMAND = "<EXIT>";
my $NJOBS = 10;
URLs to check arrive one per line on a worker’s end of the socket. For each URL, the worker calls LWP::Simple::head to determine whether the resource is fetchable. The worker then writes back to the socket a line of the form url : *status* where *status* is either "YES" or "NO" and represents the space character.
If the URL is $EXIT_COMMAND, then the worker exits immediately.
sub check_sites {
my($s) = #_;
warn "$0: [$$]: waiting for URL" if $DEBUG;
while (<$s>) {
chomp;
warn "$0: [$$]: got '$_'" if $DEBUG;
exit 0 if $_ eq $EXIT_COMMAND;
print $s "$_: ", (head($_) ? "YES" : "NO"), "\n";
}
die "NOTREACHED";
}
To create a worker, we start by creating a socketpair. The parent process will use one end and each worker (child) will use the other. We disable buffering at both ends and add the parent end to our IO::Select instance. We also note each child’s process ID so we can wait for all workers to finish.
sub create_worker {
my($sel,$kidpid) = #_;
socketpair my $parent, my $kid, AF_UNIX, SOCK_STREAM, PF_UNSPEC
or die "$0: socketpair: $!";
$_->autoflush(1) for $parent, $kid;
my $pid = fork // die "$0: fork: $!";
if ($pid) {
++$kidpid->{$pid};
close $kid or die "$0: close: $!";
$sel->add($parent);
}
else {
close $parent or die "$0: close: $!";
check_sites $kid;
die "NOTREACHED";
}
}
To dispatch URLs, the parent grabs as many readers as are available and hands out the same number of URLs from the job queue. Any workers that remain after the job queue is empty receive the exit command.
Note that print will fail if the underlying worker has already exited. The parent must ignore SIGPIPE to prevent immediate termination.
sub dispatch_jobs {
my($sel,$jobs) = #_;
foreach my $s ($sel->can_write) {
my $url = #$jobs ? shift #$jobs : $EXIT_COMMAND;
warn "$0 [$$]: sending '$url' to fd ", fileno $s if $DEBUG;
print $s $url, "\n" or $sel->remove($s);
}
}
By the time control reaches read_results, the workers have been created and received work. Now the parent uses can_read to wait for results to arrive from one or more workers. A defined result is an answer from the current worker, and an undefined result means the child has exited and closed the other end of the socket.
sub read_results {
my($sel,$results) = #_;
warn "$0 [$$]: waiting for readers" if $DEBUG;
foreach my $s ($sel->can_read) {
warn "$0: [$$]: reading from fd ", fileno $s if $DEBUG;
if (defined(my $result = <$s>)) {
chomp $result;
push #$results, $result;
warn "$0 [$$]: got '$result' from fd ", fileno $s if $DEBUG;
}
else {
warn "$0 [$$]: eof from fd ", fileno $s if $DEBUG;
$sel->remove($s);
}
}
}
The parent must keep track of live workers in order to collect all results.
sub reap_workers {
my($kidpid) = #_;
while ((my $pid = waitpid -1, WNOHANG) > 0) {
warn "$0: [$$]: reaped $pid" if $DEBUG;
delete $kidpid->{$pid};
}
}
Running the pool executes the subs above to dispatch all URLs and return all results.
sub run_pool {
my($n,#jobs) = #_;
my $sel = IO::Select->new;
my %kidpid;
my #results;
create_worker $sel, \%kidpid for 1 .. $n;
local $SIG{PIPE} = "IGNORE"; # writes to dead workers will fail
while (#jobs || keys %kidpid || $sel->handles) {
dispatch_jobs $sel, \#jobs;
read_results $sel, \#results;
reap_workers \%kidpid;
}
warn "$0 [$$]: returning #results" if $DEBUG;
#results;
}
Using an example main program
my #jobs = qw(
bogus
http://stackoverflow.com/
http://www.google.com/
http://www.yahoo.com/
);
my #results = run_pool $NJOBS, #jobs;
print $_, "\n" for #results;
the output is
bogus: NO
http://www.google.com/: YES
http://stackoverflow.com/: YES
http://www.yahoo.com/: YES
Another option is HTTP::Async.
#!/usr/bin/perl
use strict;
use warnings;
use HTTP::Request;
use HTTP::Async;
my $numberAlive = 0;
my $numberDead = 0;
my #urls = ('http://www.perl.com','http://www.example.xyzzy/foo.html');
my $async = HTTP::Async->new;
# you might want to wrap this in a loop to deal with #urls in batches
foreach my $url (#urls){
$async->add( HTTP::Request->new( HEAD => $url ) );
}
while ( my $response = $async->wait_for_next_response ) {
if ($response->code == 200){$numberAlive ++;}
else{$numberDead ++;}
}
print "$numberAlive Alive, $numberDead Dead\n";
Worker-based parallelisation (using your choice of threads or processes):
use strict;
use warnings;
use feature qw( say );
use threads; # or: use forks;
use LWP::Simple qw( head );
use Thread::Queue::Any qw( );
use constant NUM_WORKERS => 10; # Or whatever.
my $req_q = Thread::Queue::Any->new();
my $resp_q = Thread::Queue::Any->new();
my #workers;
for (1..NUM_WORKERS) {
push #workers, async {
while (my $url = $req_q->dequeue()) {
my $is_alive = head($url) ? 1 : 0;
$resp_q->enqueue($is_alive);
}
};
}
$req_q->enqueue($_) for #urls;
my ($alive, $dead);
for (1..#urls) {
my $is_alive = $resp_q->dequeue();
++( $is_alive ? $alive : $dead );
}
$req_q->enqueue(undef) for #workers;
$_->join for #workers;
say $alive;
say $dead;