#!/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__
[download]