[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'));
}

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'));
	171	}
	172
c0ee6f5c	173	sub corestatus {
	174	my($st) = @_;
	175	my($ret);
	176
	177	eval {require 'wait.ph'};
	178	if ($@) {
	179	SWITCH: {
	180	$ret = ($st & 0200); # Tim says, this is for 90%
	181	}
	182	} else {
	183	$ret = WCOREDUMP($st);
	184	}
	185
	186	eval {require Devel::CoreStack};
	187	$have_devel_corestack++ unless $@;
	188
	189	$ret;
	190	}
	191
c07a80fd	192	sub canonfailed ($@) {
c07a80fd	193	my($max,@failed) = @_;
6c31b336	194	my %seen;
6c31b336	195	@failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
c07a80fd	196	my $failed = @failed;
	197	my @result = ();
	198	my @canon = ();
	199	my $min;
	200	my $last = $min = shift @failed;
760ac839	201	my $canon;
c07a80fd	202	if (@failed) {
	203	for (@failed, $failed[-1]) { # don't forget the last one
	204	if ($_ > $last+1 \|\| $_ == $last) {
	205	if ($min == $last) {
	206	push @canon, $last;
	207	} else {
	208	push @canon, "$min-$last";
	209	}
	210	$min = $_;
	211	}
	212	$last = $_;
	213	}
	214	local $" = ", ";
	215	push @result, "FAILED tests @canon\n";
760ac839	216	$canon = "@canon";
a0d0e21e	217	} else {
c07a80fd	218	push @result, "FAILED test $last\n";
760ac839	219	$canon = $last;
a0d0e21e	220	}
c07a80fd	221
	222	push @result, "\tFailed $failed/$max tests, ";
	223	push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
760ac839	224	my $txt = join "", @result;
760ac839	225	($txt, $canon);
a0d0e21e	226	}
	227
	228	1;
cb1a09d0	229	__END__
	230
	231	=head1 NAME
	232
	233	Test::Harness - run perl standard test scripts with statistics
	234
	235	=head1 SYNOPSIS
	236
	237	use Test::Harness;
	238
	239	runtests(@tests);
	240
	241	=head1 DESCRIPTION
	242
	243	Perl test scripts print to standard output C<"ok N"> for each single
	244	test, where C<N> is an increasing sequence of integers. The first line
c0ee6f5c	245	output by a standard test script is C<"1..M"> with C<M> being the
cb1a09d0	246	number of tests that should be run within the test
c0ee6f5c	247	script. Test::Harness::runtests(@tests) runs all the testscripts
cb1a09d0	248	named as arguments and checks standard output for the expected
	249	C<"ok N"> strings.
	250
c0ee6f5c	251	After all tests have been performed, runtests() prints some
cb1a09d0	252	performance statistics that are computed by the Benchmark module.
cb1a09d0	253
6c31b336	254	=head2 The test script output
	255
	256	Any output from the testscript to standard error is ignored and
	257	bypassed, thus will be seen by the user. Lines written to standard
c0ee6f5c	258	output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
c0ee6f5c	259	runtests(). All other lines are discarded.
6c31b336	260
	261	It is tolerated if the test numbers after C<ok> are omitted. In this
	262	case Test::Harness maintains temporarily its own counter until the
	263	script supplies test numbers again. So the following test script
	264
	265	print <<END;
	266	1..6
	267	not ok
	268	ok
	269	not ok
	270	ok
	271	ok
	272	END
	273
	274	will generate
	275
	276	FAILED tests 1, 3, 6
	277	Failed 3/6 tests, 50.00% okay
	278
	279	The global variable $Test::Harness::verbose is exportable and can be
c0ee6f5c	280	used to let runtests() display the standard output of the script
6c31b336	281	without altering the behavior otherwise.
6c31b336	282
cb1a09d0	283	=head1 EXPORT
cb1a09d0	284
c0ee6f5c	285	C<&runtests> is exported by Test::Harness per default.
cb1a09d0	286
	287	=head1 DIAGNOSTICS
	288
	289	=over 4
	290
	291	=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
	292
	293	If all tests are successful some statistics about the performance are
	294	printed.
	295
6c31b336	296	=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
	297
	298	For any single script that has failing subtests statistics like the
	299	above are printed.
	300
	301	=item C<Test returned status %d (wstat %d)>
	302
	303	Scripts that return a non-zero exit status, both $?>>8 and $? are
	304	printed in a message similar to the above.
	305
	306	=item C<Failed 1 test, %.2f%% okay. %s>
cb1a09d0	307
6c31b336	308	=item C<Failed %d/%d tests, %.2f%% okay. %s>
cb1a09d0	309
	310	If not all tests were successful, the script dies with one of the
	311	above messages.
	312
	313	=back
	314
	315	=head1 SEE ALSO
	316
c07a80fd	317	See L<Benchmark> for the underlying timing routines.
	318
	319	=head1 AUTHORS
	320
	321	Either Tim Bunce or Andreas Koenig, we don't know. What we know for
	322	sure is, that it was inspired by Larry Wall's TEST script that came
	323	with perl distributions for ages. Current maintainer is Andreas
	324	Koenig.
cb1a09d0	325
	326	=head1 BUGS
	327
	328	Test::Harness uses $^X to determine the perl binary to run the tests
6c31b336	329	with. Test scripts running via the shebang (C<#!>) line may not be
6c31b336	330	portable because $^X is not consistent for shebang scripts across
cb1a09d0	331	platforms. This is no problem when Test::Harness is run with an
6c31b336	332	absolute path to the perl binary or when $^X can be found in the path.
cb1a09d0	333
cb1a09d0	334	=cut