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