From: Perl 5 Porters Date: Mon, 8 Jul 1996 23:22:00 +0000 (+0000) Subject: perl 5.003_01: lib/Test/Harness.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0ee6f5c4ced6a652202f9e7ad8d0b76aa70994f;p=p5sagit%2Fp5-mst-13.2.git perl 5.003_01: lib/Test/Harness.pm Incorporate new "use " syntax Update to version 1.12, providing improved "skipped" message and first-pass Unix support for Devel::CoreStack --- diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 7d899a6..2a89f20 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,13 +1,14 @@ package Test::Harness; +use 5.002; use Exporter; use Benchmark; use Config; use FileHandle; -use vars qw($VERSION $verbose $switches); -require 5.002; +use vars qw($VERSION $verbose $switches $have_devel_corestack); +$have_devel_corestack = 0; -$VERSION = "1.07"; +$VERSION = "1.12"; @ISA=('Exporter'); @EXPORT= qw(&runtests); @@ -41,40 +42,52 @@ sub runtests { if( $verbose ){ print $_; } - unless (/^\s*\#/) { - 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 "Aborting test: output counter mismatch [test $this answered when test $next expected]\n"; - last; - } - $next = $this + 1; + 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 = $wstatus >> 8; - if ($ok == $max && $next == $max+1 && ! $estatus) { - print "ok\n"; + 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++; + } 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) { @@ -83,16 +96,13 @@ sub runtests { if (@failed) { print canonfailed($max,@failed); } else { - print "Don't know which tests failed for some reason\n"; + print "Don't know which tests failed: got $ok ok, expected $max\n"; } $bad++; } elsif ($next == 0) { print "FAILED before any test output arrived\n"; $bad++; } - if ($wstatus) { - print "\tTest returned status $estatus (wstat $wstatus)\n"; - } } my $t_total = timediff(new Benchmark, $t_start); @@ -102,7 +112,7 @@ sub runtests { 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"; + 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.", @@ -116,6 +126,25 @@ sub runtests { printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop')); } +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; @@ -165,22 +194,21 @@ runtests(@tests); Perl test scripts print to standard output C<"ok N"> for each single test, where C is an increasing sequence of integers. The first line -output by a standard test scxript is C<"1..M"> with C being the +output by a standard test script is C<"1..M"> with C being the number of tests that should be run within the test -script. Test::Harness::runscripts(@tests) runs all the testscripts +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, runscripts() prints some +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 that look like perl comments (start with C) are -discarded. Lines containing C are interpreted as -feedback for runtests(). +output containing C are interpreted as feedback for +runtests(). All other lines are discarded. It is tolerated if the test numbers after C are omitted. In this case Test::Harness maintains temporarily its own counter until the @@ -201,12 +229,12 @@ will generate Failed 3/6 tests, 50.00% okay The global variable $Test::Harness::verbose is exportable and can be -used to let runscripts() display the standard output of the script +used to let runtests() display the standard output of the script without altering the behavior otherwise. =head1 EXPORT -C<&runscripts> is exported by Test::Harness per default. +C<&runtests> is exported by Test::Harness per default. =head1 DIAGNOSTICS