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

package Test::Harness;

require 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.13";

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