The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
# vim: ts=2 sw=2 filetype=perl expandtab

use warnings;
use strict;

sub POE::Kernel::CATCH_EXCEPTIONS () { 0 }
sub POE::Kernel::USE_SIGCHLD      () { 0 }
sub POE::Kernel::USE_SIGNAL_PIPE  () { 0 }
sub POE::Kernel::ASSERT_DEFAULT   () { 1 }
sub POE::Kernel::TRACE_DEFAULT    () { 0 }

use POE;
use POE::Wheel::Run;
use Test::More;

sub DEBUG () { 0 }

my $child_process_limit = 3;
my $seconds_children_sleep = 1;

# Each child process:
#   child sent done
#   child flushed
#   child exited
# Each spawn
#   All children exited
# Whole program
#   Sane exit

my $test_count = 3 * $child_process_limit + 1 + 1;
plan tests => $test_count;

SKIP: {
  skip("$^O handles fork/call poorly", $test_count) if (
    $^O eq "MSWin32" and not $ENV{POE_DANTIC}
  );

  diag "This test can take up to ", $seconds_children_sleep*10, " seconds";

  Work->spawn( $child_process_limit, $seconds_children_sleep );
  $poe_kernel->run;

  pass( "Sane exit" );
}

############################################################################
package Work;

use strict;
use warnings;
use POE;
use Test::More;

BEGIN {
    *DEBUG = \&::DEBUG;
}

sub spawn {
  my( $package, $count, $sleep ) = @_;
  POE::Session->create(
    inline_states => {
      _start => sub {
        my ($heap) = @_[HEAP, ARG0..$#_];
        $poe_kernel->sig(CHLD => 'sig_CHLD');
        foreach my $n (1 .. $count) {
          DEBUG and diag "$$: Launch child $n";
          my $w = POE::Wheel::Run->new(
            Program => \&spawn_child,
            ProgramArgs => [ $sleep ],
            StdoutEvent => 'chld_stdout',
            StderrEvent => 'chld_stderr',
            CloseEvent  => 'chld_close'
          );
          $heap->{PID2W}{$w->PID} = {ID => $w->ID, N => $n, flushed=>0};
          $heap->{W}{$w->ID} = $w;
        }

        $heap->{TID} = $poe_kernel->delay_set(timeout => $sleep*10);
      },

      chld_stdout => sub {
        my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1];
        my $wheel = $heap->{W}{$wid};
        die "Unknown wheel $wid" unless $wheel;
        $line =~ s/\s+//g;
        is( $line, 'DONE', "stdout from $wid" );
        if( $line eq 'DONE' ) {
          my $data = $heap->{PID2W}{ $wheel->PID };
          $data->{flushed} = 1;
        }
      },

      chld_stderr => sub {
        my ($heap, $line, $wid) = @_[HEAP, ARG0, ARG1];
        my $wheel = $heap->{W}{$wid};
        die "Unknown wheel $wid" unless $wheel;
        if (DEBUG) {
          diag "CHILD " . $wheel->PID . " STDERR: $line";
        }
        else {
          fail "stderr from $wid: $line";
        }
      },

      say_goodbye => sub {
        DEBUG and diag "$$: saying goodbye";
        foreach my $wheel (values %{$_[HEAP]{W}}) {
          $wheel->put("die\n");
        }
        DEBUG and diag "$$: said my goodbyes";
      },

      timeout => sub {
        fail "Timed out waiting for children to exit";
        $poe_kernel->stop();
      },

      sig_CHLD => sub {
        my ($heap, $signal, $pid) = @_[HEAP, ARG0, ARG1];
        DEBUG and diag "$$: CHLD $pid";
        my $data = $heap->{PID2W}{$pid};
        die "Unknown wheel PID=$pid" unless defined $data;
        close_on( 'CHLD', $heap, $data->{ID} );
      },

      chld_close => sub {
        my ($heap, $wid) = @_[HEAP, ARG0];
        DEBUG and diag "$$: close $wid";
        close_on( 'close', $heap, $wid );
      },

      _stop => sub { }, # Pacify ASSERT_DEFAULT.
    }
  );
}

sub close_on {
  my( $why, $heap, $wid ) = @_;

  my $wheel = $heap->{W}{$wid};
  die "Unknown wheel $wid" unless $wheel;

  my $data = $heap->{PID2W}{ $wheel->PID };

  $data->{$why}++;
  return unless $data->{CHLD} and $data->{close};

  is( $data->{flushed}, 1, "expected child flush" );

  delete $heap->{PID2W}{$wheel->PID};
  delete $heap->{W}{$data->{ID}};
  pass("Child $data->{ID} exit detected.");

  unless (keys %{$heap->{W}}) {
    pass "all children have exited";
    $poe_kernel->alarm_remove(delete $heap->{TID});
  }
}

sub spawn_child {
  my( $sleep ) = @_;
  #close STDERR;
  #open STDERR, ">", "child-err.$$";

  DEBUG and diag "$$: child sleep=$sleep";

  POE::Kernel->stop;

  POE::Session->create(
    inline_states => {
      _start => sub {
        $_[KERNEL]->delay( done => $sleep );
      },
      _stop => sub {
        DEBUG and diag "$$: child _stop";
      },
      done => sub {
        DEBUG and diag "$$: child done";
        print "DONE\n";
      },
    }
  );
  POE::Kernel->run;
}