This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test::Harness 2.01
authorMichael G. Schwern <schwern@pobox.com>
Thu, 10 Jan 2002 21:11:24 +0000 (16:11 -0500)
committerJarkko Hietaniemi <jhi@iki.fi>
Fri, 11 Jan 2002 13:57:59 +0000 (13:57 +0000)
Message-ID: <20020111021123.GA30666@blackrider>

p4raw-id: //depot/perl@14182

18 files changed:
MANIFEST
lib/Test/Harness.pm
lib/Test/Harness/Assert.pm [new file with mode: 0644]
lib/Test/Harness/Changes
lib/Test/Harness/Iterator.pm [new file with mode: 0644]
lib/Test/Harness/Straps.pm [new file with mode: 0644]
lib/Test/Harness/t/00compile.t [new file with mode: 0644]
lib/Test/Harness/t/assert.t [new file with mode: 0644]
lib/Test/Harness/t/base.t
lib/Test/Harness/t/callback.t [new file with mode: 0644]
lib/Test/Harness/t/nonumbers.t [new file with mode: 0644]
lib/Test/Harness/t/strap-analyze.t [new file with mode: 0644]
lib/Test/Harness/t/strap.t [new file with mode: 0644]
lib/Test/Harness/t/test-harness.t
t/lib/sample-tests/lone_not_bug [new file with mode: 0644]
t/lib/sample-tests/out_of_order [new file with mode: 0644]
t/lib/sample-tests/taint [new file with mode: 0644]
t/lib/sample-tests/vms_nit [new file with mode: 0644]

index f50585c..da98206 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1269,16 +1269,25 @@ lib/termcap.pl                  Perl library supporting termcap usage
 lib/Test.pm                    A simple framework for writing test scripts
 lib/Test/Builder.pm             For writing new test libraries
 lib/Test/Harness.pm            A test harness
+lib/Test/Harness/Assert.pm  Test::Harness::Assert (internal use only)
 lib/Test/Harness/Changes       Test::Harness
-lib/Test/Harness/t/base.t      Test::Harness
-lib/Test/Harness/t/ok.t                Test::Harness
+lib/Test/Harness/Iterator.pm    Test::Harness::Iterator (internal use only)
+lib/Test/Harness/Straps.pm      Test::Harness::Straps
+lib/Test/Harness/t/00compile.t  Test::Harness test
+lib/Test/Harness/t/assert.t     Test::Harness::Assert test
+lib/Test/Harness/t/base.t      Test::Harness test
+lib/Test/Harness/t/callback.t   Test::Harness test
+lib/Test/Harness/t/nonumbers.t  Test::Harness test
+lib/Test/Harness/t/ok.t                Test::Harness test
+lib/Test/Harness/t/strap-analyze.t      Test::Harness::Straps test
+lib/Test/Harness/t/strap.t              Test::Harness::Straps test
 lib/Test/Harness/t/test-harness.t      Test::Harness test
 lib/Test/More.pm                More utilities for writing tests
 lib/Test/Simple.pm              Basic utility for writing tests
 lib/Test/Simple/Changes                Test::Simple changes
 lib/Test/Simple/README         Test::Simple README
-lib/Test/Simple/t/Builder.t     Test::Builder tests
 lib/Test/Simple/t/buffer.t      Test::Builder buffering test
+lib/Test/Simple/t/Builder.t     Test::Builder tests
 lib/Test/Simple/t/diag.t        Test::More diag() test
 lib/Test/Simple/t/exit.t        Test::Simple test, exit codes
 lib/Test/Simple/t/extra.t       Test::Simple test
@@ -2147,14 +2156,18 @@ t/lib/sample-tests/descriptive          Test data for Test::Harness
 t/lib/sample-tests/duplicates          Test data for Test::Harness
 t/lib/sample-tests/head_end            Test data for Test::Harness
 t/lib/sample-tests/head_fail           Test data for Test::Harness
+t/lib/sample-tests/lone_not_bug         Test data for Test::Harness
 t/lib/sample-tests/no_nums             Test data for Test::Harness
+t/lib/sample-tests/out_of_order         Test data for Test::Harness
 t/lib/sample-tests/simple              Test data for Test::Harness
 t/lib/sample-tests/simple_fail         Test data for Test::Harness
 t/lib/sample-tests/skip                        Test data for Test::Harness
 t/lib/sample-tests/skip_all            Test data for Test::Harness
 t/lib/sample-tests/skip_no_msg         Test data for Test::Harness
+t/lib/sample-tests/taint                Test data for Test::Harness
 t/lib/sample-tests/todo                        Test data for Test::Harness
 t/lib/sample-tests/todo_inline         Test data for Test::Harness
+t/lib/sample-tests/vms_nit              Test data for Test::Harness
 t/lib/sample-tests/with_comments       Test data for Test::Harness
 t/lib/st-dump.pl               See if Storable works
 t/lib/strict/refs              Tests of "use strict 'refs'" for strict.t
index 26bdf71..e1d5154 100644 (file)
@@ -1,9 +1,11 @@
 # -*- Mode: cperl; cperl-indent-level: 4 -*-
-# $Id: Harness.pm,v 1.17 2001/09/07 06:20:29 schwern Exp $
+# $Id: Harness.pm,v 1.14.2.13 2002/01/07 22:34:32 schwern Exp $
 
 package Test::Harness;
 
 require 5.004;
+use Test::Harness::Straps;
+use Test::Harness::Assert;
 use Exporter;
 use Benchmark;
 use Config;
@@ -20,15 +22,21 @@ use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest
 
 $Have_Devel_Corestack = 0;
 
-$VERSION = 1.26;
+$VERSION = '2.01';
 
 $ENV{HARNESS_ACTIVE} = 1;
 
+END {
+    # For VMS.
+    delete $ENV{HARNESS_ACTIVE};
+}
+
 # Some experimental versions of OS/2 build have broken $?
 my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
 
 my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
 
+my $Strap = Test::Harness::Straps->new;
 
 @ISA = ('Exporter');
 @EXPORT    = qw(&runtests);
@@ -125,18 +133,14 @@ will generate
     FAILED tests 1, 3, 6
     Failed 3/6 tests, 50.00% okay
 
+=item B<test names>
 
-=item B<$Test::Harness::verbose>
+Anything after the test number but before the # is considered to be
+the name of the test.
 
-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.
+  ok 42 this is the name of the test
 
-=item B<$Test::Harness::switches>
-
-The global variable $Test::Harness::switches is exportable and can be
-used to set perl command line options used for running the test
-script(s). The default value is C<-w>.
+Currently, Test::Harness does nothing with this information.
 
 =item B<Skipping tests>
 
@@ -163,6 +167,19 @@ succeed.
 
   not ok 13 # TODO harness the power of the atom
 
+=begin _deprecated
+
+Alternatively, you can specify a list of what tests are todo as part
+of the test header.
+
+  1..23 todo 5 12 23
+
+This only works if the header appears at the beginning of the test.
+
+This style is B<deprecated>.
+
+=end _deprecated
+
 These tests represent a feature to be implemented or a bug to be fixed
 and act as something of an executable "thing to do" list.  They are
 B<not> expected to succeed.  Should a todo test begin succeeding,
@@ -201,6 +218,38 @@ test script, please use a comment.
 =back
 
 
+=head2 Taint mode
+
+Test::Harness will honor the C<-T> in the #! line on your test files.  So
+if you begin a test with:
+
+    #!perl -T
+
+the test will be run with taint mode on.
+
+
+=head2 Configuration variables.
+
+These variables can be used to configure the behavior of
+Test::Harness.  They are exported on request.
+
+=over 4
+
+=item B<$Test::Harness::verbose>
+
+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.
+
+=item B<$Test::Harness::switches>
+
+The global variable $Test::Harness::switches is exportable and can be
+used to set perl command line options used for running the test
+script(s). The default value is C<-w>.
+
+=back
+
+
 =head2 Failure
 
 It will happen, your tests will fail.  After you mop up your ego, you
@@ -291,8 +340,8 @@ sub runtests {
 
     my $ok = _all_ok($tot);
 
-    die q{Assert '$ok xor keys %$failedtests' failed!}
-      unless $ok xor keys %$failedtests;
+    assert(($ok xor keys %$failedtests), 
+           q{ok status jives with $failedtests});
 
     return $ok;
 }
@@ -391,39 +440,15 @@ sub _run_all_tests {
                 bench    => 0,
                );
 
-    # pass -I flags to children
-    my $old5lib = $ENV{PERL5LIB};
-
-    # VMS has a 255-byte limit on the length of %ENV entries, so
-    # toss the ones that involve perl_root, the install location
-    # for VMS
-    my $new5lib;
-    if ($^O eq 'VMS') {
-        $new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC);
-        $Switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
-    }
-    else {
-        $new5lib = join($Config{path_sep}, @INC);
-    }
-
-    local($ENV{'PERL5LIB'}) = $new5lib;
+    local($ENV{'PERL5LIB'}) = $Strap->_INC2PERL5LIB;
 
     my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
     my $t_start = new Benchmark;
 
-    my $maxlen = 0;
-    my $maxsuflen = 0;
-    foreach (@tests) { # The same code in t/TEST
-       my $suf    = /\.(\w+)$/ ? $1 : '';
-       my $len    = length;
-       my $suflen = length $suf;
-       $maxlen    = $len    if $len    > $maxlen;
-       $maxsuflen = $suflen if $suflen > $maxsuflen;
-    }
-    # + 3 : we want three dots between the test name and the "ok"
-    my $width = $maxlen + 3 - $maxsuflen;
-
+    my $width = _leader_width(@tests);
     foreach my $tfile (@tests) {
+        $Strap->_reset_file_state;
+
         my($leader, $ml) = _mk_leader($tfile, $width);
         print $leader;
 
@@ -444,6 +469,9 @@ sub _run_all_tests {
 
         my($seen_header, $tests_seen) = (0,0);
         while (<$fh>) {
+            print if $Verbose;
+
+            $Strap->{line}++;
             if( _parse_header($_, \%test, \%tot) ) {
                 warn "Test header seen twice!\n" if $seen_header;
 
@@ -543,16 +571,12 @@ sub _run_all_tests {
                 @dir_files = @new_dir_files;
             }
         }
+
+        close $fh;
     }
     $tot{bench} = timediff(new Benchmark, $t_start);
 
-    if ($^O eq 'VMS') {
-        if (defined $old5lib) {
-            $ENV{PERL5LIB} = $old5lib;
-        } else {
-            delete $ENV{PERL5LIB};
-        }
-    }
+    $Strap->_restore_PERL5LIB;
 
     return(\%tot, \%failedtests);
 }
@@ -586,6 +610,29 @@ sub _mk_leader {
     return($leader, $ml);
 }
 
+=item B<_leader_width>
+
+  my($width) = _leader_width(@test_files);
+
+Calculates how wide the leader should be based on the length of the
+longest test name.
+
+=cut
+
+sub _leader_width {
+    my $maxlen = 0;
+    my $maxsuflen = 0;
+    foreach (@_) {
+        my $suf    = /\.(\w+)$/ ? $1 : '';
+        my $len    = length;
+        my $suflen = length $suf;
+        $maxlen    = $len    if $len    > $maxlen;
+        $maxsuflen = $suflen if $suflen > $maxsuflen;
+    }
+    # + 3 : we want three dots between the test name and the "ok"
+    return $maxlen + 3 - $maxsuflen;
+}
+
 
 sub _show_results {
     my($tot, $failedtests) = @_;
@@ -633,32 +680,20 @@ sub _parse_header {
 
     my $is_header = 0;
 
-    print $line if $Verbose;
+    if( $Strap->_is_header($line) ) {
+        $is_header = 1;
 
-    # 1..10 todo 4 7 10;
-    if ($line =~ /^1\.\.([0-9]+) todo([\d\s]+);?/i) {
-        $test->{max} = $1;
-        for (split(/\s+/, $2)) { $test->{todo}{$_} = 1; }
+        $test->{max} = $Strap->{max};
+        for ( keys %{$Strap->{todo}} ) { $test->{todo}{$_} = 1; }
 
-        $tot->{max} += $test->{max};
-        $tot->{files}++;
+        $test->{skip_reason} = $Strap->{skip_all} 
+          if not $test->{max} and defined $Strap->{skip_all};
 
-        $is_header = 1;
-    }
-    # 1..10
-    # 1..0 # skip  Why?  Because I said so!
-    elsif ($line =~ /^1\.\.([0-9]+)
-                      (\s*\#\s*[Ss]kip\S*\s* (.+))?
-                    /x
-          )
-    {
-        $test->{max} = $1;
-        $tot->{max} += $test->{max};
-        $tot->{files}++;
         $test->{'next'} = 1 unless $test->{'next'};
-        $test->{skip_reason} = $3 if not $test->{max} and defined $3;
 
-        $is_header = 1;
+
+        $tot->{max} += $test->{max};
+        $tot->{files}++;
     }
     else {
         $is_header = 0;
@@ -689,77 +724,57 @@ sub _open_test {
     }
 }
 
-sub _run_one_test {
-    my($test) = @_;
-
-    
-}
-
 
 sub _parse_test_line {
     my($line, $test, $tot) = @_;
 
-    if ($line =~ /^(not\s+)?ok\b/i) {
+    my %result;
+    if ( $Strap->_is_test($line, \%result) ) {
         $test->{'next'} ||= 1;
         my $this = $test->{'next'};
-        # "not ok 23"
-        if ($line =~ /^(not )?ok\s*(\d*)[^#]*(\s*#.*)?/) {
-            my($not, $tnum, $extra) = ($1, $2, $3);
 
-            $this = $tnum if $tnum;
+        my($not, $tnum) = (!$result{ok}, $result{number});
 
-            my($type, $reason) = $extra =~ /^\s*#\s*([Ss]kip\S*|TODO)(\s+.+)?/
-              if defined $extra;
+        $this = $tnum if $tnum;
 
-            my($istodo, $isskip);
-            if( defined $type ) {
-                $istodo = 1 if $type =~ /TODO/;
-                $isskip = 1 if $type =~ /skip/i;
-            }
+        my($type, $reason) = ($result{type}, $result{reason});
 
-            $test->{todo}{$this} = 1 if $istodo;
+        my($istodo, $isskip);
+        if( defined $type ) {
+            $istodo = 1 if $type eq 'todo';
+            $isskip = 1 if $type eq 'skip';
+        }
 
-            $tot->{todo}++ if $test->{todo}{$this};
+        $test->{todo}{$this} = 1 if $istodo;
 
-            if( $not ) {
-                print "$test->{ml}NOK $this" if $test->{ml};
-                if (!$test->{todo}{$this}) {
-                    push @{$test->{failed}}, $this;
-                } else {
-                    $test->{ok}++;
-                    $tot->{ok}++;
-                }
-            }
-            else {
-                print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+        $tot->{todo}++ if $test->{todo}{$this};
+
+        if( $not ) {
+            print "$test->{ml}NOK $this" if $test->{ml};
+            if (!$test->{todo}{$this}) {
+                push @{$test->{failed}}, $this;
+            } else {
                 $test->{ok}++;
                 $tot->{ok}++;
-                $test->{skipped}++ if $isskip;
-
-                $reason = '[no reason given]'
-                    if $isskip and not defined $reason;
-                if (defined $reason and defined $test->{skip_reason}) {
-                    # print "was: '$skip_reason' new '$reason'\n";
-                    $test->{skip_reason} = 'various reasons'
-                      if $test->{skip_reason} ne $reason;
-                } elsif (defined $reason) {
-                    $test->{skip_reason} = $reason;
-                }
-
-                $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this};
             }
         }
-        # XXX ummm... dunno
-        elsif ($line =~ /^ok\s*(\d*)\s*\#([^\r]*)$/) { # XXX multiline ok?
-            $this = $1 if $1 > 0;
+        else {
             print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
             $test->{ok}++;
             $tot->{ok}++;
-        }
-        else {
-            # an ok or not ok not matching the 3 cases above...
-            # just ignore it for compatibility with TEST
-            next;
+            $test->{skipped}++ if $isskip;
+
+            $reason = '[no reason given]'
+              if $isskip and not defined $reason;
+            if (defined $reason and defined $test->{skip_reason}) {
+                # print "was: '$skip_reason' new '$reason'\n";
+                $test->{skip_reason} = 'various reasons'
+                  if $test->{skip_reason} ne $reason;
+            } elsif (defined $reason) {
+                $test->{skip_reason} = $reason;
+            }
+
+            $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this};
         }
 
         if ($this > $test->{'next'}) {
@@ -775,9 +790,12 @@ sub _parse_test_line {
         $test->{'next'} = $this + 1;
 
     }
-    elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
-        die "FAILED--Further testing stopped" .
-            ($1 ? ": $1\n" : ".\n");
+    else {
+        my $bail_reason;
+        if( $Strap->_is_bail_out($line, \$bail_reason) ) { # bail out!
+            die "FAILED--Further testing stopped" .
+              ($bail_reason ? ": $bail_reason\n" : ".\n");
+        }
     }
 }
 
@@ -828,16 +846,8 @@ sub _close_fh {
 sub _set_switches {
     my($test) = shift;
 
-    local *TEST;
-    open(TEST, $test) or print "can't open $test. $!\n";
-    my $first = <TEST>;
     my $s = $Switches;
-    $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
-      if exists $ENV{'HARNESS_PERL_SWITCHES'};
-    $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} @INC
-      if $first =~ /^#!.*\bperl.*-\w*([tT])/;
-
-    close(TEST) or print "can't close $test. $!\n";
+    $s .= $Strap->_switches($test);
 
     return $s;
 }
@@ -1088,7 +1098,7 @@ test whether new files appeared in that directory, and report them as
 
 If relative, directory name is with respect to the current directory at
 the moment runtests() was called.  Putting absolute path into 
-C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
+C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
 
 =item C<HARNESS_PERL_SWITCHES>
 
diff --git a/lib/Test/Harness/Assert.pm b/lib/Test/Harness/Assert.pm
new file mode 100644 (file)
index 0000000..0e4690c
--- /dev/null
@@ -0,0 +1,68 @@
+# $Id: Assert.pm,v 1.1.2.1 2001/08/12 03:01:27 schwern Exp $
+
+package Test::Harness::Assert;
+
+use strict;
+require Exporter;
+use vars qw($VERSION @EXPORT @ISA);
+
+$VERSION = '0.01';
+
+@ISA = qw(Exporter);
+@EXPORT = qw(assert);
+
+
+=head1 NAME
+
+Test::Harness::Assert - simple assert
+
+=head1 SYNOPSIS
+
+  ### FOR INTERNAL USE ONLY ###
+
+  use Test::Harness::Assert;
+
+  assert( EXPR, $name );
+
+=head1 DESCRIPTION
+
+A simple assert routine since we don't have Carp::Assert handy.
+
+B<For internal use by Test::Harness ONLY!>
+
+=head2 Functions
+
+=over 4
+
+=item B<assert>
+
+  assert( EXPR, $name );
+
+If the expression is false the program aborts.
+
+=cut
+
+sub assert ($;$) {
+    my($assert, $name) = @_;
+
+    unless( $assert ) {
+        require Carp;
+        my $msg = 'Assert failed';
+        $msg .= " - '$name'" if defined $name;
+        $msg .= '!';
+        Carp::croak($msg);
+    }
+
+}
+
+=head1 AUTHOR
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=head1 SEE ALSO
+
+L<Carp::Assert>
+
+=cut
+
+1;
index df0a621..fcd8bb2 100644 (file)
@@ -1,9 +1,47 @@
 Revision history for Perl extension Test::Harness
 
+2.01  Thu Dec 27 18:54:36 EST 2001
+    * Added 'passing' to the results to tell you if the test passed
+    * Added Test::Harness::Straps example (examples/mini_harness.plx)
+    * Header-at-end tests were being interpreted as failing sometimes
+    - The 'skip_all' results from analyze* was not being set
+    - analyze_fh() and analyze_file() now work more efficiently, reading
+      line-by-line instead of slurping as before.
+
+2.00  Sun Dec 23 19:13:57 EST 2001
+    - Fixed a warning on VMS.
+    - Removed a little unnecessary code from analyze_file()
+    - Made sure filehandles are getting closed
+    - analyze() now considers "not \nok" to be a failure (VMSism)
+      but Test::Harness still doesn't.
+
+2.00_05 Mon Dec 17 22:08:02 EST 2001
+    * Wasn't filtering @INC properly when a test is run with -T, caused the 
+      command line to be too long on VMS.  VMS should be 100% now.
+    - Little bug in the skip 'various reasons' logic.
+    - Minor POD nit in 5.004_04
+    - Little speling mistak
+
+2.00_04 Sun Dec 16 00:33:32 EST 2001
+    * Major Test::Harness::Straps doc bug.
+
+2.00_03 Sat Dec 15 23:52:17 EST 2001
+    * First release candidate
+    * 'summary' is now 'details'
+    * Test #1 is now element 0 on the details array.  It works out better
+      that way.
+    * analyze_file() is more portable, but no longer taint clean
+    * analyze_file() properly preserves @INC and handles -T switches
+    - minor mistake in the test header line parsing
+
 1.26  Mon Nov 12 15:44:01 EST 2001
     * An excuse to upload a new version to CPAN to get Test::Harness
       back on the index.
 
+2.00_00  Sat Sep 29 00:12:03 EDT 2001
+    * Partial gutting of the internals
+    * Added Test::Harness::Straps
+
 1.25  Tue Aug  7 08:51:09 EDT 2001
     * Fixed a bug with tests failing if they're all skipped
       reported by Stas Bekman.
@@ -13,7 +51,7 @@ Revision history for Perl extension Test::Harness
     -  minor fixes to the filename in the report
     -  '[no reason given]' skip reason
 
-1.24  2001/08/07 12:52:47   *UNRELEASED*
+1.24  Tue Aug  7 08:51:09 EDT 2001
     - Added internal information about number of todo tests
 
 1.23  Tue Jul 31 15:06:47 EDT 2001
diff --git a/lib/Test/Harness/Iterator.pm b/lib/Test/Harness/Iterator.pm
new file mode 100644 (file)
index 0000000..5e22793
--- /dev/null
@@ -0,0 +1,61 @@
+package Test::Harness::Iterator;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = 0.01;
+
+
+=head1 NAME
+
+Test::Harness::Iterator - Internal Test::Harness Iterator
+
+=head1 SYNOPSIS
+
+  use Test::Harness::Iterator;
+  use Test::Harness::Iterator;
+  my $it = Test::Harness::Iterator->new(\*TEST);
+  my $it = Test::Harness::Iterator->new(\@array);
+
+  my $line = $it->next;
+
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for arrays and filehandles.
+
+=cut
+
+sub new {
+    my($proto, $thing) = @_;
+
+    my $self = {};
+    if( ref $thing eq 'GLOB' ) {
+        bless $self, 'Test::Harness::Iterator::FH';
+        $self->{fh} = $thing;
+    }
+    elsif( ref $thing eq 'ARRAY' ) {
+        bless $self, 'Test::Harness::Iterator::ARRAY';
+        $self->{idx}   = 0;
+        $self->{array} = $thing;
+    }
+    else {
+        warn "Can't iterate with a ", ref $thing;
+    }
+
+    return $self;
+}
+
+package Test::Harness::Iterator::FH;
+sub next {
+    my $fh = $_[0]->{fh};
+    return scalar <$fh>;
+}
+
+
+package Test::Harness::Iterator::ARRAY;
+sub next {
+    my $self = shift;
+    return $self->{array}->[$self->{idx}++];
+}
diff --git a/lib/Test/Harness/Straps.pm b/lib/Test/Harness/Straps.pm
new file mode 100644 (file)
index 0000000..27f46bf
--- /dev/null
@@ -0,0 +1,644 @@
+# -*- Mode: cperl; cperl-indent-level: 4 -*-
+# $Id: Straps.pm,v 1.1.2.17 2002/01/07 22:34:33 schwern Exp $
+
+package Test::Harness::Straps;
+
+use strict;
+use vars qw($VERSION);
+use Config;
+$VERSION = '0.08';
+
+use Test::Harness::Assert;
+use Test::Harness::Iterator;
+
+# Flags used as return values from our methods.  Just for internal 
+# clarification.
+my $TRUE  = (1==1);
+my $FALSE = !$TRUE;
+my $YES   = $TRUE;
+my $NO    = $FALSE;
+
+
+=head1 NAME
+
+Test::Harness::Straps - detailed analysis of test results
+
+=head1 SYNOPSIS
+
+  use Test::Harness::Straps;
+
+  my $strap = Test::Harness::Straps->new;
+
+  # Various ways to interpret a test
+  my %results = $strap->analyze($name, \@test_output);
+  my %results = $strap->analyze_fh($name, $test_filehandle);
+  my %results = $strap->analyze_file($test_file);
+
+  # UNIMPLEMENTED
+  my %total = $strap->total_results;
+
+  # Altering the behavior of the strap  UNIMPLEMENTED
+  my $verbose_output = $strap->dump_verbose();
+  $strap->dump_verbose_fh($output_filehandle);
+
+
+=head1 DESCRIPTION
+
+B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
+in incompatible ways.  It is otherwise stable.
+
+Test::Harness is limited to printing out its results.  This makes
+analysis of the test results difficult for anything but a human.  To
+make it easier for programs to work with test results, we provide
+Test::Harness::Straps.  Instead of printing the results, straps
+provide them as raw data.  You can also configure how the tests are to
+be run.
+
+The interface is currently incomplete.  I<Please> contact the author
+if you'd like a feature added or something change or just have
+comments.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+  my $strap = Test::Harness::Straps->new;
+
+Initialize a new strap.
+
+=cut
+
+sub new {
+    my($proto) = shift;
+    my($class) = ref $proto || $proto;
+
+    my $self = bless {}, $class;
+    $self->_init;
+
+    return $self;
+}
+
+=begin _private
+
+=item B<_init>
+
+  $strap->_init;
+
+Initialize the internal state of a strap to make it ready for parsing.
+
+=cut
+
+sub _init {
+    my($self) = shift;
+
+    $self->{_is_vms} = $^O eq 'VMS';
+}
+
+=end _private
+
+=back
+
+=head2 Analysis
+
+=over 4
+
+=item B<analyze>
+
+  my %results = $strap->analyze($name, \@test_output);
+
+Analyzes the output of a single test, assigning it the given $name for
+use in the total report.  Returns the %results of the test.  See
+L<Results>.
+
+@test_output should be the raw output from the test, including newlines.
+
+=cut
+
+sub analyze {
+    my($self, $name, $test_output) = @_;
+
+    my $it = Test::Harness::Iterator->new($test_output);
+    return $self->_analyze_iterator($name, $it);
+}
+
+
+sub _analyze_iterator {
+    my($self, $name, $it) = @_;
+
+    $self->_reset_file_state;
+    $self->{file} = $name;
+    my %totals  = (
+                   max      => 0,
+                   seen     => 0,
+
+                   ok       => 0,
+                   todo     => 0,
+                   skip     => 0,
+                   bonus    => 0,
+                   
+                   details  => []
+                  );
+
+
+    while( defined(my $line = $it->next) ) {
+        $self->_analyze_line($line, \%totals);
+        last if $self->{saw_bailout};
+    }
+
+    my $passed = $totals{skip_all} || 
+                  ($totals{max} == $totals{seen} && 
+                   $totals{max} == $totals{ok});
+    $totals{passing} = $passed ? 1 : 0;
+
+    $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
+
+    $self->{totals}{$name} = \%totals;
+    return %totals;
+}
+
+
+sub _analyze_line {
+    my($self, $line, $totals) = @_;
+
+    my %result = ();
+        
+    $self->{line}++;
+
+    my $type;
+    if( $self->_is_header($line) ) {
+        $type = 'header';
+
+        $self->{saw_header}++;
+        
+        $totals->{max} += $self->{max};
+    }
+    elsif( $self->_is_test($line, \%result) ) {
+        $type = 'test';
+
+        $totals->{seen}++;
+        $result{number} = $self->{'next'} unless $result{number};
+
+        # sometimes the 'not ' and the 'ok' are on different lines,
+        # happens often on VMS if you do:
+        #   print "not " unless $test;
+        #   print "ok $num\n";
+        if( $self->{saw_lone_not} && 
+            ($self->{lone_not_line} == $self->{line} - 1) ) 
+        {   
+            $result{ok} = 0;
+        }
+
+        my $pass = $result{ok};
+        $result{type} = 'todo' if $self->{todo}{$result{number}};
+
+        if( $result{type} eq 'todo' ) {
+            $totals->{todo}++;
+            $pass = 1;
+            $totals->{bonus}++ if $result{ok}
+        }
+        elsif( $result{type} eq 'skip' ) {
+            $totals->{skip}++;
+            $pass = 1;
+        }
+
+        $totals->{ok}++ if $pass;
+
+        $totals->{details}[$result{number} - 1] = 
+                               {$self->_detailize($pass, \%result)};
+
+        # XXX handle counter mismatch
+    }
+    elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
+        $type = 'bailout';
+        $self->{saw_bailout} = 1;
+    }
+    else {
+        $type = 'other';
+    }
+
+    $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
+
+    $self->{'next'} = $result{number} + 1 if $type eq 'test';
+}
+
+=item B<analyze_fh>
+
+  my %results = $strap->analyze_fh($name, $test_filehandle);
+
+Like C<analyze>, but it reads from the given filehandle.
+
+=cut
+
+sub analyze_fh {
+    my($self, $name, $fh) = @_;
+
+    my $it = Test::Harness::Iterator->new($fh);
+    $self->_analyze_iterator($name, $it);
+}
+
+=item B<analyze_file>
+
+  my %results = $strap->analyze_file($test_file);
+
+Like C<analyze>, but it reads from the given $test_file.  It will also
+use that name for the total report.
+
+=cut
+
+sub analyze_file {
+    my($self, $file) = @_;
+
+    local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
+
+    # Is this necessary anymore?
+    my $cmd = $self->{_is_vms} ? "MCR $^X" : $^X;
+
+    my $switches = $self->_switches($file);
+
+    # *sigh* this breaks under taint, but open -| is unportable.
+    unless( open(FILE, "$cmd $switches $file|") ) {
+        print "can't run $file. $!\n";
+        return;
+    }
+
+    my %results = $self->analyze_fh($file, \*FILE);
+    close FILE;
+
+    $self->_restore_PERL5LIB();
+
+    return %results;
+}
+
+=begin _private
+
+=item B<_switches>
+
+  my $switches = $self->_switches($file);
+
+Formats and returns the switches necessary to run the test.
+
+=cut
+
+sub _switches {
+    my($self, $file) = @_;
+
+    local *TEST;
+    open(TEST, $file) or print "can't open $file. $!\n";
+    my $first = <TEST>;
+    my $s = '';
+    $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
+      if exists $ENV{'HARNESS_PERL_SWITCHES'};
+    $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} $self->_filtered_INC
+      if $first =~ /^#!.*\bperl.*-\w*([Tt]+)/;
+
+    close(TEST) or print "can't close $file. $!\n";
+
+    return $s;
+}
+
+
+=item B<_INC2PERL5LIB>
+
+  local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
+
+Takes the current value of @INC and turns it into something suitable
+for putting onto PERL5LIB.
+
+=cut
+
+sub _INC2PERL5LIB {
+    my($self) = shift;
+
+    $self->{_old5lib} = $ENV{PERL5LIB};
+
+    return join $Config{path_sep}, $self->_filtered_INC;
+}    
+
+=item B<_filtered_INC>
+
+  my @filtered_inc = $self->_filtered_INC;
+
+Shortens @INC by removing redundant and unnecessary entries.
+Necessary for OS's with limited command line lengths, like VMS.
+
+=cut
+
+sub _filtered_INC {
+    my($self, @inc) = @_;
+    @inc = @INC unless @inc;
+
+    # VMS has a 255-byte limit on the length of %ENV entries, so
+    # toss the ones that involve perl_root, the install location
+    # for VMS
+    if( $self->{_is_vms} ) {
+        @inc = grep !/perl_root/i, @inc;
+    }
+
+    return @inc;
+}
+
+
+=item B<_restore_PERL5LIB>
+
+  $self->_restore_PERL5LIB;
+
+This restores the original value of the PERL5LIB environment variable.
+Necessary on VMS, otherwise a no-op.
+
+=cut
+
+sub _restore_PERL5LIB {
+    my($self) = shift;
+
+    return unless $self->{_is_vms};
+
+    if (defined $self->{_old5lib}) {
+        $ENV{PERL5LIB} = $self->{_old5lib};
+    }
+}
+    
+
+=end _private
+
+=back
+
+
+=begin _private
+
+=head2 Parsing
+
+Methods for identifying what sort of line you're looking at.
+
+=over 4
+
+=item B<_is_comment>
+
+  my $is_comment = $strap->_is_comment($line, \$comment);
+
+Checks if the given line is a comment.  If so, it will place it into
+$comment (sans #).
+
+=cut
+
+sub _is_comment {
+    my($self, $line, $comment) = @_;
+
+    if( $line =~ /^\s*\#(.*)/ ) {
+        $$comment = $1;
+        return $YES;
+    }
+    else {
+        return $NO;
+    }
+}
+
+=item B<_is_header>
+
+  my $is_header = $strap->_is_header($line);
+
+Checks if the given line is a header (1..M) line.  If so, it places
+how many tests there will be in $strap->{max}, a list of which tests
+are todo in $strap->{todo} and if the whole test was skipped
+$strap->{skip_all} contains the reason.
+
+=cut
+
+# Regex for parsing a header.  Will be run with /x
+my $Extra_Header_Re = <<'REGEX';
+                       ^
+                        (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
+                        (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
+REGEX
+
+sub _is_header {
+    my($self, $line) = @_;
+
+    if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
+        $self->{max}  = $max;
+        assert( $self->{max} >= 0,  'Max # of tests looks right' );
+
+        if( defined $extra ) {
+            my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
+
+            $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
+
+            $self->{skip_all} = $reason if defined $skip and $skip =~ /^Skip/i;
+        }
+
+        return $YES;
+    }
+    else {
+        return $NO;
+    }
+}
+
+=item B<_is_test>
+
+  my $is_test = $strap->_is_test($line, \%test);
+
+Checks if the $line is a test report (ie. 'ok/not ok').  Reports the
+result back in %test which will contain:
+
+  ok            did it succeed?  This is the literal 'ok' or 'not ok'.
+  name          name of the test (if any)
+  number        test number (if any)
+
+  type          'todo' or 'skip' (if any)
+  reason        why is it todo or skip? (if any)
+
+If will also catch lone 'not' lines, note it saw them 
+$strap->{saw_lone_not} and the line in $strap->{lone_not_line}.
+
+=cut
+
+my $Report_Re = <<'REGEX';
+                 ^
+                  (not\ )?               # failure?
+                  ok\b
+                  (?:\s+(\d+))?         # optional test number
+                  \s*
+                  (.*)                  # and the rest
+REGEX
+
+my $Extra_Re = <<'REGEX';
+                 ^
+                  (.*?) (?:(?:[^\\]|^)# (.*))?
+                 $
+REGEX
+
+sub _is_test {
+    my($self, $line, $test) = @_;
+
+    # We pulverize the line down into pieces in three parts.
+    if( my($not, $num, $extra)    = $line  =~ /$Report_Re/ox ) {
+        my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra;
+        my($type, $reason)  = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control;
+
+        $test->{number} = $num;
+        $test->{ok}     = $not ? 0 : 1;
+        $test->{name}   = $name;
+
+        if( defined $type ) {
+            $test->{type}   = $type =~ /^TODO$/i ? 'todo' :
+                              $type =~ /^Skip/i  ? 'skip' : 0;
+        }
+        else {
+            $test->{type} = '';
+        }
+        $test->{reason} = $reason;
+
+        return $YES;
+    }
+    else{
+        # Sometimes the "not " and "ok" will be on seperate lines on VMS.
+        # We catch this and remember we saw it.
+        if( $line =~ /^not\s+$/ ) {
+            $self->{saw_lone_not} = 1;
+            $self->{lone_not_line} = $self->{line};
+        }
+
+        return $NO;
+    }
+}
+
+=item B<_is_bail_out>
+
+  my $is_bail_out = $strap->_is_bail_out($line, \$reason);
+
+Checks if the line is a "Bail out!".  Places the reason for bailing
+(if any) in $reason.
+
+=cut
+
+sub _is_bail_out {
+    my($self, $line, $reason) = @_;
+
+    if( $line =~ /^Bail out!\s*(.*)/i ) {
+        $$reason = $1 if $1;
+        return $YES;
+    }
+    else {
+        return $NO;
+    }
+}
+
+=item B<_reset_file_state>
+
+  $strap->_reset_file_state;
+
+Resets things like $strap->{max}, $strap->{skip_all}, etc... so its
+ready to parse the next file.
+
+=cut
+
+sub _reset_file_state {
+    my($self) = shift;
+
+    delete @{$self}{qw(max skip_all todo)};
+    $self->{line}       = 0;
+    $self->{saw_header} = 0;
+    $self->{saw_bailout}= 0;
+    $self->{saw_lone_not} = 0;
+    $self->{lone_not_line} = 0;
+    $self->{bailout_reason} = '';
+    $self->{'next'}       = 1;
+}
+
+=back
+
+=end _private
+
+
+=head2 Results
+
+The %results returned from analyze() contain the following information:
+
+  passing           true if the whole test is considered a pass 
+                    (or skipped), false if its a failure
+
+  max               total tests which should have been run
+  seen              total tests actually seen
+  skip_all          if the whole test was skipped, this will 
+                      contain the reason.
+
+  ok                number of tests which passed 
+                      (including todo and skips)
+
+  todo              number of todo tests seen
+  bonus             number of todo tests which 
+                      unexpectedly passed
+
+  skip              number of tests skipped
+
+So a successful test should have max == seen == ok.
+
+
+There is one final item, the details.
+
+  details           an array ref reporting the result of 
+                    each test looks like this:
+
+    $results{details}[$test_num - 1] = 
+            { ok        => is the test considered ok?
+              actual_ok => did it literally say 'ok'?
+              name      => name of the test (if any)
+              type      => 'skip' or 'todo' (if any)
+              reason    => reason for the above (if any)
+            };
+
+Element 0 of the details is test #1.  I tried it with element 1 being
+#1 and 0 being empty, this is less awkward.
+
+=begin _private
+
+=over 4
+
+=item B<_detailize>
+
+  my %details = $strap->_detailize($pass, \%test);
+
+Generates the details based on the last test line seen.  $pass is true
+if it was considered to be a passed test.  %test is the results of the
+test you're summarizing.
+
+=cut
+
+sub _detailize {
+    my($self, $pass, $test) = @_;
+
+    my %details = ( ok         => $pass,
+                    actual_ok  => $test->{ok}
+                  );
+
+    assert( !(grep !defined $details{$_}, keys %details),
+            'test contains the ok and actual_ok info' );
+
+    foreach my $piece (qw(name type reason)) {
+        $details{$piece} = $test->{$piece} if $test->{$piece};
+    }
+
+    return %details;
+}
+
+=back
+
+=end _private
+
+=head1 EXAMPLES
+
+See F<examples/mini_harness.plx> for an example of use.
+
+=head1 AUTHOR
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+
+1;
diff --git a/lib/Test/Harness/t/00compile.t b/lib/Test/Harness/t/00compile.t
new file mode 100644 (file)
index 0000000..6ea2ce6
--- /dev/null
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if($ENV{PERL_CORE}) {
+        chdir 't';
+        @INC = '../lib';
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use Test::More tests => 5;
+
+BEGIN { use_ok 'Test::Harness' }
+
+BEGIN { use_ok 'Test::Harness::Straps' }
+
+BEGIN { use_ok 'Test::Harness::Iterator' }
+
+BEGIN { use_ok 'Test::Harness::Assert' }
+
+# If the $VERSION is set improperly, this will spew big warnings.
+use_ok 'Test::Harness', 1.1601;
diff --git a/lib/Test/Harness/t/assert.t b/lib/Test/Harness/t/assert.t
new file mode 100644 (file)
index 0000000..9ff7305
--- /dev/null
@@ -0,0 +1,28 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 6;
+
+use Test::Harness::Assert;
+
+
+ok( defined &assert,                'assert() exported' );
+
+ok( !eval { assert( 0 ); 1 },       'assert( FALSE ) causes death' );
+like( $@, '/Assert failed/',        '  with the right message' );
+
+ok( eval { assert( 1 );  1 },       'assert( TRUE ) does nothing' );
+
+ok( !eval { assert( 0, 'some name' ); 1 },  'assert( FALSE, NAME )' );
+like( $@, '/some name/',                    '  has the name' );
index a10eb13..5ad05e9 100644 (file)
@@ -1,10 +1,13 @@
-print "1..1\n";
-
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
+
+print "1..1\n";
+
 unless (eval 'require Test::Harness') {
   print "not ok 1\n";
 } else {
diff --git a/lib/Test/Harness/t/callback.t b/lib/Test/Harness/t/callback.t
new file mode 100644 (file)
index 0000000..2fc943a
--- /dev/null
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+my $SAMPLE_TESTS = $ENV{PERL_CORE} ? 'lib/sample-tests' : 't/sample-tests';
+
+use Test::More;
+
+%samples = (
+            bailout     => [qw( header test test test bailout )],
+            combined    => ['header', ('test') x 10],
+            descriptive => ['header', ('test') x 5 ],
+            duplicates  => ['header', ('test') x 11 ],
+            head_end    => [qw( other test test test test 
+                                other header other other )],
+            head_fail   => [qw( other test test test test
+                                other header other other )],
+            no_nums     => ['header', ('test') x 5 ],
+            out_of_order=> [('test') x 10, 'header', ('test') x 5],
+            simple      => [qw( header test test test test test )],
+            simple_fail => [qw( header test test test test test )],
+            'skip'      => [qw( header test test test test test )],
+            skip_all    => [qw( header )],
+            skip_no_msg => [qw( header test )],
+            taint       => [qw( header test )],
+            'todo'      => [qw( header test test test test test )],
+            todo_inline => [qw( header test test test )],
+            vms_nit     => [qw( header other test test )],
+            with_comments => [qw( other header other test other test test
+                                  test other other test other )],
+           );
+
+plan tests => scalar keys %samples;
+
+use Test::Harness::Straps;
+my $strap = Test::Harness::Straps->new;
+$strap->{callback} = sub {
+    my($self, $line, $type, $totals) = @_;
+    push @out, $type;
+};
+                            
+while( my($test, $expect) = each %samples ) {
+    local @out = ();
+    $strap->analyze_file("$SAMPLE_TESTS/$test");
+
+    is_deeply(\@out, $expect,   "$test callback");
+}
diff --git a/lib/Test/Harness/t/nonumbers.t b/lib/Test/Harness/t/nonumbers.t
new file mode 100644 (file)
index 0000000..a5dc411
--- /dev/null
@@ -0,0 +1,14 @@
+if( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) {
+    print "1..0 # Skip: t/TEST needs numbers\n";
+    exit;
+}
+
+print <<END;
+1..6
+ok
+ok
+ok
+ok
+ok
+ok
+END
diff --git a/lib/Test/Harness/t/strap-analyze.t b/lib/Test/Harness/t/strap-analyze.t
new file mode 100644 (file)
index 0000000..06addd6
--- /dev/null
@@ -0,0 +1,281 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+my $SAMPLE_TESTS = $ENV{PERL_CORE} ? 'lib/sample-tests' : 't/sample-tests';
+
+use strict;
+
+use Test::More tests => 27;
+
+use_ok('Test::Harness::Straps');
+
+my $IsVMS = $^O eq 'VMS';
+
+my %samples = (
+   combined   => {
+                  passing     => 0,
+
+                  max         => 10,
+                  seen        => 10,
+
+                  'ok'        => 8,
+                  'todo'      => 2,
+                  'skip'      => 1,
+                  bonus       => 1,
+
+                  details     => [ { 'ok' => 1, actual_ok => 1 },
+                                   { 'ok' => 1, actual_ok => 1,
+                                     name => 'basset hounds got long ears',
+                                   },
+                                   { 'ok' => 0, actual_ok => 0,
+                                     name => 'all hell broke lose',
+                                   },
+                                   { 'ok' => 1, actual_ok => 1,
+                                     type => 'todo'
+                                   },
+                                   { 'ok' => 1, actual_ok => 1 },
+                                   { 'ok' => 1, actual_ok => 1 },
+                                   { 'ok' => 1, actual_ok => 1,
+                                     type   => 'skip',
+                                     reason => 'contract negociations'
+                                   },
+                                   { 'ok' => 1, actual_ok => 1 },
+                                   { 'ok' => 0, actual_ok => 0 },
+                                   { 'ok' => 1, actual_ok => 0,
+                                     type   => 'todo' 
+                                   },
+                                 ]
+                       },
+
+   descriptive      => {
+                        passing     => 1,
+
+                        max         => 5,
+                        seen        => 5,
+
+                        'ok'          => 5,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+
+                        details     => [ { 'ok' => 1, actual_ok => 1,
+                                           name => 'Interlock activated'
+                                         },
+                                         { 'ok' => 1, actual_ok => 1,
+                                           name => 'Megathrusters are go',
+                                         },
+                                         { 'ok' => 1, actual_ok => 1,
+                                           name => 'Head formed',
+                                         },
+                                         { 'ok' => 1, actual_ok => 1,
+                                           name => 'Blazing sword formed'
+                                         },
+                                         { 'ok' => 1, actual_ok => 1,
+                                           name => 'Robeast destroyed'
+                                         },
+                                       ],
+                       },
+
+   duplicates       => {
+                        passing     => 0,
+
+                        max         => 10,
+                        seen        => 11,
+
+                        'ok'          => 11,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+
+                        details     => [ ({ 'ok' => 1, actual_ok => 1 }) x 10
+                                       ],
+                       },
+
+   head_end         => {
+                        passing     => 1,
+
+                        max         => 4,
+                        seen        => 4,
+
+                        'ok'        => 4,
+                        'todo'      => 0,
+                        'skip'      => 0,
+                        bonus       => 0,
+
+                        details     => [ ({ 'ok' => 1, actual_ok => 1 }) x 4
+                                       ],
+                       },
+
+   lone_not_bug     => {
+                        passing     => 1,
+
+                        max         => 4,
+                        seen        => 4,
+
+                        'ok'        => 4,
+                        'todo'      => 0,
+                        'skip'      => 0,
+                        bonus       => 0,
+
+                        details     => [ ({ 'ok' => 1, actual_ok => 1 }) x 4
+                                       ],
+                       },
+
+   head_fail           => {
+                           passing  => 0,
+
+                           max      => 4,
+                           seen     => 4,
+
+                           'ok'     => 3,
+                           'todo'   => 0,
+                           'skip'   => 0,
+                           bonus    => 0,
+
+                           details  => [ { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok' => 0, actual_ok => 0 },
+                                         ({ 'ok'=> 1, actual_ok => 1 }) x 2
+                                       ],
+                          },
+               
+   simple           => {
+                        passing     => 1,
+
+                        max         => 5,
+                        seen        => 5,
+                        
+                        'ok'          => 5,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+                        
+                        details     => [ ({ 'ok' => 1, actual_ok => 1 }) x 5
+                                       ]
+                       },
+
+   simple_fail      => {
+                        passing     => 0,
+
+                        max         => 5,
+                        seen        => 5,
+                        
+                        'ok'          => 3,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+                        
+                        details     => [ { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok' => 0, actual_ok => 0 },
+                                         { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok' => 0, actual_ok => 0 },
+                                       ]
+                       },
+
+   'skip'             => {
+                        passing     => 1,
+
+                        max         => 5,
+                        seen        => 5,
+
+                        'ok'          => 5,
+                        'todo'        => 0,
+                        'skip'        => 1,
+                        bonus       => 0,
+                        
+                        details     => [ { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok'   => 1, actual_ok => 1,
+                                           type   => 'skip',
+                                           reason => 'rain delay',
+                                         },
+                                         ({ 'ok' => 1, actual_ok => 1 }) x 3
+                                       ]
+                       },
+
+   skip_all           => {
+                          passing   => 1,
+
+                          max       => 0,
+                          seen      => 0,
+                          skip_all  => 'rope',
+
+                          'ok'      => 0,
+                          'todo'    => 0,
+                          'skip'    => 0,
+                          bonus     => 0,
+                          
+                          details   => [],
+                         },
+
+   'todo'             => {
+                        passing     => 1,
+
+                        max         => 5,
+                        seen        => 5,
+                                    
+                        'ok'          => 5,
+                        'todo'        => 2,
+                        'skip'        => 0,
+                        bonus       => 1,
+
+                        details     => [ { 'ok' => 1, actual_ok => 1 },
+                                         { 'ok' => 1, actual_ok => 1,
+                                           type => 'todo' },
+                                         { 'ok' => 1, actual_ok => 0,
+                                           type => 'todo' },
+                                         ({ 'ok' => 1, actual_ok => 1 }) x 2
+                                       ],
+                       },
+   taint            => {
+                        passing     => 1,
+
+                        max         => 1,
+                        seen        => 1,
+
+                        'ok'          => 1,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+
+                        details     => [ { 'ok' => 1, actual_ok => 1,
+                                           name => '- -T honored'
+                                         },
+                                       ],
+                       },
+   vms_nit          => {
+                        passing     => 0,
+
+                        max         => 2,
+                        seen        => 2,
+
+                        'ok'          => 1,
+                        'todo'        => 0,
+                        'skip'        => 0,
+                        bonus       => 0,
+
+                        details     => [ { 'ok' => 0, actual_ok => 0 },
+                                         { 'ok' => 1, actual_ok => 1 },
+                                       ],
+                       },              
+);
+
+
+while( my($test, $expect) = each %samples ) {
+    my $strap = Test::Harness::Straps->new;
+    my %results = $strap->analyze_file("$SAMPLE_TESTS/$test");
+    
+    is_deeply($expect->{details}, $results{details}, "$test details" );
+
+    delete $expect->{details};
+    delete $results{details};
+    is_deeply($expect, \%results, "  the rest" );
+}
diff --git a/lib/Test/Harness/t/strap.t b/lib/Test/Harness/t/strap.t
new file mode 100644 (file)
index 0000000..26af9f3
--- /dev/null
@@ -0,0 +1,224 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 146;
+
+
+use_ok('Test::Harness::Straps');
+
+my $strap = Test::Harness::Straps->new;
+ok( defined $strap && $strap->isa("Test::Harness::Straps"),         'new()' );
+
+
+### Testing _is_comment()
+
+my $comment;
+ok( !$strap->_is_comment("foo", \$comment), '_is_comment(), not a comment'  );
+ok( !defined $comment,                      '  no comment set'              );
+
+ok( !$strap->_is_comment("f # oo", \$comment), '  not a comment with #'     );
+ok( !defined $comment,                         '  no comment set'           );
+
+my %comments = (
+                "# stuff and things # and stuff"    => 
+                                        ' stuff and things # and stuff',
+                "    # more things "                => ' more things ',
+                "#"                                 => '',
+               );
+
+while( my($line, $line_comment) = each %comments ) {
+    my $strap = Test::Harness::Straps->new;
+
+    my $name = substr($line, 0, 20);
+    ok( $strap->_is_comment($line, \$comment),        "  comment '$name'"   );
+    is( $comment, $line_comment,                      '  right comment set' );
+}
+
+
+
+### Testing _is_header()
+
+my @not_headers = (' 1..2',
+                   '1..M',
+                   '1..-1',
+                   '2..2',
+                   '1..a',
+                   '',
+                  );
+
+foreach my $unheader (@not_headers) {
+    my $strap = Test::Harness::Straps->new;
+
+    ok( !$strap->_is_header($unheader),     
+        "_is_header(), not a header '$unheader'" );
+
+    ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)),
+        "  max, todo and skip_all are not set" );
+}
+
+
+my @attribs = qw(max skip_all todo);
+my %headers = (
+   '1..2'                               => { max => 2 },
+   '1..1'                               => { max => 1 },
+   '1..0'                               => { max => 0 },
+   '1..0 # Skipped: no leverage found'  => { max      => 0,
+                                             skip_all => 'no leverage found',
+                                           },
+   '1..4 # Skipped: no leverage found'  => { max      => 4,
+                                             skip_all => 'no leverage found',
+                                           },
+   '1..0 # skip skip skip because'      => { max      => 0,
+                                             skip_all => 'skip skip because',
+                                           },
+   '1..10 todo 2 4 10'                  => { max        => 10,
+                                             'todo'       => { 2  => 1,
+                                                             4  => 1,
+                                                             10 => 1,
+                                                           },
+                                           },
+   '1..10 todo'                         => { max        => 10 },
+   '1..192 todo 4 2 13 192 # Skip skip skip because'   => 
+                                           { max     => 192,
+                                             'todo'    => { 4   => 1, 
+                                                          2   => 1, 
+                                                          13  => 1, 
+                                                          192 => 1,
+                                                        },
+                                             skip_all => 'skip skip because'
+                                           }
+);
+
+while( my($header, $expect) = each %headers ) {
+    my $strap = Test::Harness::Straps->new;
+
+    ok( $strap->_is_header($header),    "_is_header() is a header '$header'" );
+
+    is( $strap->{skip_all}, $expect->{skip_all},      '  skip_all set right' )
+      if defined $expect->{skip_all};
+
+    ok( eq_set( [map $strap->{$_},  grep defined $strap->{$_},  @attribs],
+                [map $expect->{$_}, grep defined $expect->{$_}, @attribs] ),
+        '  the right attributes are there' );
+}
+
+
+
+### Testing _is_test()
+
+my %tests = (
+             'ok'       => { 'ok' => 1 },
+             'not ok'   => { 'ok' => 0 },
+
+             'ok 1'     => { 'ok' => 1, number => 1 },
+             'not ok 1' => { 'ok' => 0, number => 1 },
+
+             'ok 2938'  => { 'ok' => 1, number => 2938 },
+
+             'ok 1066 - and all that'   => { 'ok'     => 1,
+                                             number => 1066,
+                                             name   => "- and all that" },
+             'not ok 42 - universal constant'   => 
+                                      { 'ok'     => 0,
+                                        number => 42,
+                                        name   => '- universal constant',
+                                      },
+             'not ok 23 # TODO world peace'     => { 'ok'     => 0,
+                                                     number => 23,
+                                                     type   => 'todo',
+                                                     reason => 'world peace'
+                                                   },
+             'ok 11 - have life # TODO get a life'  => 
+                                      { 'ok'     => 1,
+                                        number => 11,
+                                        name   => '- have life',
+                                        type   => 'todo',
+                                        reason => 'get a life'
+                                      },
+             'not ok # TODO'    => { 'ok'     => 0,
+                                     type   => 'todo',
+                                     reason => ''
+                                   },
+             'ok # skip'        => { 'ok'     => 1,
+                                     type   => 'skip',
+                                   },
+             'not ok 11 - this is \# all the name # skip this is not'
+                                => { 'ok'     => 0,
+                                     number => 11,
+                                     name   => '- this is \# all the name',
+                                     type   => 'skip',
+                                     reason => 'this is not'
+                                   },
+             "ok 42 - _is_header() is a header '1..192 todo 4 2 13 192 \\# Skip skip skip because"
+                                => { 'ok'   => 1,
+                                     number => 42,
+                                     name   => "- _is_header() is a header '1..192 todo 4 2 13 192 \\# Skip skip skip because",
+                                   },
+            );
+
+while( my($line, $expect) = each %tests ) {
+    my %test;
+    ok( $strap->_is_test($line, \%test),    "_is_test() spots '$line'" );
+
+    foreach my $type (qw(ok number name type reason)) {
+        cmp_ok( $test{$type}, 'eq', $expect->{$type}, "  $type" );
+    }
+}
+
+my @untests = (
+               ' ok',
+               'not',
+               'okay 23',
+              );
+foreach my $line (@untests) {
+    my $strap = Test::Harness::Straps->new;
+    my %test = ();
+    ok( !$strap->_is_test($line, \%test),    "_is_test() disregards '$line'" );
+
+    # is( keys %test, 0 ) won't work in 5.004 because it's undef.
+    ok( !keys %test,                         '  and produces no test info'   );
+}
+
+
+### Test _is_bail_out()
+
+my %bails = (
+             'Bail out!'                 =>  undef,
+             'Bail out!  Wing on fire.'  => 'Wing on fire.',
+             'BAIL OUT!'                 => undef,
+             'bail out! - Out of coffee' => '- Out of coffee',
+            );
+
+while( my($line, $expect) = each %bails ) {
+    my $strap = Test::Harness::Straps->new;
+    my $reason;
+    ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'");
+    is( $reason, $expect,                       '  with the right reason' );
+}
+
+my @unbails = (
+               '  Bail out!',
+               'BAIL OUT',
+               'frobnitz',
+               'ok 23 - BAIL OUT!',
+              );
+
+foreach my $line (@unbails) {
+    my $strap = Test::Harness::Straps->new;
+    my $reason;
+
+    ok( !$strap->_is_bail_out($line, \$reason),  
+                                       "_is_bail_out() ignores '$line'" );
+    is( $reason, undef,                         '  and gives no reason' );
+}
index 80b8d9e..be15009 100644 (file)
@@ -1,14 +1,18 @@
-#!perl
+#!/usr/bin/perl
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
 }
 
+my $SAMPLE_TESTS = $ENV{PERL_CORE} ? "lib/sample-tests" : "t/sample-tests";
+
 use strict;
 
 # For shutting up Test::Harness.
-# Has to work on 5.004, which doesn't have Tie::StdHandle.
+# Has to work on 5.004 which doesn't have Tie::StdHandle.
 package My::Dev::Null;
 
 sub WRITE  {}
@@ -283,6 +287,22 @@ BEGIN {
                                       failed => { },
                                       all_ok => 1,
                                      },
+                taint             => {
+                                      total => {
+                                                bonus      => 0,
+                                                max        => 1,
+                                                'ok'       => 1,
+                                                files      => 1,
+                                                bad        => 0,
+                                                good       => 1,
+                                                tests      => 1,
+                                                sub_skipped=> 0,
+                                                todo       => 0,
+                                                skipped    => 0,
+                                               },
+                                      failed => { },
+                                      all_ok => 1,
+                                     },
                );
 
     $Total_tests = (keys(%samples) * 4);
@@ -296,7 +316,7 @@ while (my($test, $expect) = each %samples) {
     eval {
         select NULL;    # _run_all_tests() isn't as quiet as it should be.
         ($totals, $failed) = 
-          Test::Harness::_run_all_tests("lib/sample-tests/$test");
+          Test::Harness::_run_all_tests("$SAMPLE_TESTS/$test");
     };
     select STDOUT;
 
@@ -308,7 +328,7 @@ while (my($test, $expect) = each %samples) {
                     {map { $_=>$totals->{$_} } keys %{$expect->{total}}} ),
                                                          "$test - totals" );
         ok( eqhash( $expect->{failed}, 
-                    {map { $_=>$failed->{"lib/sample-tests/$test"}{$_} }
+                    {map { $_=>$failed->{"$SAMPLE_TESTS/$test"}{$_} }
                               keys %{$expect->{failed}}} ),
                                                          "$test - failed" );
     }
diff --git a/t/lib/sample-tests/lone_not_bug b/t/lib/sample-tests/lone_not_bug
new file mode 100644 (file)
index 0000000..10eaa2a
--- /dev/null
@@ -0,0 +1,9 @@
+# There was a bug where the first test would be considered a
+# 'lone not' failure.
+print <<DUMMY;
+ok 1
+ok 2
+ok 3
+ok 4
+1..4
+DUMMY
diff --git a/t/lib/sample-tests/out_of_order b/t/lib/sample-tests/out_of_order
new file mode 100644 (file)
index 0000000..77641aa
--- /dev/null
@@ -0,0 +1,22 @@
+# From a bungled core thread test.
+#
+# The important thing here is that the last test is the right test.
+# Test::Harness would misparse this as being a valid test.
+print <<DUMMY;
+ok 2 - Test that argument passing works
+ok 3 - Test that passing arguments as references work
+ok 4 - Test a normal sub
+ok 6 - Detach test
+ok 8 - Nested thread test
+ok 9 - Nested thread test
+ok 10 - Wanted 7, got 7
+ok 11 - Wanted 7, got 7
+ok 12 - Wanted 8, got 8
+ok 13 - Wanted 8, got 8
+1..15
+ok 1
+ok 5 - Check that Config::threads is true
+ok 7 - Detach test
+ok 14 - Check so that tid for threads work for main thread
+ok 15 - Check so that tid for threads work for main thread
+DUMMY
diff --git a/t/lib/sample-tests/taint b/t/lib/sample-tests/taint
new file mode 100644 (file)
index 0000000..42968d3
--- /dev/null
@@ -0,0 +1,7 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use Test::More tests => 1;
+
+eval { kill 0, $^X };
+like( $@, '/^Insecure dependency/',   '-T honored' );
diff --git a/t/lib/sample-tests/vms_nit b/t/lib/sample-tests/vms_nit
new file mode 100644 (file)
index 0000000..1df7804
--- /dev/null
@@ -0,0 +1,6 @@
+print <<DUMMY;
+1..2
+not 
+ok 1
+ok 2
+DUMMY