parallel_run in Test::More, with testing children output

gistfile1.pl

#!/usr/bin/perl

use warnings;
use strict;
use diagnostics;

use POSIX qw(dup2);
use IO::Handle;
use IO::Select;
use IO::Pipe;

use Test::More;

sub parallel_run (&); # forward declaration of prototype

subtest 'foo' => sub {
	my @output = parallel_run {
		print "foo";
	};
	is($output[0], "foo");
	is($output[1], "foo");

	done_testing();
};
done_testing();

#######################################################################
#######################################################################
#######################################################################

# from http://aaroncrane.co.uk/talks/pipes_and_processes/
sub fork_child (&) {
	my ($child_process_code) = @_;

	my $pid = fork();
	die "Failed to fork: $!\n" if !defined $pid;

	return $pid if $pid != 0;

	# Now we're in the new child process
	$child_process_code->();
	exit;
}

sub parallel_run (&) {
	my $child_code = shift;
	my $nchildren = 2;

	my %children;
	my (%pid_for_child, %fd_for_child);
	my $sel = IO::Select->new();
	foreach my $child_idx (1..$nchildren) {
		my $pipe = IO::Pipe->new()
			or die "Failed to create pipe: $!\n";

		my $pid = fork_child {
			$pipe->writer()
				or die "$$: Child \$pipe->writer(): $!\n";
			dup2(fileno($pipe), fileno(STDOUT))
				or die "$$: Child $child_idx failed to reopen stdout to pipe: $!\n";
			close $pipe
				or die "$$: Child $child_idx failed to close pipe: $!\n";

			# From Test-Simple-0.96/t/subtest/fork.t
			#
			# Force all T::B output into the pipe, for the parent
			# builder as well as the current subtest builder.
			#no warnings 'redefine';
			#*Test::Builder::output         = sub { *STDOUT };
			#*Test::Builder::failure_output = sub { *STDOUT };
			#*Test::Builder::todo_output    = sub { *STDOUT };

			$child_code->();

			*STDOUT->flush();
			close(STDOUT);
		};

		$pid_for_child{$pid} = $child_idx;
		$pipe->reader()
			or die "Failed to \$pipe->reader(): $!\n";
		$fd_for_child{$pipe} = $child_idx;
		$sel->add($pipe);

		$children{$child_idx} = {
			'pid'    => $pid,
			'stdout' => $pipe,
			'output' => '',
		};
	}

	while (my @ready = $sel->can_read()) {
		foreach my $fh (@ready) {
			my $buf = '';
			my $nread = sysread($fh, $buf, 1024);

			exists $fd_for_child{$fh}
				or die "Cannot find child for fd: $fh\n";

			if ($nread > 0) {
				$children{$fd_for_child{$fh}}{'output'} .= $buf;
			} else {
				$sel->remove($fh);
			}
		}
	}

	while (%pid_for_child) {
		my $pid = waitpid -1, 0;
		warn "Child $pid_for_child{$pid} ($pid) failed with status: $?\n"
			if $? != 0;
		delete $pid_for_child{$pid};
	}

	return map { $children{$_}{'output'} } keys %children;
}


__END__