allow the Test::Harness to grok TODO-type tests docs

p4raw-id: //depot/perl@539

2 files changed, 171 insertions, 9 deletions

diff --git a/lib/Test.pm b/lib/Test.pm
new file mode 100644
index 0000000000..7e79da2bf4
--- /dev/null
+++ b/lib/Test.pm
@@ -0,0 +1,134 @@
+use strict;
+package Test;
+use Test::Harness 1.1601 ();
+use Carp;
+use vars qw($VERSION @ISA @EXPORT $ntest %todo);
+$VERSION = '0.06';
+require Exporter;
+@ISA=('Exporter');
+@EXPORT= qw(&plan &ok &skip $ntest);
+
+$|=1;
+#$^W=1;  ?
+$ntest=1;
+
+# Use of this variable is strongly discouraged.  It is set
+# exclusively for test coverage analyzers.
+$ENV{REGRESSION_TEST} = $0;
+
+sub plan {
+    croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+    my $max=0;
+    for (my $x=0; $x < @_; $x+=2) {
+	my ($k,$v) = @_[$x,$x+1];
+	if ($k =~ /^test(s)?$/) { $max = $v; }
+	elsif ($k eq 'todo' or 
+	       $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+	else { carp "Test::plan(): skipping unrecognized directive '$k'" }
+    }
+    my @todo = sort { $a <=> $b } keys %todo;
+    if (@todo) {
+	print "1..$max todo ".join(' ', @todo).";\n";
+    } else {
+	print "1..$max\n";
+    }
+}
+
+sub ok {
+    my ($ok, $guess) = @_;
+    carp "(this is ok $ntest)" if defined $guess && $guess != $ntest;
+    $ok = $ok->() if (ref $ok or '') eq 'CODE';
+    if ($ok) {
+	if ($todo{$ntest}) {
+	    print("ok $ntest # Wow!\n");
+	} else {
+	    print("ok $ntest # (failure expected)\n");
+	}
+    } else {
+	print("not ok $ntest\n");
+    }
+    ++ $ntest;
+    $ok;
+}
+
+sub skip {
+    my ($toskip, $ok, $guess) = @_;
+    carp "(this is skip $ntest)" if defined $guess && $guess != $ntest;
+    $toskip = $toskip->() if (ref $toskip or '') eq 'CODE';
+    if ($toskip) {
+	print "ok $ntest # skip\n";
+	++ $ntest;
+	1;
+    } else {
+	ok($ok);
+    }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+  Test - provides a simple framework for writing test scripts
+
+=head1 SYNOPSIS
+
+  use strict;
+  use Test;
+  BEGIN { plan tests => 5, todo => [3,4] }
+
+  ok(0); #failure
+  ok(1); #success
+
+  ok(0); #ok, expected failure (see todo above)
+  ok(1); #surprise success!
+
+  skip($feature_is_missing, sub {...});    #do platform specific test
+
+=head1 DESCRIPTION
+
+Test::Harness expects to see particular output when it executes test
+scripts.  This module tries to make conforming just a little bit
+easier (and less error prone).
+
+=head1 TEST CATEGORIES
+
+=over 4
+
+=item * NORMAL TESTS
+
+These tests are expected to succeed.  If they don't, something is
+wrong!
+
+=item * SKIPPED TESTS
+
+C<skip> should be used to skip tests for which a platform specific
+feature isn't available.
+
+=item * TODO TESTS
+
+TODO tests are designed for the purpose of maintaining an executable
+TODO list.  These tests are expected NOT to succeed (otherwise the
+feature they test would be on the new feature list, not the TODO
+list).
+
+Packages should NOT be released with successful TODO tests.  As soon
+as a TODO test starts working, it should be promoted to a normal test
+and the new feature should be documented in the release notes.
+
+=back
+
+=head1 SEE ALSO
+
+L<Test::Harness> and various test coverage analysis tools.
+
+=head1 AUTHOR
+
+Copyright © 1998 Joshua Nathaniel Pritikin.  All rights reserved.
+
+This package is free software and is provided "as is" without express
+or implied warranty.  It may be used, redistributed and/or modified
+under the terms of the Perl Artistic License (see
+http://www.perl.com/perl/misc/Artistic.html)
+
+=cut
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 37f4a9fbde..8102ff4cac 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -11,7 +11,7 @@ use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
 	    @ISA @EXPORT @EXPORT_OK);
 $have_devel_corestack = 0;
 
-$VERSION = "1.1502";
+$VERSION = "1.1601";
 
 @ISA=('Exporter');
 @EXPORT= qw(&runtests);
@@ -43,7 +43,7 @@ $switches = "-w";
 sub runtests {
     my(@tests) = @_;
     local($|) = 1;
-    my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
+    my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests);
     my $totmax = 0;
     my $files = 0;
     my $bad = 0;
@@ -73,12 +73,20 @@ sub runtests {
 	$fh->open($cmd) or print "can't run $test. $!\n";
 	$ok = $next = $max = 0;
 	@failed = ();
+	my %todo = ();
+        my $bonus = 0;
 	my $skipped = 0;
 	while (<$fh>) {
 	    if( $verbose ){
 		print $_;
 	    }
-	    if (/^1\.\.([0-9]+)/) {
+	    if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
+		$max = $1;
+		for (split(/\s+/, $2)) { $todo{$_} = 1; }
+		$totmax += $max;
+		$files++;
+		$next = 1;
+	    } elsif (/^1\.\.([0-9]+)/) {
 		$max = $1;
 		$totmax += $max;
 		$files++;
@@ -87,12 +95,18 @@ sub runtests {
 		my $this = $next;
 		if (/^not ok\s*(\d*)/){
 		    $this = $1 if $1 > 0;
-		    push @failed, $this;
+		    if (!$todo{$this}) {
+			push @failed, $this;
+		    } else {
+			$ok++;
+			$totok++;
+		    }
 		} elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
 		    $this = $1 if $1 > 0;
 		    $ok++;
 		    $totok++;
 		    $skipped++ if defined $2;
+		    $bonus++, $totbonus++ if $todo{$this};
 		}
 		if ($this > $next) {
 		    # warn "Test output counter mismatch [test $this]\n";
@@ -144,9 +158,14 @@ sub runtests {
 				    estat => $estatus, wstat => $wstatus,
 				  };
 	} elsif ($ok == $max && $next == $max+1) {
-	    if ($max and $skipped) {
-	        my $ender = 's' x ($skipped > 1);
-		print "ok, $skipped subtest$ender skipped on this platform\n";
+	    if ($max and $skipped + $bonus) {
+		my @msg;
+		push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped")
+		    if $skipped;
+		push(@msg, "$bonus subtest".($bonus>1?'s':'').
+		     " unexpectedly succeeded")
+		    if $bonus;
+		print "ok, ".join(', ', @msg)."\n";
 	    } elsif ($max) {
 		print "ok\n";
 	    } else {
@@ -193,8 +212,12 @@ sub runtests {
 	    delete $ENV{PERL5LIB};
 	}
     }
+    my $bonusmsg = '';
+    $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
+	       " UNEXPECTEDLY SUCCEEDED)")
+	if $totbonus;
     if ($bad == 0 && $totmax) {
-	    print "All tests successful.\n";
+	print "All tests successful$bonusmsg.\n";
     } elsif ($total==0){
 	die "FAILED--no tests were run for some reason.\n";
     } elsif ($totmax==0) {
@@ -289,6 +312,10 @@ runtests(@tests);
 
 =head1 DESCRIPTION
 
+(By using the L<Test> module, you can write test scripts without
+knowing the exact output this module expects.  However, if you need to
+know the specifics, read on!)
+
 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
@@ -372,7 +399,8 @@ above messages.
 
 =head1 SEE ALSO
 
-See L<Benchmark> for the underlying timing routines.
+L<Test> for writing test scripts and also L<Benchmark> for the
+underlying timing routines.
 
 =head1 AUTHORS