I am attempting to launch a subprocess in perl that either:
Successfully runs to conclusion
Takes too long and needs to be killed
Prints an error message to STDERR and hangs and needs to be killed
I could handle just the timeout issue (2) with waitpid.
I could look for messages on STDOUT with a while (<CHILD_HANDLE>) loop.
I could read the STDOUT and STDERR by appending 2>&1 to the process string.
But, this got more complicated when I realized that after sending an error to STDERR (3), the child process does not return a line break, and then hangs for a while. I could wait for a timeout as in (2), but I'd prefer to identify the error right away. So I switched from while (<CHILD_HANDLE>) syntax to while ($next_letter = getc(<CHILD_HANDLE>)) syntax. This worked with a toy test process, but when I try it with the real command I'm monitoring, I am finding that the child process terminates after sending a single character ("\n"). This may be difficult to troubleshoot without my sharing details of the actual subprocess, but I'm hoping some guidance can be provided.
Here is the simplified code I've got:
#!/usr/bin/perl
use POSIX qw(:sys_wait_h WNOHANG);
my $TIMEOUT = 60 * 30; # 30 minutes
my $alarm_hit = 0;
my $pid = open(CHILD_HANDLE, "-|", 'command arg1 arg2 arg3 2>&1' ));
die "Could not fork\n" if not defined $pid;
if ($pid > 0) {
# set the timeout alarm
local $SIG{ALRM} = sub {kill 9, $pid; print "Killing process after timeout\n"; $alarm_hit = 1; };
alarm $TIMEOUT;
my $next_letter;
my $buffer;
# read the next character from the child
READ_LOOP: while ($next_letter = getc(CHILD_HANDLE)) {
$buffer .= $next_letter;
# if we see the error message
if ($buffer =~ /Error Message/) {
print "======= HIT ERROR MESSAGE\n";
# kill the child
close CHILD_HANDLE;
kill 'KILL', $pid;
last READ_LOOP;
# if the timeout alarm was hit
} elsif ($alarm_hit == 1) {
close READ_LOOP;
print "======= ALARM HIT\n";
last READ_LOOP;
# else print the child output when we hit a new line
} elsif ($next_letter eq "\n") {
print "> $buffer";
$buffer = '';
}
}
}
Related
I'm currently using a cron job to have a perl script that tells my arduino to cycle my aquaponics system and all is well, except the perl script doesn't die as intended.
Here is my cron job:
*/15 * * * * /home/dburke/scripts/hal/bin/main.pl cycle
And below is my perl script:
#!/usr/bin/perl -w
# Sample Perl script to transmit number
# to Arduino then listen for the Arduino
# to echo it back
use strict;
use Device::SerialPort;
use Switch;
use Time::HiRes qw ( alarm );
$|++;
# Set up the serial port
# 19200, 81N on the USB ftdi driver
my $device = '/dev/arduino0';
# Tomoc has to use a different tty for testing
#$device = '/dev/ttyS0';
my $port = new Device::SerialPort ($device)
or die('Unable to open connection to device');;
$port->databits(8);
$port->baudrate(19200);
$port->parity("none");
$port->stopbits(1);
my $lastChoice = ' ';
my $signalOut;
my $args = shift(#ARGV);
# Parent must wait for child to exit before exiting itself on CTRL+C
if ($args eq "cycle") {
open (LOG, '>>log.txt');
print LOG "Cycle started.\n";
my $stop = 0;
sleep(2);
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
$stop = 1;
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
print LOG "Alarm is being set.\n";
alarm (420);
print LOG "Alarm is set.\n";
while ($stop == 0) {
print LOG "In while-sleep loop.\n";
sleep(2);
}
print LOG "The loop has been escaped.\n";
die "Done.";
print LOG "No one should ever see this.";
}
else {
my $pid = fork();
$SIG{'INT'} = sub {
waitpid($pid,0) if $pid != 0; exit(0);
};
# What child process should do
if($pid == 0) {
# Poll to see if any data is coming in
print "\nListening...\n\n";
while (1) {
my $incmsg = $port->lookfor(9);
# If we get data, then print it
if ($incmsg) {
print "\nFrom arduino: " . $incmsg . "\n\n";
}
}
}
# What parent process should do
else {
sleep(1);
my $choice = ' ';
print "Please pick an option you'd like to use:\n";
while(1) {
print " [1] Cycle [2] Relay OFF [3] Relay ON [4] Config [$lastChoice]: ";
chomp($choice = <STDIN>);
switch ($choice) {
case /1/ {
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
alarm (420);
$lastChoice = $choice;
}
case /2/ {
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2";
$lastChoice = $choice;
}
case /3/ {
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1";
$lastChoice = $choice;
}
case /4/ {
print "There is no configuration available yet. Please stab the developer.";
}
else { print "Please select a valid option.\n\n";}
}
}
}
}
When I run ps -ef I find the following output:
dburke 15294 15293 0 14:30 ? 00:00:00 /bin/sh -c /home/dburke/scripts/hal/bin/main.pl cycle
dburke 15295 15294 0 14:30 ? 00:00:00 /usr/bin/perl -w /home/dburke/scripts/hal/bin/main.pl cycle
Shouldn't there only be one process? Is it forking even though it received the cycle argument and the fork is outside of the cycle argument's if block?
Any idea why it wouldn't die from the statement die "Done.";? It runs fine from the command line and interprets the 'cycle' argument fine. When it runs in cron it runs fine, however, the process never dies and while each process doesn't continue to cycle the system it does seem to be looping in some way due to the fact that it ups my system load very quickly.
If you'd like more information, just ask. Thanks guys!
It looks as thought the issue was that my script originally encapsulated the cycle block inside of the fork which for some reason, unknown to me, was leaving a process open (possibly the child?). Taking the cycle block out of the fork has corrected the issue. Now it runs at the specified time and correctly dies after the cycle is complete leaving my cpu load for something more useful. :)
Thank you everyone who commented on my question. You suggestions helped me work through the issue.
I have the following code which reads output from the command 'some_command'. The 'some_command' is an ongoing process which keeps printing output until it is killed. I am wondering if I close the file handle or call on last, will it also terminate the 'some_command' process or it's possible that 'some_command' will keep running as an orphan process. I basically want to read output from the command until I find the line with /Output/ then terminates.
my $mycommand = 'some_command';
open IN, "$mycommand 123456 |" or die("Failed: $!");
while(my $line = <IN> && !$stop) {
if($line =~ /Output/) {
# work is done
last;
$stop = 1;
}
}
close IN;
close on this type of handle will start by closing the pipe, then it waits for the child to exit. The child will die from a SIGPIPE the next time it tries to write to the pipe. If you don't want to wait that long, you can speed things along and terminate it yourself.
my $pid = open ...;
while (<IN>) {
if (/Output/) {
# work is done
kill TERM => $pid;
last;
}
print; # Or whatever
}
close IN;
(Got rid of $stop since you weren't using it.)
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.
I have finished my earlier multithreaded program that uses perl threads and it works on my system. The problem is that on some systems that it needs to run on, thread support is not compiled into perl and I cannot install additional packages. I therefore need to use something other than threads, and I am moving my code to using fork(). This works on my windows system in starting the subtasks.
A few problems:
How to determine when the child process exits? I created new threads when the thread count was below a certain value, I need to keep track of how many threads are running. For processes, how do I know when one exits so I can keep track of how many exist at the time, incrementing a counter when one is created and decrementing when one exits?
Is file I/O using handles obtained with OPEN when opened by the parent process safe in the child process? I need to append to a file for each of the child processes, is this safe on unix as well.
Is there any alternative to fork and threads? I tried use Parallel::ForkManager, but that isn't installed on my system (use Parallel::ForkManager; gave an error) and I absolutely require that my perl script work on all unix/windows systems without installing any additional modules.
Typical usage:
use POSIX ':sys_wait_h'; # for &WNOHANG
# how to create a new background process
$pid = fork();
if (!defined $pid) { die "fork() failed!" }
if ($pid == 0) { # child
# ... do stuff in background ...
exit 0; # don't forget to exit or die from the child process
}
# else this is the parent, $pid contains process id of child process
# ... do stuff in foreground ...
# how to tell if a process is finished
# also see perldoc perlipc
$pid = waitpid -1, 0; # blocking wait for any process
$pid = wait; # blocking wait for any process
$pid = waitpid $mypid, 0; # blocking wait for process $mypid
# after blocking wait/waitpid
if ($pid == -1) {
print "All child processes are finished.\n";
} else {
print "Process $pid is finished.\n";
print "The exit status of process $pid was $?\n";
}
$pid = waitpid -1, &WNOHANG; # non-blocking wait for any process
$pid = waitpid $mypid, 0; # blocking wait for process $mypid
if ($pid == -1) {
print "No child processes have finished since last wait/waitpid call.\n";
} else {
print "Process $pid is finished.\n";
print "The exit status of process $pid was $?\n";
}
# terminating a process - see perldoc -f kill or perldoc perlipc
# this can be flaky on Windows
kill 'INT', $pid; # send SIGINT to process $pid
Gory details in perldoc -f fork, waitpid, wait, kill, and perlipc. The stuff in perlipc about setting up a handler for SIGCHLD events should be particularly helpful, though that isn't supported on Windows.
I/O across forked processes is generally safe on Unix and Windows. File descriptors are shared, so for something like this
open X, ">", $file;
if (fork() == 0) { # in child
print X "Child\n";
close X;
exit 0;
}
# in parent
sleep 1;
print X "Parent\n";
close X;
both child and parent processes will successfully write to the same file (be aware of output buffering, though).
Take a look at waitpid. Here is some code that has nine tasks that need to be done (1 through 9). It will start up to three workers to do those tasks.
#!/usr/bin/perl
use strict;
use warnings;
use POSIX ":sys_wait_h";
my $max_children = 3;
my %work = map { $_ => 1 } 1 .. 9;
my #work = keys %work;
my %pids;
while (%work) {
#while there are still empty slots
while (#work and keys %pids < $max_children) {
#get some work for the child to do
my $work = shift #work;
die "could not fork" unless defined(my $pid = fork);
#parent
if ($pid) {
$pids{$pid} = 1;
next;
}
#child
print "$$ doing work $work\n";
sleep 1;
print "$$ done doing work $work";
exit $work;
}
my $pid = waitpid -1, WNOHANG;
if ($pid > 0) {
delete $pids{$pid};
my $rc = $? >> 8; #get the exit status
print "saw $pid was done with $rc\n";
delete $work{$rc};
print "work left: ", join(", ", sort keys %work), "\n";
}
select undef, undef, undef, .25;
}
I am running the below code snippet on Windows. The server starts listening continuously after reading from client. I want to terminate this command after a time period.
If I use alarm() function call within main.pl, then it terminates the whole Perl program (here main.pl), so I called this system command by placing it in a separate Perl file
and calling this Perl file (alarm.pl) in the original Perl File using the system command.
But in this way I was unable to take the output of this system() call neither in the original Perl File nor in called one Perl File.
Could anybody please let me know the way to terminate a system() call or take the output in that way I used above?
main.pl
my #output = system("alarm.pl");
print"one iperf completed\n";
open FILE, ">display.txt" or die $!;
print FILE #output_1;
close FILE;
alarm.pl
alarm 30;
my #output_1 = readpipe("adb shell cd /data/app; ./iperf -u -s -p 5001");
open FILE, ">display.txt" or die $!;
print FILE #output_1;
close FILE;
In both ways display.txt is always empty.
There are a few separate issues here.
First, to keep the alarm from killing your script, you need to handle the ALRM signal. See the alarm documentation. You shouldn't need two scripts for this.
Second, system doesn't capture output. You need one of the backtick variants or a pipe if you want to do that. There are answers for that on Stackoverflow already.
Third, if alarm.pl puts anything in display.txt, you discard it in main.pl when you re-open the file in write mode. You only need to create the file in one place. When you get rid of the extra script, you won't have this problem.
I recently had some problems with alarm and system, but switching to IPC::System::Simple fixed that.
Good luck, :)
What the hell was I thinking? You don't need a background process for this task. You just need to follow the example in the perldoc -f alarm function and wrap your time-sensitive code in an eval block.
my $command = "adb shell cd /data/app; ./iperf -u -s -p 5001";
my #output;
eval {
local $SIG{ALRM} = sub { die "Timeout\n" };
alarm 30;
#output = `$command`;
alarm 0;
};
if ($#) {
warn "$command timed out.\n";
} else {
print "$command successful. Output was:\n", #output;
}
Inside the eval block, you can capture your output the regular way (with backticks or qx() or readpipe). Though if the call times out, there won't be any output.
If you don't need the output (or don't mind hacking some interprocess communication together), an almost idiot-proof alternative is to set the alarm and run the system call in a child process.
$command = "adb shell cd /data/app; ./iperf -u -s -p 5001";
if (($pid = fork()) == 0) {
# child process
$SIG{ALRM} = sub { die "Timeout\n" }; # handling SIGALRM in child is optional
alarm 30;
my $c = system($command);
alarm 0;
exit $c >> 8; # if you want to capture the exit status
}
# parent
waitpid $pid, 0;
waitpid will return when either the child's system command is finished, or when the child's alarm goes off and kills the child. $? will hold the exit code of the system call, or something else (142 on my system) for an unhandled SIGALRM or 255 if your SIGALRM handler calls die.
I run into a similar problem that requires:
run a system command and get its output
time out the system command after x seconds
kill the system command process and all child processes
After much reading about Perl IPC and manual fork & exec, I came out with this solution. It is implemented as a simulated 'backtick' subroutine.
use Error qw(:try);
$SIG{ALRM} = sub {
my $sig_name = shift;
die "Timeout by signal [$sig_name]\n";
};
# example
my $command = "vmstat 1 1000000";
my $output = backtick(
command => $command,
timeout => 60,
verbose => 0
);
sub backtick {
my %arg = (
command => undef,
timeout => 900,
verbose => 1,
#_,
);
my #output;
defined( my $pid = open( KID, "-|" ) )
or die "Can't fork: $!\n";
if ($pid) {
# parent
# print "parent: child pid [$pid]\n" if $arg{verbose};
try {
alarm( $arg{timeout} );
while (<KID>) {
chomp;
push #output, $_;
}
alarm(0);
}
catch Error with {
my $err = shift;
print $err->{-text} . "\n";
print "Killing child process [$pid] ...\n" if $arg{verbose};
kill -9, $pid;
print "Killed\n" if $arg{verbose};
alarm(0);
}
finally {};
}
else {
# child
# set the child process to be a group leader, so that
# kill -9 will kill it and all its descendents
setpgrp( 0, 0 );
# print "child: pid [$pid]\n" if $arg{verbose};
exec $arg{command};
exit;
}
wantarray ? #output : join( "\n", #output );
}
Might use "timeout -n " for wrapping your commands if thats already common on your system.