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

package Test::Harness;

BEGIN {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.15";

@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;

    # pass -I flags to children
    my $old5lib = $ENV{PERL5LIB};
    local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);

    if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }

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