perl 5.003_01: lib/Test/Harness.pm

Incorporate new "use <version>" syntax
Update to version 1.12, providing improved "skipped" message and
  first-pass Unix support for Devel::CoreStack

1 files changed, 73 insertions, 45 deletions

diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 7d899a69f9..2a89f20dde 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<N> is an increasing sequence of integers. The first line
-output by a standard test scxript is C<"1..M"> with C<M> being the
+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::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</^\s*\#/>) are
-discarded. Lines containing C</^(not\s+)?ok\b/> are interpreted as
-feedback for runtests().
+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
@@ -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