The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 205;

use POE;
use POE::Session::Hachi;

pass( "Before Create" );

POE::Session::Hachi->create(
	package_states => [
		main => [ qw(_start go chld _stop) ],
	],
	heap => {
		pids => {},
		child => 0,
	},
);

sub _start {
	pass( "Start" );
	$POE::KERNEL->sig( 'CHLD', 'chld' );
	$POE::KERNEL->yield( 'go' );
}

sub go {
	my $pids = $POE::HEAP->{pids};
	
	for my $count (1..100) {
		my $return = int( rand( 100 ) );
		my $fork = fork();

		if ($fork) {
			pass( "Parent ($$)!" );
			if (exists( $pids->{$fork} )) {
				fail( "Child PID already used" );
			}
			else {
				$pids->{$fork} = $return;
			}
		}
		elsif (defined( $fork )) {
			$POE::HEAP->{child} = 1;
			sleep( 2 );
			exit( $return );
		}
		else {
			fail( "Fork Failed!" );
		}
	}

	$POE::HEAP->{done} = 1;
}

sub chld {
	my $package = shift;
	my $pid = $_[1];
	my $return = $_[2] >> 8;

	my $pids = $POE::HEAP->{pids};

	if(exists( $pids->{$pid} )) {
		if($pids->{$pid} == $return) {
			pass( "Yay!" );
		}
		else {
			fail( "PID Return value was unexpected" );
		}
		delete( $pids->{$pid} );
	}
	else {
		fail( "Signal received for pid that was not forked" );
	}

	if (keys( %$pids ) == 0 and $POE::HEAP->{done}) {
		$POE::KERNEL->sig( 'CHLD' );
	}
	$POE::KERNEL->sig_handled();
}

sub _stop {
	if ($POE::HEAP->{child}) {
#	This is stranger for interaction than you can imagine, try it some time.
#		fail( "This should not get called by a child." );
	}
	else {
		pass( "This should be called in the parent." );
	}
}

pass( "Before Run" );

POE::Kernel->run();

pass( "After Run" );

# vim: filetype=perl