Process hanging -SIGALRM not delivered- Perl - perl

I have a command that I'm executing using OPEN with pipe, and I want to set a timeout of 10 seconds and have the sub process aborted if the execution time exceeds this. However, my code just causes the program to hang- Why is my ALARM not getting delivered properly?
my $pid = 0;
my $cmd = "someCommand";
print "Running Command # $num";
eval {
local $SIG{ALRM} = sub {
print "alarm \n";
kill 9, $pid;
};
alarm 10;
pid = open(my $fh, "$cmd|");
alarm 0;
};
if($#) {
die unless $# eq "alarm \n";
} else {
print $_ while(<$fh>);
}
EDIT:
So From the answers below, This is what I have:
my $pid = open(my $fh, qq(perl -e 'alarm 10; exec \#ARGV; die "exec: $!\n" ' $cmd |));
print $_ while(<$fh>);
But this print ALARM CLOCK to the console when the alarm times out...whereas I dont specify this anywhere in the code...how can I get rid of this, and where would I put the custom alarm event handler?
Thanks!

I want to set a timeout of 10seconds and have the sub process aborted if the execution time exceeds this
A different approach is to set the alarm on the subprocess itself, with a handy scripting language you already have:
my $cmd = "someCommand";
my $pid = open(my $child_stdout, '-|',
'perl', '-e', 'alarm 10; exec #ARGV; die "exec: $!"', $cmd);
...
Your child process will initially be perl (well, the shell and then perl), which will set an alarm on itself and then exec (replace itself with) $someCommand. Pending alarms, however, are inherited across exec()s.

All your code is doing is setting a 10 second timeout on the open call, not on the whole external program. You want to bring the rest of your interaction with the external command into the eval block:
eval {
local $SIG{ALRM} = sub {
print "alarm \n";
kill 9, $pid;
};
alarm 10;
$pid = open(my $fh, "$cmd|");
print while <$fh>;
close $fh;
alarm 0;
};
if($#) {
die unless $# eq "alarm \n";
}

Related

Signal handler not working with double eval

I have this code to timeout a long-running process (sleep in this case):
#!/usr/bin/env perl
use strict;
use warnings;
die "Usage: $0 SLEEP TIMEOUT\n" unless #ARGV == 2;
my ( $sleep, $timeout ) = #ARGV;
$|++;
eval {
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm $timeout;
eval {
# long-running process
print "Going to sleep ... ";
sleep $sleep;
print "DONE\n";
};
alarm 0; # cancel timeout
};
die $# if $#;
When I run it as ./alarm 5 2, I expect it to die saying "TIMEOUT". However it exits with 0 and says nothing. It works as expected when I remove the inner eval block (not the block's content, just the eval) though. Can someone explain why is that? Thanks.
Because you trap the error in the first eval block and the second eval block does not have an exception and clears $#.
eval {
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm $timeout;
eval {
# long-running process
print "Going to sleep ... ";
A: sleep $sleep;
print "DONE\n";
};
B:
alarm 0; # cancel timeout
C:};
die $# if $#;
$sleep > $timeout, so at A: your program throws a SIGALRM. The signal is caught by your local signal handler and calls die "TIMEOUT\n". So Perl sets $# to "TIMEOUT\n" and resumes execution at B:. Your program then makes it to C: without any additional errors. Since your outer eval block completed normally, Perl clears $#, and your final die statement does not execute.
To do what it seems like you want to do, you could either
don't use eval on the outer block
put another die $# if $# call at the end of the outer block

Perl - custom keystroke handlers

I'm trying to implement custom handlers for given keystrokes so that I can change mode when my script is fetching data from file. How is that possible without any WHILE loop?
I was looking into Term::ReadKey but I dont think it does what I need. Maybe I should connect it with something though I can't find any solution on google.
I've just started with perl scripting :)
Here is an example of how to avoid busy waiting when waiting for a keyboard input:
use strict;
use warnings;
use IPC::Open2;
my $pid1 = run_cmd('read_key');
my $pid2 = run_cmd('counter');
print "Master: waiting for keyboard event..\n";
waitpid $pid1, 0;
print "Master: Done.\n";
kill 'TERM', $pid2;
sub run_cmd {
my ($cmd) = #_;
open(OUT, ">&STDOUT") or die "Could not duplicate STDOUT: $!\n";
open(IN, ">&STDIN") or die "Could not duplicate STDIN: $!\n";
my $pid = open2('>&OUT', '<&IN', $cmd);
return $pid;
}
where read_key is:
use strict;
use warnings;
use Term::ReadKey;
ReadMode 4;
END { ReadMode 0 }
my $key = ReadKey(0);
print "$key\n";
and counter is:
use strict;
use warnings;
$SIG{TERM} = sub { die "Child (counter): Caught a sigterm. Abort.\n" };
my $i = 0;
while (++$i) {
sleep 1;
print "$i\n";
}
Example output:
Name "main::IN" used only once: possible typo at ./p.pl line 19.
Name "main::OUT" used only once: possible typo at ./p.pl line 18.
Master: waiting for keyboard event..
1
2
3
q
Master: Done.
Child (counter): Caught a sigterm. Abort.

coreutils timeout simulate on perl

I trying to make replacement for timeout using perl (need in centos5)
here the script:
#!/usr/bin/perl
use strict;
my $pid=$$;
my $timeout=shift;
my #args=#ARGV;
eval {
local $SIG{ALRM} = sub {
print "Timed OUT!\n";
exit 142;
kill 9,$pid;
};
alarm($timeout);
system(#args);
};
exit $?;
while testing it I found:
Here all fine
time /tmp/timeout 3 sleep 6
Timed OUT!
real 0m3.007s
user 0m0.000s
sys 0m0.004s
but here all bad
time echo `/tmp/timeout 3 sleep 6`
Timed OUT!
real 0m6.009s
user 0m0.000s
sys 0m0.004s
on my debian system I tested with /usr/bin/timeout:
time echo `/usr/bin/timeout 3 sleep 6`
real 0m3.004s
user 0m0.000s
sys 0m0.000s
So the questions
why the perl script work so strange ?
is there any real working way to have timeout writen on perl which will work the same as binary timeout ?
please note, that I know about /usr/share/doc/bash-3.2/scripts/timeout and I also found that it acts the same as my perl approach
also please note that I can't install modules from CPAN on the server targeted for this script
i tried with exec() but in that case it does not handle signal in sub.
UPD
with the script from #rhj (had to fix a little)
#!/usr/bin/perl
use strict;
use warnings;
my $PID=$$;
my $timeout=shift;
my #args=#ARGV;
my $pid = fork();
defined $pid or die "fork: $!";
$pid == 0 && exec(#args);
my $timed_out = 0;
$SIG{ALRM} = sub { $timed_out = 1; die; };
alarm $timeout;
eval { waitpid $pid, 0 };
alarm 0;
if ($timed_out) {
print "Timed out!\n";
kill 9, $pid;
kill 9, $PID;
}
elsif ($#) {
warn "error: $#\n";
}
it pass above test but fail in the case of calling external script:
run_script
#!/bin/sh
sleep 6
test.sh
#!/bin/sh
a=`./timeout.pl 2 ./run_script.sh`
output
$ time ./test.sh
real 0m6.020s
user 0m0.004s
sys 0m0.008s
This version should always work:
#!/usr/bin/perl
use strict;
use warnings;
my $pid=$$;
my $timeout=shift;
my #args=#ARGV;
my $pid = fork();
defined $pid or die "fork: $!";
$pid == 0 && exec(#args);
my $timed_out = 0;
$SIG{ALRM} = sub { $timed_out = 1; die; };
alarm $timeout;
eval { waitpid $pid, 0 };
alarm 0;
if ($timed_out) {
print "Timed out!\n";
kill 9, $pid;
}
elsif ($#) {
warn "error: $#\n";
}
It does not handle an error in the exec() call, though.
Had to make it with IPC::Cmd;
#!/usr/bin/perl -w
use strict;
use IPC::Cmd qw(run_forked);
my $timeout=shift;
my $stdout;
my $hashref = run_forked(#ARGV, { timeout => $timeout});
print $hashref->{'stdout'};
print STDERR $hashref->{'stderr'};
if ($hashref->{'timeout'}) {
print STDERR "Timed out!\n";
exit 142;
}
exit $hashref->{'exit_code'};
the bad thing that I had to install IPC::Cmd using rpmforge.

Perl: how to prevent SIGALRM from closing a pipe?

My pipe (filehandle, socket) breaks (sometimes). I can reproduce it with the following code:
my $counter = 5;
alarm(1);
open(FH,"while(sleep 2); do date; done |") or die $!;
while (<FH>) { print; }
close(FH);
BEGIN {
$SIG{ALRM} = sub {
print "alarm!\n";
exit if --$counter == 0;
alarm(1);
};
}
Which will produce:
alarm!
alarm!
Thu Feb 7 11:46:29 EST 2013
alarm!
alarm!
alarm!
If I strace this process, I see that the spawned shell gets a SIGPIPE. However, the Perl process happily continues. How do I fix this?
The problem is that <FH> is returning false because of an interrupted system call. I am not sure if this is the idiomatic way to handle this in perl (and would love to see a better answer), but the following seems to work:
my $counter = 5;
alarm 1;
open my $fh, '-|', 'while(sleep 2); do date; done' or die $!;
loop:
while (<$fh>) { print; }
goto loop if $!{EINTR};
close $fh;
BEGIN {
$SIG{ALRM} = sub {
print "alarm!\n";
alarm 1;
exit if --$counter <= 0;
};
}

Kill a hung child process

My Perl script runs an external program (which takes a single command-line parameter) and processes its output. Originally, I was doing this:
my #result = `prog arg`;
However, turns out that the program is buggy and hangs unpredictably in rare cases. How can I kill the program if it hasn't exited after a certain amount of time? The script has to work both in Windows and in Linux, and it is my understanding that alarms and forks don't work well (or at all) in Windows.
I found a module called IPC::Run but I can't figure out how to use it properly from its documentation. :-( I tried this:
use strict;
use warnings;
use IPC::Run qw(run timeout);
my $in;
my $out;
my $err;
my #result;
my #cmd = qw(prog arg);
run \#cmd, \$in, \$out, \$err, timeout (10) or die "#cmd: $?";
push #result, $_ while (<$out>);
close $out;
print #result;
As a test, I created a program that just sleeps 60 seconds, prints a string to stdout and exits. When I try to run it with the above code, it hangs for 60 seconds (instead of for 10 seconds, as specified in the timeout) and aborts with a bizarre error:
IPC::Run: timeout on timer #1 at C:/Bin/Unix/Perl/site/lib/IPC/Run.pm line 2956
Then I found another module, Proc::Reliable. From the description, it seems to do precisely what I want. Except that it doesn't work! I tried this:
use strict;
use warnings;
use Proc::Reliable;
my $proc = Proc::Reliable->new ();
$proc->maxtime (10);
my $out = $proc->run ("prog arg");
print "$out\n";
It indeed aborts the child process after 10 seconds. So far, so good. But then I modified the external program and made it sleep for only 5 seconds. This means that the program should finish before the 10-second timeout specified in the above code and its stdout output should be captured into the variable $out. But it isn't! The above script doesn't output anything.
Any ideas how to do it properly? (Fixing the buggy external program is not an option.) Thanks in advance.
Try the poor man's alarm
my $pid;
if ($^O eq 'MSWin32') {
$pid = system 1, "prog arg"; # Win32 only, run proc in background
} else {
$pid = fork();
if (defined($pid) && $pid == 0) {
exec("proc arg");
}
}
my $poor_mans_alarm = "sleep 1,kill(0,$pid)||exit for 1..$TIMEOUT;kill -9,$pid";
system($^X, "-e", $poor_mans_alarm);
The poor man's alarm runs in a separate process. Every second, it checks whether the process with identifier $pid is still alive. If the process isn't alive, the alarm process exits. If the process is still alive after $time seconds, it sends a kill signal to the process (I used 9 to make it untrappable and -9 to take out the whole subprocess tree, your needs may vary. kill 9,... is also portable).
Edit: How do you capture the output of the process with the poor man's alarm?
Not with backticks -- then you can't get the process id and you may lose the intermediate output if the process times out and gets killed. The alternatives are
1) send output to a file, read the file when the process is done
$pid = system 1, "proc arg > some_file";
... start poor man's alarm, wait for program to finish ...
open my $fh, '<', 'some_file';
my #process_output = <$fh>;
...
2) use Perl's open to start the process
$pid = open my $proc, '-|', 'proc arg';
if (fork() == 0) {
# run poor man's alarm in a background process
exec($^X, '-e', "sleep 1,kill 0,$pid||exit ...");
}
my #process_output = ();
while (<$proc>) {
push #process_output, $_;
}
The while loop will end when the process ends, either naturally or unnaturally.
This is the best I could do. Any ideas on how to avoid the use of a temporary file on Windows would be appreciated.
#!/usr/bin/perl
use strict;
use warnings;
use File::Temp;
use Win32::Process qw(STILL_ACTIVE NORMAL_PRIORITY_CLASS);
my $pid;
my $timeout = 10;
my $prog = "prog arg";
my #output;
if ($^O eq "MSWin32")
{
my $exitcode;
my $fh = File::Temp->new ();
my $output_file = $fh->filename;
close ($fh);
open (OLDOUT, ">&STDOUT");
open (STDOUT, ">$output_file" ) || die ("Unable to redirect STDOUT to $output_file.\n");
Win32::Process::Create ($pid, $^X, $prog, 1, NORMAL_PRIORITY_CLASS, '.') or die Win32::FormatMessage (Win32::GetLastError ());
for (1 .. $timeout)
{
$pid->GetExitCode ($exitcode);
last if ($exitcode != STILL_ACTIVE);
sleep 1;
}
$pid->GetExitCode ($exitcode);
$pid->Kill (0) or die "Cannot kill '$pid'" if ($exitcode == STILL_ACTIVE);
close (STDOUT);
open (STDOUT, ">&OLDOUT");
close (OLDOUT);
open (FILE, "<$output_file");
push #output, $_ while (<FILE>);
close (FILE);
}
else
{
$pid = open my $proc, "-|", $prog;
exec ($^X, "-e", "sleep 1, kill (0, $pid) || exit for 1..$timeout; kill -9, $pid") unless (fork ());
push #output, $_ while (<$proc>);
close ($proc);
}
print "Output:\n";
print #output;
You may want to use alarm system call as in perldoc -f alarm.