[p5sagit/p5-mst-13.2.git] / lib / Test / Harness.pm

package Test::Harness;

use 5.002;
use Exporter;
use Benchmark;
use Config;
use FileHandle;
use strict;

use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
	    @ISA @EXPORT @EXPORT_OK);
$have_devel_corestack = 0;

$VERSION = "1.12";

@ISA=('Exporter');
@EXPORT= qw(&runtests);
@EXPORT_OK= qw($verbose $switches);

format STDOUT_TOP =
Failed Test  Status Wstat Total Fail  Failed  List of failed
------------------------------------------------------------------------------
.

format STDOUT =
@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
{ $curtest->{name},
                $curtest->{estat},
                    $curtest->{wstat},
                          $curtest->{max},
                                $curtest->{failed},
                                     $curtest->{percent},
                                              $curtest->{canon}
}
.


$verbose = 0;
$switches = "-w";

sub runtests {
    my(@tests) = @_;
    local($|) = 1;
    my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
    my $totmax = 0;
    my $files = 0;
    my $bad = 0;
    my $good = 0;
    my $total = @tests;
    local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children

    my $t_start = new Benchmark;
    while ($test = shift(@tests)) {
	$te = $test;
	chop($te);
	print "$te" . '.' x (20 - length($te));
	my $fh = new FileHandle;
	$fh->open("$^X $switches $test|") || (print "can't run. $!\n");
	$ok = $next = $max = 0;
	@failed = ();
	while (<$fh>) {
	    if( $verbose ){
		print $_;
	    }
	    if (/^1\.\.([0-9]+)/) {
		$max = $1;
		$totmax += $max;
		$files++;
		$next = 1;
	    } elsif ($max && /^(not\s+)?ok\b/) {
		my $this = $next;
		if (/^not ok\s*(\d*)/){
		    $this = $1 if $1 > 0;
		    push @failed, $this;
		} elsif (/^ok\s*(\d*)/) {
		    $this = $1 if $1 > 0;
		    $ok++;
		    $totok++;
		}
		if ($this > $next) {
		    # warn "Test output counter mismatch [test $this]\n";
		    # no need to warn probably
		    push @failed, $next..$this-1;
		} elsif ($this < $next) {
		    #we have seen more "ok" lines than the number suggests
		    warn "Confused test output: test $this answered after test ", $next-1, "\n";
		    $next = $this;
		}
		$next = $this + 1;
	    }
	}
	$fh->close; # must close to reap child resource values
	my $wstatus = $?;
	my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8;
	if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) {
	    print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
	    if (corestatus($wstatus)) { # until we have a wait module
		if ($have_devel_corestack) {
		    Devel::CoreStack::stack($^X);
		} else {
		    print "\ttest program seems to have generated a core\n";
		}
	    }
	    $bad++;
	    $failedtests{$test} = { canon => '??',  max => $max || '??',
				    failed => '??', 
				    name => $test, percent => undef,
				    estat => $estatus, wstat => $wstatus,
				  };
	} elsif ($ok == $max && $next == $max+1) {
	    if ($max) {
		print "ok\n";
	    } else {
		print "skipping test on this platform\n";
	    }
	    $good++;
	} elsif ($max) {
	    if ($next <= $max) {
		push @failed, $next..$max;
	    }
	    if (@failed) {
		my ($txt, $canon) = canonfailed($max,@failed);
		print $txt;
		$failedtests{$test} = { canon => $canon,  max => $max,
					failed => scalar @failed,
					name => $test, percent => 100*(scalar @failed)/$max,
					estat => '', wstat => '',
				      };
	    } else {
		print "Don't know which tests failed: got $ok ok, expected $max\n";
		$failedtests{$test} = { canon => '??',  max => $max,
					failed => '??', 
					name => $test, percent => undef,
					estat => '', wstat => '',
				      };
	    }
	    $bad++;
	} elsif ($next == 0) {
	    print "FAILED before any test output arrived\n";
	    $bad++;
	    $failedtests{$test} = { canon => '??',  max => '??',
				    failed => '??',
				    name => $test, percent => undef,
				    estat => '', wstat => '',
				  };
	}
    }
    my $t_total = timediff(new Benchmark, $t_start);
    
    if ($bad == 0 && $totmax) {
	    print "All tests successful.\n";
    } elsif ($total==0){
	die "FAILED--no tests were run for some reason.\n";
    } elsif ($totmax==0) {
	my $blurb = $total==1 ? "script" : "scripts";
	die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
    } else {
	$pct = sprintf("%.2f", $good / $total * 100);
	my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
	$totmax - $totok, $totmax, 100*$totok/$totmax;
	my $script;
	for $script (sort keys %failedtests) {
	  $curtest = $failedtests{$script};
	  write;
	}
	if ($bad > 1) {
	    die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
	}
    }
    printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));

    return ($bad == 0 && $totmax) ;
}

sub corestatus {
    my($st) = @_;
    my($ret);

    eval {require 'wait.ph'};
    if ($@) {
      SWITCH: {
	    $ret = ($st & 0200); # Tim says, this is for 90%
	}
    } else {
	$ret = WCOREDUMP($st);
    }

    eval {require Devel::CoreStack};
    $have_devel_corestack++ unless $@;

    $ret;
}

sub canonfailed ($@) {
    my($max,@failed) = @_;
    my %seen;
    @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
    my $failed = @failed;
    my @result = ();
    my @canon = ();
    my $min;
    my $last = $min = shift @failed;
    my $canon;
    if (@failed) {
	for (@failed, $failed[-1]) { # don't forget the last one
	    if ($_ > $last+1 || $_ == $last) {
		if ($min == $last) {
		    push @canon, $last;
		} else {
		    push @canon, "$min-$last";
		}
		$min = $_;
	    }
	    $last = $_;
	}
	local $" = ", ";
	push @result, "FAILED tests @canon\n";
	$canon = "@canon";
    } else {
	push @result, "FAILED test $last\n";
	$canon = $last;
    }

    push @result, "\tFailed $failed/$max tests, ";
    push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
    my $txt = join "", @result;
    ($txt, $canon);
}

1;
__END__

=head1 NAME

Test::Harness - run perl standard test scripts with statistics

=head1 SYNOPSIS

use Test::Harness;

runtests(@tests);

=head1 DESCRIPTION

Perl test scripts print to standard output C<"ok N"> for each single
test, where C<N> is an increasing sequence of integers. The first line
output by a standard test script is C<"1..M"> with C<M> being the
number of tests that should be run within the test
script. Test::Harness::runtests(@tests) runs all the testscripts
named as arguments and checks standard output for the expected
C<"ok N"> strings.

After all tests have been performed, runtests() prints some
performance statistics that are computed by the Benchmark module.

=head2 The test script output

Any output from the testscript to standard error is ignored and
bypassed, thus will be seen by the user. Lines written to standard
output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
runtests().  All other lines are discarded.

It is tolerated if the test numbers after C<ok> are omitted. In this
case Test::Harness maintains temporarily its own counter until the
script supplies test numbers again. So the following test script

    print <<END;
    1..6
    not ok
    ok
    not ok
    ok
    ok
    END

will generate 

    FAILED tests 1, 3, 6
    Failed 3/6 tests, 50.00% okay

The global variable $Test::Harness::verbose is exportable and can be
used to let runtests() display the standard output of the script
without altering the behavior otherwise.

=head1 EXPORT

C<&runtests> is exported by Test::Harness per default.

=head1 DIAGNOSTICS

=over 4

=item C<All tests successful.\nFiles=%d,  Tests=%d, %s>

If all tests are successful some statistics about the performance are
printed.

=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>

For any single script that has failing subtests statistics like the
above are printed.

=item C<Test returned status %d (wstat %d)>

Scripts that return a non-zero exit status, both $?>>8 and $? are
printed in a message similar to the above.

=item C<Failed 1 test, %.2f%% okay. %s>

=item C<Failed %d/%d tests, %.2f%% okay. %s>

If not all tests were successful, the script dies with one of the
above messages.

=back

=head1 SEE ALSO

See L<Benchmark> for the underlying timing routines.

=head1 AUTHORS

Either Tim Bunce or Andreas Koenig, we don't know. What we know for
sure is, that it was inspired by Larry Wall's TEST script that came
with perl distributions for ages. Current maintainer is Andreas
Koenig.

=head1 BUGS

Test::Harness uses $^X to determine the perl binary to run the tests
with. Test scripts running via the shebang (C<#!>) line may not be
portable because $^X is not consistent for shebang scripts across
platforms. This is no problem when Test::Harness is run with an
absolute path to the perl binary or when $^X can be found in the path.

=cut
Commit	Line	Data
a0d0e21e	1	package Test::Harness;
a0d0e21e	2
c0ee6f5c	3	use 5.002;
a0d0e21e	4	use Exporter;
a0d0e21e	5	use Benchmark;
4633a7c4	6	use Config;
6c31b336	7	use FileHandle;
760ac839	8	use strict;
	9
	10	use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
	11	@ISA @EXPORT @EXPORT_OK);
c0ee6f5c	12	$have_devel_corestack = 0;
4633a7c4	13
c0ee6f5c	14	$VERSION = "1.12";
4633a7c4	15
c07a80fd	16	@ISA=('Exporter');
cb1a09d0	17	@EXPORT= qw(&runtests);
a0d0e21e	18	@EXPORT_OK= qw($verbose $switches);
a0d0e21e	19
760ac839	20	format STDOUT_TOP =
	21	Failed Test Status Wstat Total Fail Failed List of failed
	22	------------------------------------------------------------------------------
	23	.
	24
	25	format STDOUT =
	26	@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
	27	{ $curtest->{name},
	28	$curtest->{estat},
	29	$curtest->{wstat},
	30	$curtest->{max},
	31	$curtest->{failed},
	32	$curtest->{percent},
	33	$curtest->{canon}
	34	}
	35	.
	36
c07a80fd	37
6c31b336	38	$verbose = 0;
6c31b336	39	$switches = "-w";
a0d0e21e	40
	41	sub runtests {
	42	my(@tests) = @_;
	43	local($\|) = 1;
760ac839	44	my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
6c31b336	45	my $totmax = 0;
6c31b336	46	my $files = 0;
a0d0e21e	47	my $bad = 0;
	48	my $good = 0;
	49	my $total = @tests;
c07a80fd	50	local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
a0d0e21e	51
	52	my $t_start = new Benchmark;
	53	while ($test = shift(@tests)) {
c07a80fd	54	$te = $test;
	55	chop($te);
	56	print "$te" . '.' x (20 - length($te));
6c31b336	57	my $fh = new FileHandle;
6c31b336	58	$fh->open("$^X $switches $test\|") \|\| (print "can't run. $!\n");
c07a80fd	59	$ok = $next = $max = 0;
	60	@failed = ();
	61	while (<$fh>) {
6c31b336	62	if( $verbose ){
c07a80fd	63	print $_;
c07a80fd	64	}
c0ee6f5c	65	if (/^1\.\.([0-9]+)/) {
	66	$max = $1;
	67	$totmax += $max;
	68	$files++;
	69	$next = 1;
	70	} elsif ($max && /^(not\s+)?ok\b/) {
	71	my $this = $next;
	72	if (/^not ok\s(\d)/){
	73	$this = $1 if $1 > 0;
	74	push @failed, $this;
	75	} elsif (/^ok\s(\d)/) {
	76	$this = $1 if $1 > 0;
	77	$ok++;
	78	$totok++;
c07a80fd	79	}
c0ee6f5c	80	if ($this > $next) {
	81	# warn "Test output counter mismatch [test $this]\n";
	82	# no need to warn probably
	83	push @failed, $next..$this-1;
	84	} elsif ($this < $next) {
	85	#we have seen more "ok" lines than the number suggests
	86	warn "Confused test output: test $this answered after test ", $next-1, "\n";
	87	$next = $this;
	88	}
	89	$next = $this + 1;
c07a80fd	90	}
c07a80fd	91	}
6c31b336	92	$fh->close; # must close to reap child resource values
c07a80fd	93	my $wstatus = $?;
c0ee6f5c	94	my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8;
	95	if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) {
	96	print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
	97	if (corestatus($wstatus)) { # until we have a wait module
	98	if ($have_devel_corestack) {
	99	Devel::CoreStack::stack($^X);
	100	} else {
	101	print "\ttest program seems to have generated a core\n";
	102	}
	103	}
	104	$bad++;
760ac839	105	$failedtests{$test} = { canon => '??', max => $max \|\| '??',
	106	failed => '??',
	107	name => $test, percent => undef,
	108	estat => $estatus, wstat => $wstatus,
	109	};
c0ee6f5c	110	} elsif ($ok == $max && $next == $max+1) {
	111	if ($max) {
	112	print "ok\n";
	113	} else {
	114	print "skipping test on this platform\n";
	115	}
c07a80fd	116	$good++;
6c31b336	117	} elsif ($max) {
	118	if ($next <= $max) {
	119	push @failed, $next..$max;
	120	}
c07a80fd	121	if (@failed) {
760ac839	122	my ($txt, $canon) = canonfailed($max,@failed);
	123	print $txt;
	124	$failedtests{$test} = { canon => $canon, max => $max,
	125	failed => scalar @failed,
	126	name => $test, percent => 100*(scalar @failed)/$max,
	127	estat => '', wstat => '',
	128	};
c07a80fd	129	} else {
c0ee6f5c	130	print "Don't know which tests failed: got $ok ok, expected $max\n";
760ac839	131	$failedtests{$test} = { canon => '??', max => $max,
	132	failed => '??',
	133	name => $test, percent => undef,
	134	estat => '', wstat => '',
	135	};
c07a80fd	136	}
c07a80fd	137	$bad++;
6c31b336	138	} elsif ($next == 0) {
	139	print "FAILED before any test output arrived\n";
	140	$bad++;
760ac839	141	$failedtests{$test} = { canon => '??', max => '??',
	142	failed => '??',
	143	name => $test, percent => undef,
	144	estat => '', wstat => '',
	145	};
6c31b336	146	}
a0d0e21e	147	}
a0d0e21e	148	my $t_total = timediff(new Benchmark, $t_start);
c07a80fd	149
6c31b336	150	if ($bad == 0 && $totmax) {
c07a80fd	151	print "All tests successful.\n";
6c31b336	152	} elsif ($total==0){
	153	die "FAILED--no tests were run for some reason.\n";
	154	} elsif ($totmax==0) {
	155	my $blurb = $total==1 ? "script" : "scripts";
c0ee6f5c	156	die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
c07a80fd	157	} else {
c07a80fd	158	$pct = sprintf("%.2f", $good / $total * 100);
6c31b336	159	my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
6c31b336	160	$totmax - $totok, $totmax, 100*$totok/$totmax;
760ac839	161	my $script;
	162	for $script (sort keys %failedtests) {
	163	$curtest = $failedtests{$script};
	164	write;
	165	}
	166	if ($bad > 1) {
6c31b336	167	die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
c07a80fd	168	}
	169	}
	170	printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
f0a9308e	171
f0a9308e	172	return ($bad == 0 && $totmax) ;
c07a80fd	173	}
c07a80fd	174
c0ee6f5c	175	sub corestatus {
	176	my($st) = @_;
	177	my($ret);
	178
	179	eval {require 'wait.ph'};
	180	if ($@) {
	181	SWITCH: {
	182	$ret = ($st & 0200); # Tim says, this is for 90%
	183	}
	184	} else {
	185	$ret = WCOREDUMP($st);
	186	}
	187
	188	eval {require Devel::CoreStack};
	189	$have_devel_corestack++ unless $@;
	190
	191	$ret;
	192	}
	193
c07a80fd	194	sub canonfailed ($@) {
c07a80fd	195	my($max,@failed) = @_;
6c31b336	196	my %seen;
6c31b336	197	@failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
c07a80fd	198	my $failed = @failed;
	199	my @result = ();
	200	my @canon = ();
	201	my $min;
	202	my $last = $min = shift @failed;
760ac839	203	my $canon;
c07a80fd	204	if (@failed) {
	205	for (@failed, $failed[-1]) { # don't forget the last one
	206	if ($_ > $last+1 \|\| $_ == $last) {
	207	if ($min == $last) {
	208	push @canon, $last;
	209	} else {
	210	push @canon, "$min-$last";
	211	}
	212	$min = $_;
	213	}
	214	$last = $_;
	215	}
	216	local $" = ", ";
	217	push @result, "FAILED tests @canon\n";
760ac839	218	$canon = "@canon";
a0d0e21e	219	} else {
c07a80fd	220	push @result, "FAILED test $last\n";
760ac839	221	$canon = $last;
a0d0e21e	222	}
c07a80fd	223
	224	push @result, "\tFailed $failed/$max tests, ";
	225	push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
760ac839	226	my $txt = join "", @result;
760ac839	227	($txt, $canon);
a0d0e21e	228	}
	229
	230	1;
cb1a09d0	231	__END__
	232
	233	=head1 NAME
	234
	235	Test::Harness - run perl standard test scripts with statistics
	236
	237	=head1 SYNOPSIS
	238
	239	use Test::Harness;
	240
	241	runtests(@tests);
	242
	243	=head1 DESCRIPTION
	244
	245	Perl test scripts print to standard output C<"ok N"> for each single
	246	test, where C<N> is an increasing sequence of integers. The first line
c0ee6f5c	247	output by a standard test script is C<"1..M"> with C<M> being the
cb1a09d0	248	number of tests that should be run within the test
c0ee6f5c	249	script. Test::Harness::runtests(@tests) runs all the testscripts
cb1a09d0	250	named as arguments and checks standard output for the expected
	251	C<"ok N"> strings.
	252
c0ee6f5c	253	After all tests have been performed, runtests() prints some
cb1a09d0	254	performance statistics that are computed by the Benchmark module.
cb1a09d0	255
6c31b336	256	=head2 The test script output
	257
	258	Any output from the testscript to standard error is ignored and
	259	bypassed, thus will be seen by the user. Lines written to standard
c0ee6f5c	260	output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
c0ee6f5c	261	runtests(). All other lines are discarded.
6c31b336	262
	263	It is tolerated if the test numbers after C<ok> are omitted. In this
	264	case Test::Harness maintains temporarily its own counter until the
	265	script supplies test numbers again. So the following test script
	266
	267	print <<END;
	268	1..6
	269	not ok
	270	ok
	271	not ok
	272	ok
	273	ok
	274	END
	275
	276	will generate
	277
	278	FAILED tests 1, 3, 6
	279	Failed 3/6 tests, 50.00% okay
	280
	281	The global variable $Test::Harness::verbose is exportable and can be
c0ee6f5c	282	used to let runtests() display the standard output of the script
6c31b336	283	without altering the behavior otherwise.
6c31b336	284
cb1a09d0	285	=head1 EXPORT
cb1a09d0	286
c0ee6f5c	287	C<&runtests> is exported by Test::Harness per default.
cb1a09d0	288
	289	=head1 DIAGNOSTICS
	290
	291	=over 4
	292
	293	=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
	294
	295	If all tests are successful some statistics about the performance are
	296	printed.
	297
6c31b336	298	=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
	299
	300	For any single script that has failing subtests statistics like the
	301	above are printed.
	302
	303	=item C<Test returned status %d (wstat %d)>
	304
	305	Scripts that return a non-zero exit status, both $?>>8 and $? are
	306	printed in a message similar to the above.
	307
	308	=item C<Failed 1 test, %.2f%% okay. %s>
cb1a09d0	309
6c31b336	310	=item C<Failed %d/%d tests, %.2f%% okay. %s>
cb1a09d0	311
	312	If not all tests were successful, the script dies with one of the
	313	above messages.
	314
	315	=back
	316
	317	=head1 SEE ALSO
	318
c07a80fd	319	See L<Benchmark> for the underlying timing routines.
	320
	321	=head1 AUTHORS
	322
	323	Either Tim Bunce or Andreas Koenig, we don't know. What we know for
	324	sure is, that it was inspired by Larry Wall's TEST script that came
	325	with perl distributions for ages. Current maintainer is Andreas
	326	Koenig.
cb1a09d0	327
	328	=head1 BUGS
	329
	330	Test::Harness uses $^X to determine the perl binary to run the tests
6c31b336	331	with. Test scripts running via the shebang (C<#!>) line may not be
6c31b336	332	portable because $^X is not consistent for shebang scripts across
cb1a09d0	333	platforms. This is no problem when Test::Harness is run with an
6c31b336	334	absolute path to the perl binary or when $^X can be found in the path.
cb1a09d0	335
cb1a09d0	336	=cut