[ANNOUNCE] Test::Simple 0.47

Message-ID: <20020826111303.GJ758@ool-18b93024.dyn.optonline.net>

p4raw-id: //depot/perl@17783

13 files changed, 402 insertions, 38 deletions

diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm
index 06543e696e..6f3edd8cce 100644
--- a/lib/Test/Builder.pm
+++ b/lib/Test/Builder.pm
@@ -8,18 +8,11 @@ $^C ||= 0;
 
 use strict;
 use vars qw($VERSION $CLASS);
-$VERSION = '0.15';
+$VERSION = '0.17';
 $CLASS = __PACKAGE__;
 
 my $IsVMS = $^O eq 'VMS';
 
-use vars qw($Level);
-my @Test_Results = ();
-my @Test_Details = ();
-my($Test_Died) = 0;
-my($Have_Plan) = 0;
-my $Curr_Test = 0;
-
 # Make Test::Builder thread-safe for ithreads.
 BEGIN {
     use Config;
@@ -27,15 +20,21 @@ BEGIN {
         require threads;
         require threads::shared;
         threads::shared->import;
-        share(\$Curr_Test);
-        share(\@Test_Details);
-        share(\@Test_Results);
     }
     else {
-        *lock = sub { 0 };
+        *share = sub { 0 };
+        *lock  = sub { 0 };
     }
 }
 
+use vars qw($Level);
+my($Test_Died) = 0;
+my($Have_Plan) = 0;
+my $Original_Pid = $$;
+my $Curr_Test = 0;      share($Curr_Test);
+my @Test_Results = ();  share(@Test_Results);
+my @Test_Details = ();  share(@Test_Details);
+
 
 =head1 NAME
 
@@ -217,6 +216,21 @@ sub no_plan {
     $Have_Plan  = 1;
 }
 
+=item B<has_plan>
+
+  $plan = $Test->has_plan
+  
+Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
+
+=cut
+
+sub has_plan {
+	return($Expected_Tests) if $Expected_Tests;
+	return('no_plan') if $No_Plan;
+	return(undef);
+};
+
+
 =item B<skip_all>
 
   $Test->skip_all;
@@ -263,6 +277,10 @@ like Test::Simple's ok().
 sub ok {
     my($self, $test, $name) = @_;
 
+    # $test might contain an object which we don't want to accidentally
+    # store, so we turn it into a boolean.
+    $test = $test ? 1 : 0;
+
     unless( $Have_Plan ) {
         require Carp;
         Carp::croak("You tried to run a test without a plan!  Gotta have a plan.");
@@ -281,12 +299,15 @@ ERR
     my $todo = $self->todo($pack);
 
     my $out;
+    my $result = {};
+    share($result);
+
     unless( $test ) {
         $out .= "not ";
-        $Test_Results[$Curr_Test-1] = $todo ? 1 : 0;
+        @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
     }
     else {
-        $Test_Results[$Curr_Test-1] = 1;
+        @$result{ 'ok', 'actual_ok' } = ( 1, $test );
     }
 
     $out .= "ok";
@@ -295,13 +316,24 @@ ERR
     if( defined $name ) {
         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
         $out   .= " - $name";
+        $result->{name} = $name;
+    }
+    else {
+        $result->{name} = '';
     }
 
     if( $todo ) {
         my $what_todo = $todo;
         $out   .= " # TODO $what_todo";
+        $result->{reason} = $what_todo;
+        $result->{type}   = 'todo';
+    }
+    else {
+        $result->{reason} = '';
+        $result->{type}   = '';
     }
 
+    $Test_Results[$Curr_Test-1] = $result;
     $out .= "\n";
 
     $self->_print($out);
@@ -630,7 +662,16 @@ sub skip {
     lock($Curr_Test);
     $Curr_Test++;
 
-    $Test_Results[$Curr_Test-1] = 1;
+    my %result;
+    share(%result);
+    %result = (
+        'ok'      => 1,
+        actual_ok => 1,
+        name      => '',
+        type      => 'skip',
+        reason    => $why,
+    );
+    $Test_Results[$Curr_Test-1] = \%result;
 
     my $out = "ok";
     $out   .= " $Curr_Test" if $self->use_numbers;
@@ -666,7 +707,17 @@ sub todo_skip {
     lock($Curr_Test);
     $Curr_Test++;
 
-    $Test_Results[$Curr_Test-1] = 1;
+    my %result;
+    share(%result);
+    %result = (
+        'ok'      => 1,
+        actual_ok => 0,
+        name      => '',
+        type      => 'todo_skip',
+        reason    => $why,
+    );
+
+    $Test_Results[$Curr_Test-1] = \%result;
 
     my $out = "not ok";
     $out   .= " $Curr_Test" if $self->use_numbers;
@@ -1024,9 +1075,17 @@ sub current_test {
 
         $Curr_Test = $num;
         if( $num > @Test_Results ) {
-            my $start = @Test_Results ? $#Test_Results : 0;
+            my $start = @Test_Results ? $#Test_Results + 1 : 0;
             for ($start..$num-1) {
-                $Test_Results[$_] = 1;
+                my %result;
+                share(%result);
+                %result = ( ok        => 1, 
+                            actual_ok => undef, 
+                            reason    => 'incrementing test number', 
+                            type      => 'unknown', 
+                            name      => undef 
+                          );
+                $Test_Results[$_] = \%result;
             }
         }
     }
@@ -1048,23 +1107,62 @@ Of course, test #1 is $tests[0], etc...
 sub summary {
     my($self) = shift;
 
-    return @Test_Results;
+    return map { $_->{'ok'} } @Test_Results;
 }
 
-=item B<details>  I<UNIMPLEMENTED>
+=item B<details>
 
     my @tests = $Test->details;
 
 Like summary(), but with a lot more detail.
 
     $tests[$test_num - 1] = 
-            { ok         => is the test considered ok?
+            { 'ok'       => is the test considered a pass?
               actual_ok  => did it literally say 'ok'?
               name       => name of the test (if any)
-              type       => 'skip' or 'todo' (if any)
+              type       => type of test (if any, see below).
               reason     => reason for the above (if any)
             };
 
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
+tests.  
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test.  Normal tests have a type
+of ''.  Type can be one of the following:
+
+    skip        see skip()
+    todo        see todo()
+    todo_skip   see todo_skip()
+    unknown     see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when current_test() is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+it's type is 'unkown'.  These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left undef.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+    $tests[22] =    # 23 - 1, since arrays start from 0.
+      { ok        => 1,   # logically, the test passed since it's todo
+        actual_ok => 0,   # in absolute terms, it failed
+        name      => 'hole count',
+        type      => 'todo',
+        reason    => 'insufficient donuts'
+      };
+
+=cut
+
+sub details {
+    return @Test_Results;
+}
+
 =item B<todo>
 
     my $todo_reason = $Test->todo;
@@ -1201,9 +1299,13 @@ sub _ending {
 
     _sanity_check();
 
+    # Don't bother with an ending if this is a forked copy.  Only the parent
+    # should do the ending.
+    do{ _my_exit($?) && return } if $Original_Pid != $$;
+
     # Bailout if plan() was never called.  This is so
     # "require Test::Simple" doesn't puke.
-    do{ _my_exit(0) && return } if !$Have_Plan;
+    do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
 
     # Figure out if we passed or failed and print helpful messages.
     if( @Test_Results ) {
@@ -1214,11 +1316,16 @@ sub _ending {
         }
 
         # 5.8.0 threads bug.  Shared arrays will not be auto-extended 
-        # by a slice.
-        $Test_Results[$Expected_Tests-1] = undef
-          unless defined $Test_Results[$Expected_Tests-1];
+        # by a slice.  Worse, we have to fill in every entry else
+        # we'll get an "Invalid value for shared scalar" error
+        for my $idx ($#Test_Results..$Expected_Tests-1) {
+            my %empty_result = ();
+            share(%empty_result);
+            $Test_Results[$idx] = \%empty_result
+              unless defined $Test_Results[$idx];
+        }
 
-        my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
+        my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
         $num_failed += abs($Expected_Tests - @Test_Results);
 
         if( $Curr_Test < $Expected_Tests ) {
@@ -1251,6 +1358,11 @@ FAIL
     elsif ( $Skip_All ) {
         _my_exit( 0 ) && return;
     }
+    elsif ( $Test_Died ) {
+        $self->diag(<<'FAIL');
+Looks like your test died before it could output anything.
+FAIL
+    }
     else {
         $self->diag("No tests run!\n");
         _my_exit( 255 ) && return;
@@ -1283,7 +1395,7 @@ E<lt>schwern@pobox.comE<gt>
 
 =head1 COPYRIGHT
 
-Copyright 2001 by chromatic E<lt>chromatic@wgz.orgE<gt>,
+Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>,
                   Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 
 This program is free software; you can redistribute it and/or 
diff --git a/lib/Test/More.pm b/lib/Test/More.pm
index 9be5ea8b92..d82f81d0fe 100644
--- a/lib/Test/More.pm
+++ b/lib/Test/More.pm
@@ -18,7 +18,7 @@ sub _carp {
 
 require Exporter;
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.45';
+$VERSION = '0.47';
 @ISA    = qw(Exporter);
 @EXPORT = qw(ok use_ok require_ok
              is isnt like unlike is_deeply
@@ -304,7 +304,7 @@ test:
 Will produce something like this:
 
     not ok 17 - Is foo the same as bar?
-    #     Failed test 1 (foo.t at line 139)
+    #     Failed test (foo.t at line 139)
     #          got: 'waffle'
     #     expected: 'yarblokos'
 
@@ -773,10 +773,10 @@ the easiest way to illustrate:
         skip "HTML::Lint not installed", 2 if $@;
 
         my $lint = new HTML::Lint;
-        ok( $lint, "Created object" );
+        isa_ok( $lint, "HTML::Lint" );
 
         $lint->parse( $html );
-        is( scalar $lint->errors, 0, "No errors found in HTML" );
+        is( $lint->errors, 0, "No errors found in HTML" );
     }
 
 If the user does not have HTML::Lint installed, the whole block of
@@ -1109,6 +1109,9 @@ Similar to eq_array(), except the order of the elements is B<not>
 important.  This is a deep check, but the irrelevancy of order only
 applies to the top level.
 
+B<NOTE> By historical accident, this is not a true set comparision.
+While the order of elements does not matter, duplicate elements do.
+
 =cut
 
 # We must make sure that references are treated neutrally.  It really
diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm
index 464fffd782..563528bc15 100644
--- a/lib/Test/Simple.pm
+++ b/lib/Test/Simple.pm
@@ -4,7 +4,7 @@ use 5.004;
 
 use strict 'vars';
 use vars qw($VERSION);
-$VERSION = '0.45';
+$VERSION = '0.47';
 
 
 use Test::Builder;
diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes
index 0591a7e435..272b07e649 100644
--- a/lib/Test/Simple/Changes
+++ b/lib/Test/Simple/Changes
@@ -1,5 +1,25 @@
 Revision history for Perl extension Test::Simple
 
+0.47  Mon Aug 26 03:54:22 PDT 2002 
+    * Tatsuhiko Miyagawa noticed Test::Builder was accidentally storing 
+      objects passed into test functions causing problems with tests 
+      relying on object destruction.
+    - Added example of calculating the number of tests to Test::Tutorial
+    - Peter Scott made the ending logic not fire on child processes when
+      forking.
+    * Test::Builder is once again ithread safe.
+
+0.46  Sat Jul 20 19:57:40 EDT 2002
+    - Noted eq_set() isn't really a set comparision.
+    - Test fix, exit codes are broken on MacPerl (bleadperl@16868)
+    - Make Test::Simple install itself into the core for >= 5.8
+    - Small fixes to Test::Tutorial and skip examples
+    * Added TB->has_plan() from Adrian Howard
+    - Clarified the meaning of 'actual_ok' from TB->details
+    * Added TB->details() from chromatic
+    - Neil Watkiss fixed a pre-5.8 test glitch with threads.t
+    * If the test died before a plan, it would exit with 0 [ID 20020716.013]
+
 0.45  Wed Jun 19 18:41:12 EDT 2002
     - Andy Lester made the SKIP & TODO docs a bit clearer.
     - Explicitly disallowing double plans. (RT #553)
diff --git a/lib/Test/Simple/t/details.t b/lib/Test/Simple/t/details.t
new file mode 100644
index 0000000000..65dcf8d154
--- /dev/null
+++ b/lib/Test/Simple/t/details.t
@@ -0,0 +1,93 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use Test::More;
+use Test::Builder;
+my $Test = Test::Builder->new;
+
+$Test->plan( tests => 8 );
+$Test->level(0);
+
+my @Expected_Details;
+
+$Test->is_num( scalar $Test->summary(), 0,   'no tests yet, no summary' );
+push @Expected_Details, { 'ok'      => 1,
+                          actual_ok => 1,
+                          name      => 'no tests yet, no summary',
+                          type      => '',
+                          reason    => ''
+                        };
+
+# Inline TODO tests will confuse pre 1.20 Test::Harness, so we
+# should just avoid the problem and not print it out.
+my $out_fh = $Test->output;
+my $start_test = $Test->current_test + 1;
+require TieOut;
+tie *FH, 'TieOut';
+$Test->output(\*FH);
+
+SKIP: {
+    $Test->skip( 'just testing skip' );
+}
+push @Expected_Details, { 'ok'      => 1,
+                          actual_ok => 1,
+                          name      => '',
+                          type      => 'skip',
+                          reason    => 'just testing skip',
+                        };
+
+TODO: {
+    local $TODO = 'i need a todo';
+    $Test->ok( 0, 'a test to todo!' );
+
+    push @Expected_Details, { 'ok'       => 1,
+                              actual_ok  => 0,
+                              name       => 'a test to todo!',
+                              type       => 'todo',
+                              reason     => 'i need a todo',
+                            };
+
+    $Test->todo_skip( 'i need both' );
+}
+push @Expected_Details, { 'ok'      => 1,
+                          actual_ok => 0,
+                          name      => '',
+                          type      => 'todo_skip',
+                          reason    => 'i need both'
+                        };
+
+for ($start_test..$Test->current_test) { print "ok $_\n" }
+$Test->output($out_fh);
+
+$Test->is_num( scalar $Test->summary(), 4,   'summary' );
+push @Expected_Details, { 'ok'      => 1,
+                          actual_ok => 1,
+                          name      => 'summary',
+                          type      => '',
+                          reason    => '',
+                        };
+
+$Test->current_test(6);
+print "ok 6 - current_test incremented\n";
+push @Expected_Details, { 'ok'      => 1,
+                          actual_ok => undef,
+                          name      => undef,
+                          type      => 'unknown',
+                          reason    => 'incrementing test number',
+                        };
+
+my @details = $Test->details();
+$Test->is_num( scalar @details, 6,
+    'details() should return a list of all test details');
+
+$Test->level(1);
+is_deeply( \@details, \@Expected_Details );
diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t
index 1367bbfdcd..0ba76ba5de 100644
--- a/lib/Test/Simple/t/exit.t
+++ b/lib/Test/Simple/t/exit.t
@@ -1,3 +1,5 @@
+#!/usr/bin/perl -w
+
 # Can't use Test.pm, that's a 5.005 thing.
 package My::Test;
 
@@ -53,6 +55,7 @@ my %Tests = (
              'too_few.plx'              => [4,      4],
              'death.plx'                => [255,    4],
              'last_minute_death.plx'    => [255,    4],
+             'pre_plan_death.plx'       => ['not zero',    'not zero'],
              'death_in_eval.plx'        => [0,      0],
              'require.plx'              => [0,      0],
             );
@@ -87,6 +90,14 @@ while( my($test_name, $exit_codes) = each %Tests ) {
     my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
     my $actual_exit = exitstatus($wait_stat);
 
-    My::Test::ok( $actual_exit == $exit_code, 
-                  "$test_name exited with $actual_exit (expected $exit_code)");
+    if( $exit_code eq 'not zero' ) {
+        My::Test::ok( $actual_exit != 0,
+                      "$test_name exited with $actual_exit ".
+                      "(expected $exit_code)");
+    }
+    else {
+        My::Test::ok( $actual_exit == $exit_code, 
+                      "$test_name exited with $actual_exit ".
+                      "(expected $exit_code)");
+    }
 }
diff --git a/lib/Test/Simple/t/fork.t b/lib/Test/Simple/t/fork.t
new file mode 100644
index 0000000000..ca103b1ca6
--- /dev/null
+++ b/lib/Test/Simple/t/fork.t
@@ -0,0 +1,25 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+use Config;
+
+if( !$Config{d_fork} ) {
+    plan skip_all => "This system cannot fork";
+}
+else {
+    plan tests => 1;
+}
+
+if( fork ) { # parent
+    pass("Only the parent should process the ending, not the child");
+}
+else {
+    exit;   # child
+}
diff --git a/lib/Test/Simple/t/has_plan.t b/lib/Test/Simple/t/has_plan.t
new file mode 100644
index 0000000000..d3f888f2a5
--- /dev/null
+++ b/lib/Test/Simple/t/has_plan.t
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib');
+    }
+}
+
+use strict;
+use Test::Builder;
+
+my $unplanned;
+
+BEGIN {
+	$unplanned = 'oops';
+	$unplanned = Test::Builder->has_plan;
+};
+
+use Test::More tests => 2;
+
+is($unplanned, undef, 'no plan yet defined');
+is(Test::Builder->has_plan, 2, 'has fixed plan');
diff --git a/lib/Test/Simple/t/has_plan2.t b/lib/Test/Simple/t/has_plan2.t
new file mode 100644
index 0000000000..2b9ac499da
--- /dev/null
+++ b/lib/Test/Simple/t/has_plan2.t
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+
+BEGIN {
+    if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
+        plan skip_all => "Won't work with t/TEST";
+    }
+}
+
+BEGIN {
+    require Test::Harness;
+}
+
+if( $Test::Harness::VERSION < 1.20 ) {
+    plan skip_all => 'Need Test::Harness 1.20 or up';
+}
+
+use strict;
+use Test::Builder;
+
+plan 'no_plan';
+is(Test::Builder->has_plan, 'no_plan', 'has no_plan');
diff --git a/lib/Test/Simple/t/ok_obj.t b/lib/Test/Simple/t/ok_obj.t
new file mode 100644
index 0000000000..8678dbff8d
--- /dev/null
+++ b/lib/Test/Simple/t/ok_obj.t
@@ -0,0 +1,29 @@
+#!/usr/bin/perl -w
+
+# Testing to make sure Test::Builder doesn't accidentally store objects
+# passed in as test arguments.
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 4;
+
+package Foo;
+my $destroyed = 0;
+sub new { bless {}, shift }
+
+sub DESTROY {
+    $destroyed++;
+}
+
+package main;
+
+for (1..3) {
+    ok(my $foo = Foo->new, 'created Foo object');
+}
+is $destroyed, 3, "DESTROY called 3 times";
+
diff --git a/lib/Test/Simple/t/plan.t b/lib/Test/Simple/t/plan.t
index c2bf27a37e..fa46744b06 100644
--- a/lib/Test/Simple/t/plan.t
+++ b/lib/Test/Simple/t/plan.t
@@ -1,3 +1,5 @@
+#!/usr/bin/perl -w
+
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
diff --git a/lib/Test/Simple/t/threads.t b/lib/Test/Simple/t/threads.t
index 4212cccb77..5670bda25b 100644
--- a/lib/Test/Simple/t/threads.t
+++ b/lib/Test/Simple/t/threads.t
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 use Config;
-unless ($Config{'useithreads'}) {
+unless ($Config{'useithreads'} and eval { require threads; 1 }) {
     print "1..0 # Skip: no threads\n";
     exit 0;
 }
diff --git a/lib/Test/Tutorial.pod b/lib/Test/Tutorial.pod
index e07ca325f3..a57d04769e 100644
--- a/lib/Test/Tutorial.pod
+++ b/lib/Test/Tutorial.pod
@@ -298,8 +298,23 @@ C<%ICal_Dates>.  Now that it's less work to test with more dates, you'll
 be inclined to just throw more in as you think of them.
 Only problem is, every time we add to that we have to keep adjusting
 the C<use Test::More tests =E<gt> ##> line.  That can rapidly get
-annoying.  Instead we use C<no_plan>.  This means we're just running
-some tests, don't know how many. [6]
+annoying.  There's two ways to make this work better.
+
+First, we can calculate the plan dynamically using the C<plan()>
+function.
+
+    use Test::More;
+    use Date::ICal;
+
+    my %ICal_Dates = (
+        ...same as before...
+    );
+
+    # For each key in the hash we're running 8 tests.
+    plan tests => keys %ICal_Dates * 8;
+
+Or to be even more flexible, we use C<no_plan>.  This means we're just
+running some tests, don't know how many. [6]
 
     use Test::More 'no_plan';   # instead of tests => 32
 
@@ -436,6 +451,7 @@ Thumbing through the Date::ICal man page, I came across this:
 the date in the Date::ICal test suite.  So I'll write one.
 
     use Test::More tests => 1;
+    use Date::ICal;
 
     my $ical = Date::ICal->new;
     $ical->ical('20201231Z');