Change 14182 by jhi@alpha on 2002/01/11 13:57:59
Subject: [PATCH] Test::Harness 2.01
From: Michael G Schwern <[EMAIL PROTECTED]>
Date: Thu, 10 Jan 2002 21:11:24 -0500
Message-ID: <20020111021123.GA30666@blackrider>
Affected files ...
.... //depot/perl/MANIFEST#702 edit
.... //depot/perl/lib/Test/Harness.pm#56 edit
.... //depot/perl/lib/Test/Harness/Assert.pm#1 add
.... //depot/perl/lib/Test/Harness/Changes#3 edit
.... //depot/perl/lib/Test/Harness/Iterator.pm#1 add
.... //depot/perl/lib/Test/Harness/Straps.pm#1 add
.... //depot/perl/lib/Test/Harness/t/00compile.t#1 add
.... //depot/perl/lib/Test/Harness/t/assert.t#1 add
.... //depot/perl/lib/Test/Harness/t/base.t#2 edit
.... //depot/perl/lib/Test/Harness/t/callback.t#1 add
.... //depot/perl/lib/Test/Harness/t/nonumbers.t#1 add
.... //depot/perl/lib/Test/Harness/t/strap-analyze.t#1 add
.... //depot/perl/lib/Test/Harness/t/strap.t#1 add
.... //depot/perl/lib/Test/Harness/t/test-harness.t#4 edit
.... //depot/perl/t/lib/sample-tests/lone_not_bug#1 add
.... //depot/perl/t/lib/sample-tests/out_of_order#1 add
.... //depot/perl/t/lib/sample-tests/taint#1 add
.... //depot/perl/t/lib/sample-tests/vms_nit#1 add
Differences ...
==== //depot/perl/MANIFEST#702 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Fri Jan 11 07:15:05 2002
+++ perl/MANIFEST Fri Jan 11 07:15:05 2002
@@ -1269,16 +1269,25 @@
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/buffer.t Test::Builder buffering test
lib/Test/Simple/t/Builder.t Test::Builder tests
-lib/Test/Simple/t/buffer.t Test::Builder buffering test
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/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
==== //depot/perl/lib/Test/Harness.pm#56 (text) ====
Index: perl/lib/Test/Harness.pm
--- perl/lib/Test/Harness.pm.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness.pm Fri Jan 11 07:15:05 2002
@@ -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 @@
$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,19 +133,15 @@
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>
+Currently, Test::Harness does nothing with this information.
-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>.
-
=item B<Skipping tests>
If the standard output line contains the substring C< # Skip> (with
@@ -163,6 +167,19 @@
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 @@
=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 @@
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 @@
bench => 0,
);
- # pass -I flags to children
- my $old5lib = $ENV{PERL5LIB};
+ local($ENV{'PERL5LIB'}) = $Strap->_INC2PERL5LIB;
- # 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;
-
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;
- foreach my $tfile (@tests) {
my($leader, $ml) = _mk_leader($tfile, $width);
print $leader;
@@ -444,6 +469,9 @@
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 @@
@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 @@
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 @@
my $is_header = 0;
- print $line if $Verbose;
+ if( $Strap->_is_header($line) ) {
+ $is_header = 1;
+
+ $test->{max} = $Strap->{max};
+ for ( keys %{$Strap->{todo}} ) { $test->{todo}{$_} = 1; }
+
+ $test->{skip_reason} = $Strap->{skip_all}
+ if not $test->{max} and defined $Strap->{skip_all};
- # 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->{'next'} = 1 unless $test->{'next'};
- $tot->{max} += $test->{max};
- $tot->{files}++;
- $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;
}
else {
$is_header = 0;
@@ -689,78 +724,58 @@
}
}
-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);
+
+ my($not, $tnum) = (!$result{ok}, $result{number});
- $this = $tnum if $tnum;
+ $this = $tnum if $tnum;
- my($type, $reason) = $extra =~ /^\s*#\s*([Ss]kip\S*|TODO)(\s+.+)?/
- if defined $extra;
+ my($type, $reason) = ($result{type}, $result{reason});
- my($istodo, $isskip);
- if( defined $type ) {
- $istodo = 1 if $type =~ /TODO/;
- $isskip = 1 if $type =~ /skip/i;
- }
+ my($istodo, $isskip);
+ if( defined $type ) {
+ $istodo = 1 if $type eq 'todo';
+ $isskip = 1 if $type eq 'skip';
+ }
- $test->{todo}{$this} = 1 if $istodo;
+ $test->{todo}{$this} = 1 if $istodo;
- $tot->{todo}++ if $test->{todo}{$this};
+ $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}++;
- }
- }
- else {
- print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
+ 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}++;
+ $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};
}
- else {
- # an ok or not ok not matching the 3 cases above...
- # just ignore it for compatibility with TEST
- next;
- }
if ($this > $test->{'next'}) {
print "Test output counter mismatch [test $this]\n";
@@ -775,9 +790,12 @@
$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,17 +846,9 @@
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])/;
+ $s .= $Strap->_switches($test);
- close(TEST) or print "can't close $test. $!\n";
-
return $s;
}
@@ -1088,7 +1098,7 @@
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>
==== //depot/perl/lib/Test/Harness/Changes#3 (text) ====
Index: perl/lib/Test/Harness/Changes
--- perl/lib/Test/Harness/Changes.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/Changes Fri Jan 11 07:15:05 2002
@@ -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 @@
- 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
==== //depot/perl/lib/Test/Harness/t/base.t#2 (text) ====
Index: perl/lib/Test/Harness/t/base.t
--- perl/lib/Test/Harness/t/base.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/base.t Fri Jan 11 07:15:05 2002
@@ -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 {
==== //depot/perl/lib/Test/Harness/t/test-harness.t#4 (text) ====
Index: perl/lib/Test/Harness/t/test-harness.t
--- perl/lib/Test/Harness/t/test-harness.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/test-harness.t Fri Jan 11 07:15:05 2002
@@ -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 @@
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 @@
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 @@
{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" );
}
==== //depot/perl/lib/Test/Harness/Assert.pm#1 (text) ====
Index: perl/lib/Test/Harness/Assert.pm
--- perl/lib/Test/Harness/Assert.pm.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/Assert.pm Fri Jan 11 07:15:05 2002
@@ -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>[EMAIL PROTECTED]<gt>
+
+=head1 SEE ALSO
+
+L<Carp::Assert>
+
+=cut
+
+1;
==== //depot/perl/lib/Test/Harness/Iterator.pm#1 (text) ====
Index: perl/lib/Test/Harness/Iterator.pm
--- perl/lib/Test/Harness/Iterator.pm.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/Iterator.pm Fri Jan 11 07:15:05 2002
@@ -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}++];
+}
==== //depot/perl/lib/Test/Harness/Straps.pm#1 (text) ====
Index: perl/lib/Test/Harness/Straps.pm
--- perl/lib/Test/Harness/Straps.pm.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/Straps.pm Fri Jan 11 07:15:05 2002
@@ -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>[EMAIL PROTECTED]<gt>
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+=cut
+
+
+1;
==== //depot/perl/lib/Test/Harness/t/00compile.t#1 (text) ====
Index: perl/lib/Test/Harness/t/00compile.t
--- perl/lib/Test/Harness/t/00compile.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/00compile.t Fri Jan 11 07:15:05 2002
@@ -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;
==== //depot/perl/lib/Test/Harness/t/assert.t#1 (text) ====
Index: perl/lib/Test/Harness/t/assert.t
--- perl/lib/Test/Harness/t/assert.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/assert.t Fri Jan 11 07:15:05 2002
@@ -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' );
==== //depot/perl/lib/Test/Harness/t/callback.t#1 (text) ====
Index: perl/lib/Test/Harness/t/callback.t
--- perl/lib/Test/Harness/t/callback.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/callback.t Fri Jan 11 07:15:05 2002
@@ -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");
+}
==== //depot/perl/lib/Test/Harness/t/nonumbers.t#1 (text) ====
Index: perl/lib/Test/Harness/t/nonumbers.t
--- perl/lib/Test/Harness/t/nonumbers.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/nonumbers.t Fri Jan 11 07:15:05 2002
@@ -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
==== //depot/perl/lib/Test/Harness/t/strap-analyze.t#1 (text) ====
Index: perl/lib/Test/Harness/t/strap-analyze.t
--- perl/lib/Test/Harness/t/strap-analyze.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/strap-analyze.t Fri Jan 11 07:15:05 2002
@@ -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" );
+}
==== //depot/perl/lib/Test/Harness/t/strap.t#1 (text) ====
Index: perl/lib/Test/Harness/t/strap.t
--- perl/lib/Test/Harness/t/strap.t.~1~ Fri Jan 11 07:15:05 2002
+++ perl/lib/Test/Harness/t/strap.t Fri Jan 11 07:15:05 2002
@@ -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' );
+}
==== //depot/perl/t/lib/sample-tests/lone_not_bug#1 (text) ====
Index: perl/t/lib/sample-tests/lone_not_bug
--- perl/t/lib/sample-tests/lone_not_bug.~1~ Fri Jan 11 07:15:05 2002
+++ perl/t/lib/sample-tests/lone_not_bug Fri Jan 11 07:15:05 2002
@@ -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
==== //depot/perl/t/lib/sample-tests/out_of_order#1 (text) ====
Index: perl/t/lib/sample-tests/out_of_order
--- perl/t/lib/sample-tests/out_of_order.~1~ Fri Jan 11 07:15:05 2002
+++ perl/t/lib/sample-tests/out_of_order Fri Jan 11 07:15:05 2002
@@ -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
==== //depot/perl/t/lib/sample-tests/taint#1 (text) ====
Index: perl/t/lib/sample-tests/taint
--- perl/t/lib/sample-tests/taint.~1~ Fri Jan 11 07:15:05 2002
+++ perl/t/lib/sample-tests/taint Fri Jan 11 07:15:05 2002
@@ -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' );
==== //depot/perl/t/lib/sample-tests/vms_nit#1 (text) ====
Index: perl/t/lib/sample-tests/vms_nit
--- perl/t/lib/sample-tests/vms_nit.~1~ Fri Jan 11 07:15:05 2002
+++ perl/t/lib/sample-tests/vms_nit Fri Jan 11 07:15:05 2002
@@ -0,0 +1,6 @@
+print <<DUMMY;
+1..2
+not
+ok 1
+ok 2
+DUMMY
End of Patch.
