#!/usr/bin/perl

use JSON;
sub UNIVERSAL::TO_JSON { "@_" }

use strict;
use warnings;
use Time::HiRes qw(sleep);
use Scalar::Util qw(refaddr weaken readonly);
use POSIX qw(:sys_wait_h);

my $sub_kids = 30;
$|=1;

sub run
{
    my %rcs;
    my %pids;
    
    my $reaper;
    my @reaped;
    
    $reaper = sub {
        my $child = shift;
        my $rc    = shift;

        if ($pids{$child})
        {
            $rcs{$pids{$child}}{rc} = $rc;
            print "Child: $child RC: $rc ITER: $pids{$child}\n";

            # keep track of the reaped children so we can deal with th
+em
            # later.
            push @reaped, delete $pids{$child};
            print 'reaped list: ', encode_json(\@reaped), "\n"; # JSON
+ is very compact cf Data::Dump et al
            return 1;
        }
        return 0;
    };

    register_sigchild($reaper);
    my $dealt_with = 0;
    my $deal_with_children = sub {
        ++$dealt_with;
        my $child = shift @reaped;
        if(readonly($child))
        {
            print "********child readonly?**************\n" ;
            die;
        }
        print "Dealing with: ", encode_json([$child]), "\n";
        print "  - got: ", encode_json($rcs{$child}), "\n"# if $child;
        # code shouldn't make a difference here.
    };

    for my $kid (1..$sub_kids)
    {
        my $pid = run_async($kid % 2 ? '/bin/true' : '/bin/false');
        $pids{$pid} = $kid;
    }

    while (@reaped or keys %pids)
    {
        print "Waiting for children to end: ", encode_json(\%pids), "\
+n";
        sleep 10 unless @reaped;
        while (@reaped)
        {
            $deal_with_children->();
        }
    }
    unless ($dealt_with == $sub_kids)
    {
        warn "Only dealt with $dealt_with of $sub_kids?";
    }
    unregister_sigchild($reaper);
}

sub run_async
{
    # normally, I use IPC::Open3, but here we're just being quick/dirt
+y.
    # with that, we're assuming fork will work.
    my $pid = fork();
    return $pid if $pid;
    die "failed to fork" unless defined $pid;
    sleep 0.01 * rand(50);
    exec @_;
    die "Huh? exec failed?"
}

my %sigs;
sub register_sigchild
{
    my $sig = shift;
    $sigs{refaddr $sig} = {
        sig  => $sig,
        from => (caller(1))[3],
    };
    weaken($sigs{refaddr $sig}{sig});

    $SIG{CHLD} = \&handle_sigchild;
}

my @buffer;

sub handle_sigchild
{
    my $child;
    unregister_sigchild();

    while (($child = 0+ waitpid(-1, WNOHANG)) > 0)
    {
        my $rc = 0+ $?;
        print "Child: $child RC: $?\n";
        push @buffer, [$child, $rc];
    }

    my @exited = @buffer;
    @buffer = ();

    for my $exit (@exited)
    {
        for my $sig (values %sigs)
        {
            my $last;
            my $ref = $sig->{sig}; # ensure strong reference now
            next unless $ref;
            if (
                eval {
                    $last = 1 if $ref->(@$exit);
                    1;
                }
               )
            {
                last if $last;
            }
            else
            {
                delete $sigs{refaddr $ref};
            }
            # no one handled yet?
            push @buffer, $exit;
        }
    }
    unregister_sigchild();
}

sub unregister_sigchild
{
    if (@_)
    {
        delete $sigs{refaddr $_[0]} if $_[0];
        $_[0] = undef; # action at a distance!
    }
    
    for my $addr (keys %sigs)
    {
        delete $sigs{$addr} unless defined $sigs{$addr}{sig};
    }

    print 'About to set $SIG{CHLD}', "\n";
    $SIG{CHLD} = keys %sigs ? \&handle_sigchild : 'DEFAULT';
    #print 'SIGS: ', encode_json(\%sigs), "\n";
}

run();
[download]