Here's a generic form of parallel process dispatcher that I worked up a few years ago. I'm sure there some things that could be done better. I've reworked it to be generic, but I can't completely test it here (the "-|" fails where I am now).
#!/your/perl/here
use strict;
use warnings;
use IO::Handle;
use POSIX qw(:signal_h :errno_h :sys_wait_h );
use Getopt::Long;
# define option names and defaults
our $PARENT_OPT = q/parent/;
our $CHILD_OPT = q/child/;
our $INTERVAL_OPT = q/interval/;
our $PARENT_OPT_SHORT = substr( $PARENT_OPT, 0, 1 );
our $PARENT = 5; # seconds
our $CHILD = 5; # seconds
our $INTERVAL = 0; # seconds
our $CHILD_COMMAND = 'echo ';
# note that =f takes a real, but integers are also allowed
GetOptions( "$PARENT_OPT=f" => \$PARENT,
"$CHILD_OPT=f" => \$CHILD,
"$INTERVAL_OPT=f" => \$INTERVAL ) or usage();
@ARGV or usage();
##############################################
sub usage
{
die <<"USAGE";
usage:
$0 [-$PARENT_OPT time] [-$CHILD_OPT time] [-$INTERVAL_OPT time]
description:
$0 performs \'${CHILD_COMMAND} machine\'
for all machine names given on the command line
-$PARENT_OPT time
changes the default total time (${PARENT}s) for the parent
-$PARENT_OPT time
changes the default machine response time (${CHILD}s)
-$INTERVAL_OPT time
changes the default request interval (${INTERVAL}s)
-help
-?
prints this message (any unrecognized option will do the same
+)
Note that unique abreviations can also be used.
[e.g., -$PARENT_OPT_SHORT for $PARENT_OPT]
USAGE
} # sub usage
##############################################
# let child timeout control parent timeout
$PARENT = $CHILD if $PARENT < $CHILD;
our %pid_to_name = (); # exists, but empty
our @names = @ARGV; # fill as desired
# signal setup
$SIG{ALRM} = \&ALARM_PARENT;
$SIG{INT} = $SIG{HUP} = \&REAP_ALL;
$SIG{CHLD} = \&REAPER;
# set parent alarm
# (not just for time limit, also for pathological fork problems)
alarm $PARENT;
STDERR->autoflush( 1 );
##################################################
# fork children
FORK:
foreach my $name ( @names )
{
# need 'no strict "refs"' for open( $var, ... )
# better way to do this?
no strict "refs";
if ( my $pid = open( $name, "-|" ) ) # fork a child
{
# parent code here
$pid_to_name{ $pid } = $name;
# wait between requests, if needed
select undef, undef, undef, $INTERVAL;
}
elsif ( not( defined( $pid ) ) )
{
# "open" didn't fork, try again
warn "Failed to fork on $name, retrying...\n";
redo FORK;
}
else # child code here
{
# alarm handler for child different from parent
$SIG{ALRM} = \&ALARM;
alarm $CHILD;
STDOUT->autoflush( 1 ); # flush output
STDERR->autoflush( 1 );
# place child stuff here, including write to STDOUT
my $catch = `${CHILD_COMMAND}$name`;
warn "[$name] $?" if $?;
if ( length( $catch ) )
{
print "=" x 10, "${CHILD_COMMAND}$name", "=" x 10, "\n";
print $catch;
print "-" x 30, "\n";
}
exit; # exit from child
}
} # foreach $name ( @names )
# while there are children left, wait for alarm or child
while ( keys %pid_to_name )
{
sleep;
# to periodically do something else while waiting,
# give sleep a value above (or use select), and put code here
}
exit; # exit from parent
##################################################
sub REAPER
{
my $pid = waitpid( -1, &WNOHANG ); # WNOHANG from POSIX
if ( $pid == -1 )
{
# no children waiting, ignore it
}
elsif ( WIFEXITED( $? ) ) # WIFEXITED from POSIX
{
my $name = $pid_to_name{ $pid };
my @catch = <$name>;
close( $name );
print @catch;
warn "\t\t[$name] waiting, reaped in REAPER\n";
delete( $pid_to_name{ $pid } ); # only keep the living childre
+n
}
else
{
# false alarm
my $name = $pid_to_name{ $pid };
warn "\t\t[$name] false alarm waiting, untouched in REAPER\n";
}
$SIG{CHLD} = \&REAPER; # in case of unreliable signals
} # sub REAPER
##################################################
sub REAP_ALL
{
foreach my $child ( keys %pid_to_name )
{
my $pid = waitpid( $child, &WNOHANG ); # WNOHANG from POSIX
if ( WIFEXITED( $? ) ) # WIFEXITED from POSIX
{
my $name = $pid_to_name{ $child };
my @catch = <$name>;
close( $name );
print @catch;
warn "\t\t[$name] waiting, reaped in REAP_ALL\n";
}
else
{
# child not waiting, close it anyway
my $name = $pid_to_name{ $pid };
close( $name );
warn "\t\t[$name] not waiting, reaped anyway in REAP_ALL\n
+";
}
} # foreach $child
exit; # exit parent
} # sub REAP_ALL
##################################################
sub ALARM_PARENT
{
warn "Parent timed out ${PARENT}s, reaping children...\n";
REAP_ALL();
} # sub ALARM_PARENT
##################################################
sub ALARM # for child processes
{
STDOUT->autoflush( 1 );
my $name = $pid_to_name{ $$ };
warn "\t\t[$name] timed out ${CHILD}s\n";
close( STDOUT );
exit;
} # sub ALARM
__END__