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

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

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