File Coverage

blib/lib/Test/SerialFork.pm

Criterion	Covered	Total	%
statement	50	54	92.5
branch	8	16	50.0
condition	2	5	40.0
subroutine	8	8	100.0
pod	1	1	100.0
total	69	84	82.1

# $Id: SerialFork.pm,v 1.1 2005/07/27 15:08:13 pmh Exp $

=head1 NAME

Test::SerialFork - Run iterations of a test in different processes

=head1 SYNOPSIS

  use Test::More plan => 42;
  use Test::SerialFork;

  my $abc=serial_fork('abc','def','ghi');

  ok(do_my_test($abc),'It works');

=head1 DESCRIPTION

This module allows you to run multiple copies of the same test, specifying a
different label for each copy.
The label is made available to the test run, and will
generally be used to modify its behaviour in some way.
Each copy of the test will also be run in a
seperate sub-process, to isolate each test run from system-wide changes made
by previous runs.

The module exports a single function, serial_fork(), whose arguments are
the labels which will be passed to the subsequent runs of the test.
serial_fork() iterates over these labels, forking into two processes each
time.

In the child process, serial_fork() essentially just returns the current
label, and the remainder of the test program is run as normal. However, the
parent process collects all of the child's output, and integrates it into the
main status report generated by the test (test names have the current label
prepended to make it clear which run produced each message).

serial_fork() generates a few test cases of its own:

=over

=item serial_fork() parameters good

This test of serial_fork()'s parameters ensures that each one is defined
and contains at least one non-whitespace character. This is to make sure that
when these labels are useful when prepended to the test. If this test fails,
the remainder of the test is aborted.

=item $label: Create pipe

=item $label: Fork

These tests are performed at the beginning of each test run, to check that the
mechanics of setting up the subprocess are working. If either of them fails,
the test run and any subsequent test runs are aborted.

=item $label: Clean exit

This test is performed after each test run, to check that the subprocess
exited with a successful status.

=back

=head1 INTEGRATION WITH TEST::*

This module only works properly with other modules derived from
L. However, the way it currently works loses some of the
distinction between the three output channels that Test::Builder provides. If
you stick to the ok(), is() and diag() variants, you should be OK.

=head1 BUGS AND CAVEATS

Due to their use as test name labels, the values passed to serial_fork()
should really only be plain strings (though have a look at L
to see what resulted when Damian Conway said something similar). A future
version of this module will probably allow some way of specifying label/data
pairs, but in the meantime, you can easily work around it like this:

  my %label_data=(
    abc => { complex data ... },
    def => { more complex data ... },
  );
  my $label=serial_fork(keys %label_data);
  my $data=$label_data{$label};

=head1 SEE ALSO

L forks several copies of a test and runs them all
concurrently, through the magic of source filters. It also provides a way for
the subprocesses to communicate with each other. In my view, the diagnostics
aren't as clear as C's, but YMMV.

=head1 AUTHOR

Copyright 2005 by Peter Haworth [e-mail]

=cut


package Test::SerialFork;
our $VERSION=0.01;

use 5.006;
use Exporter;
use IO::Handle;
use Test::Builder;
use strict;
use warnings;

{
  no warnings 'once';
  *import=\&Exporter::import;
}
our @EXPORT=qw(serial_fork);

sub serial_fork(@){
  my $Test=Test::Builder->new;

  $Test->ok(@_==grep(defined() && /\S/,@_), 'serial_fork() parameters good')
    or $Test->BAILOUT;

  for my $label(@_){
    $Test->ok(pipe(my $stdout_in,my $stdout_out),"$label: Create pipe")
      or $Test->BAILOUT;
    $stdout_out->autoflush(1);

    if(my $pid=fork){
      # Parent
      close $stdout_out;
      $Test->ok(1,"$label: Fork");

      while(my $line=<$stdout_in>){
	$line=~s/\s+\z//;
	if($line=~/\A((not\s+)?ok)(?:\s+-)(?:\s+(.*))\z/){
	  my($status,$not,$text)=($1,$2,$3);
	  $text||='';

	  # We don't just call ok(!$not), because that generates diagnostics of
	  # its own for failures. We only want the diagnostics from the child.
	  my $num=$Test->current_test;
	  $Test->current_test(++$num);
	  $Test->_print("$status $num - $label: $text\n");
	}elsif($line=~s/\A#\s?//){
	  $Test->diag($line);
	}else{
	  $Test->_print_diag("$label: $line (unrecognised)\n");
	}
      }
      my $wpid=waitpid($pid,0);
      $Test->is_num($?,0,"$label: Clean exit");
    }elsif(defined $pid){
      # Child
      $Test->use_numbers(0);
      $Test->no_ending(1);

      close $stdout_in;
      my $fileno=fileno $stdout_out;
      open STDERR,">&=$fileno"
        or die "$label: Can't redirect STDERR";
      open STDOUT,">&=$fileno"
        or die "$label: Can't redirect STDOUT";

      $Test->output($stdout_out);
      $Test->failure_output($stdout_out);
      $Test->todo_output($stdout_out);

      return $label;
    }else{
      $Test->ok(0,"$label: Fork");
      $Test->BAILOUT;
    }
  }
  exit 0;
}

# Return true to require
1;