view release on metacpan or  search on metacpan

Tester.pm  view on Meta::CPAN

# Tester.pm module

# $Id$
#
# This package is designed to run tests on modules which
# perform interactively.

package Tester;

@ISA = qw( Exporter );
@EXPORT = qw( run_test_with_input run_class_test );

# run_test_with_input $class, $testno, $input, 
#		      \&testsub, $testargsref, $condition.

sub run_test_with_input {
    my $class = shift;
    my $test = shift;
    my $inputstring = shift;
    my $testsub = shift;
    my $testargs = shift;
    my $condition = shift;

    if (!ref($testsub) and $testsub !~ /::/) {
	my $pkg = (caller)[0];
	my $i;
	for ($i = 1; $pkg = (caller)[0]; $i++) {
	    last unless $pkg eq 'Tester';
	}
	$testsub =~ s/^/$pkg::/;	# qualify the sub
    }

    select(STDOUT); $| = 1;
    printf STDOUT "%d.......", $test;

    $SIG{'PIPE'} = 'IGNORE';	# don't let pipe errors hurt us
    pipe(TESTREAD, CHILDWRITE);
    pipe(CHILDREAD, TESTWRITE);
    if (!fork) {
	open(STDIN, "<&CHILDREAD");
	open(STDOUT, ">&CHILDWRITE");	select(STDOUT); $| = 1;
	open(STDERR, ">&STDOUT");	select(STDERR); $| = 1;
	close CHILDREAD;
	close CHILDWRITE;
	select(STDOUT); $| = 1;

	# Finally, after all that -- run the actual test subroutine
	my $sub = eval 'sub { package main; &{$_[0]}(@{$_[1]}); }';
	$_ = &$sub($testsub, $testargs);

	# The condition must be evaluated here, in the child
	# process -- since it may involve variables which have
	# been set in the child (but not the parent)
	if ($condition) {
	    my $sub = eval 
		'sub { package main;
		       ref($_[0]) eq "CODE" ? &{$_[0]} : eval $_[0]; }';
	    &$sub($condition) or print "Condition failed\n";
	}
	close STDOUT;
	close STDIN;
	exit;
    }
    close CHILDREAD;
    close CHILDWRITE;

    # Generate the output
    print TESTWRITE $inputstring."\n";
    close TESTWRITE;		# will cause an EOF
    
    my @output;
    while (<TESTREAD>) {	# Now get the results
	push(@output, $_);
	print if $Details > 1;
    }
    close TESTREAD;
    $SIG{'PIPE'} = 'DEFAULT';	# normal pipe stuff

    # If reference output doesn't exist, generate it from our
    # current input
    my $testdir = -d "t" ? "t" :
		  -d "../t" ? "../t" :
		  -d "../../t" ? "../../t" :
		  die "Can't find 't'!\n";
    my $testref = "$testdir/$class.$test.ref";
    my $testout = "$testdir/$class.$test.out";
    my @Details = ();