#!/usr/bin/perl

#
#  Modules
#

use POSIX;
use Time::HiRes;
use feature 'state';   #  let doubletime() have a static variable

#
#  Global variables
#

my($MAX_CHILDREN) = 10000;
my($CHILDREN)     = 5000;
my($TIMEOUT)      = 300;
my($A_LONG_TIME)  = 3600;
sub CHILD_RUN_TIME { my($n) = @_; return 1; }
my(@children)     = ();

#
#  Functions
#

sub main
{
    my($i);
    my($running_children_count, $next_timeout, $killed_something);
    my($now);
    my($sigset, $old_sigset, $suspend_sigset);
    my($act, $old_chld_act, $old_alrm_act, $old_usr1_act);

    # 
    #  Initialise.
    # 

    &infomsg("parent initialising children status table ...");
    for ($i=0; $i<$MAX_CHILDREN; $i++) {
        %{$children[$i]} = ();
        $children[$i]{'pid'} = 0;
    }

    &infomsg("parent setting up signal handlers ...");
    # 
    #  Define signal set for two purposes: 
    #      (1) for sigprocmask() call, 
    #      (2) for sigaction() we need list of *additional* signals to block
    #          while executing the handler (we specify all three signals, which
    #          is slightly more than *just* the additional signals, but it does
    #          no harm)
    # 
    $sigset = POSIX::SigSet->new;
    $sigset->addset(POSIX::SIGCHLD);
    $sigset->addset(POSIX::SIGALRM);
    $sigset->addset(POSIX::SIGUSR1);
    $old_sigset = POSIX::SigSet->new;
    #  cause delivery of SIGCHLD, etc to be delayed until we call sigsuspend()
    POSIX::sigprocmask(SIG_BLOCK, $sigset, $old_sigset);
    #  later we need list of signals blocked before that sigprocmask() call, 
    #  but *excluding* SIGCHLD, etc.
    $suspend_sigset = $old_sigset;
    $suspend_sigset->delset(POSIX::SIGCHLD);
    $suspend_sigset->delset(POSIX::SIGALRM);
    $suspend_sigset->delset(POSIX::SIGUSR1);
    #  establish signals handlers
    $act = POSIX::SigAction->new;
    $act->mask($sigset);
    $act->flags(&POSIX::SA_RESTART);
    $act->handler(\&handler);
    $old_chld_act = POSIX::SigAction->new;
    $old_alrm_act = POSIX::SigAction->new;
    $old_usr1_act = POSIX::SigAction->new;
    POSIX::sigaction(SIGCHLD, $act, $old_chld_act);
    POSIX::sigaction(SIGALRM, $act, $old_alrm_act);
    POSIX::sigaction(SIGUSR1, $act, $old_usr1_act);

    #  
    #  Start children.
    #  

    &infomsg("parent starting %d children ...", $CHILDREN);
    for ($i=0; $i<$CHILDREN; $i++) {
        &start_child_sleep(&CHILD_RUN_TIME($i));
    }

    # 
    #  Main monitoring loop
    # 

    &infomsg("parent entering monitoring loop ...");
    while (1) {
        $now = time;
    
        # 
        #  Exit if no running children.
        # 

        &infomsg("parent checking for running children ...");
        $running_children_count = 0;
        for ($i=0; $i<$MAX_CHILDREN; $i++) {
            if ($children[$i]{'pid'} != 0) {
                $running_children_count++;
            }
        }
        &infomsg("parent sees %d children still running", $running_children_count);
        if ($running_children_count == 0) {
            last;
        }

        # 
        #  Kill any children that have reached their timeout time and not
        #  been killed already.
        # 

        $killed_something = 0;
        for ($i=0; $i<$MAX_CHILDREN; $i++) {
            if ($children[$i]{'pid'} != 0 && $children[$i]{'start'} != 0 &&
                    $now >= $children[$i]{'start'}+$TIMEOUT) {
                kill($children[$i]{'pid'}, SIGTERM);
                $children[$i]{'start'} = 0;
                $killed_something = 1;
            }
        }

        # 
        #  Slight optimisation: if something did reach its timeout and got
        #  killed then skip to reassessing if this program can exit.
        # 

        if ($killed_something) {
            next;
        }

        # 
        #  Schedule timeout alarm of next-to-timeout child.
        # 

        &infomsg("parent scheduling timeout alarm ...");
        $next_timeout = 0;
        for ($i=0; $i<$MAX_CHILDREN; $i++) {
            if ($children[$i]{'pid'} != 0 && $children[$i]{'start'} != 0) {
                if ($next_timeout == 0) {
                    $next_timeout = $children[$i]{'start'}+$TIMEOUT - $now;
                } elsif ($children[$i]{'start'}+$TIMEOUT - $now < $next_timeout) {
                    $next_timeout = $children[$i]{'start'}+$TIMEOUT - $now;
                }
            }
        }
        if ($next_timeout >= 1) {
            &infomsg("parent scheduling alarm for %ds ...", $next_timeout);
            POSIX::alarm($next_timeout);
        }

        # 
        #  If there are dispatched-but-not-yet-delivered signals then
        #  handle them. If there are none then wait for one.
        # 

        &infomsg("parent handling any pending signals ...");
        if ($next_timeout >= 1) {
            POSIX::sigsuspend($suspend_sigset);
        }

        # 
        #  If SIGCHLD arrived before SIGALRM then the alarm is still
        #  pending. Cancel it.
        # 

        &infomsg("parent cancelling alarm ...");
        POSIX::alarm(0);
    }

    #
    #  Clean up and exit.
    #

    &infomsg("parent cleaning up and exiting ...");
    #  C allows third argument to be NULL, meaning don't bother telling me
    #  what the old sig action was. But Perl insists on proper third argument.
    #  By chance we have a sig action variable that we no longer need - act -
    #  so we let sigaction() write in there. sigprocmask() on the other hand
    #  seems to accept undef as third argument.
    POSIX::sigaction(SIGUSR1, $old_usr1_act, $act);
    POSIX::sigaction(SIGALRM, $old_alrm_act, $act);
    POSIX::sigaction(SIGCHLD, $old_chld_act, $act);
    POSIX::sigprocmask(SIG_SETMASK, $old_sigset, undef);
    return 0;
}

sub start_child_sleep
{
    my($period) = @_;
    my($pid);
    my($buf);
    my($i);

    # 
    #  Find an empty slot to store info about the process we're
    #  about launch.
    # 

    for ($i=0; $i<$MAX_CHILDREN; $i++) {
        if ($children[$i]{'pid'} == 0) {
            last;
        }
    }
    if ($i == $MAX_CHILDREN) {
        &errormsg("start_child_sleep: unable to find a free slot");
    }

    # 
    #  Launch a child process and note its pid and start time
    #  in the empty slot.
    # 

    $buf = "sleep $period"
    if (($pid=fork) < 0) {
        &errormsg("fork() failed: %s", strerror(errno));
    } elsif ($pid > 0) {
        $children[$i]{'pid'} = $pid;
        $children[$i]{'start'} = time;
        return($pid);
    }

    # 
    #  Only the child gets here
    # 

    exec '/bin/sh', '-c', $buf;
    &errormsg("exec() failed: $!");
}

sub handler
{
    my($sig) = @_;
    my($pid);
    my($i);

    if ($sig eq 'CHLD') {
        while (($pid=waitpid(-1, WNOHANG)) > 0) {
            for ($i=0; $i<$MAX_CHILDREN; $i++) {
                if ($children[$i]{'pid'} == $pid) {
                    $children[$i]{'pid'} = 0;
                    $children[$i]{'start'} = 0;
                    break;
                }
            }
        }
    } elsif ($sig eq 'ALRM') {
        &infomsg("parent received SIGALRM");
    } elsif ($sig eq 'USR1') {
        &finfomsg(\*STDERR, "parent received SIGUSR1");
        for ($i=0; $i<$MAX_CHILDREN; $i++) {
            if ($children[$i]{'pid'} != 0) {
                &finfomsg(\*STDERR, "slot:%04d; pid:%05d, start=%ld", 
                          $i, $children[$i]{'pid'}, $children[$i]{'start'});
            }
        }
    } else {
        &errormsg("parent received unexpected signal %s", $sig);
    }
}

sub doubletime
{
    state $start = undef;  #  static
    my($now);

    $now = Time::HiRes::time();

    if (not defined($start)) {
        $start = $now;
    }

    return($now - $start);
}

sub infomsg
{
    my($fmt, @args) = @_;

    #  substr() strips 'main::' module prefix.
    &real_fmessage(substr((caller(1))[3],6), \*STDOUT, $fmt, @args);
}

sub errormsg
{
    my($fmt, @args) = @_;

    #  substr() strips 'main::' module prefix.
    &real_fmessage(substr((caller(1))[3],6), \*STDOUT, $fmt, @args);
    exit 1;
}

sub finfomsg
{
    my($fp, $fmt, @args) = @_;

    &real_fmessage(substr((caller(1))[3],6), $fp, $fmt, @args);
}

sub ferrormsg
{
    my($fp, $fmt, @args) = @_;

    &real_fmessage(substr((caller(1))[3],6), $fp, $fmt, @args);
    exit 1;
}

sub real_fmessage
{
    my($func, $fp, $fmt, @args) = @_;

    printf $fp "%.06lf: %s: ", &doubletime(), $func;
    printf $fp $fmt, @args;
    printf $fp "\n";
}

&main();