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