This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Test-Simple-0.82.
authorSteve Peters <steve@fisharerojo.org>
Wed, 15 Oct 2008 13:11:04 +0000 (13:11 +0000)
committerSteve Peters <steve@fisharerojo.org>
Wed, 15 Oct 2008 13:11:04 +0000 (13:11 +0000)
p4raw-id: //depot/perl@34483

87 files changed:
lib/Test/Builder.pm
lib/Test/Builder/Module.pm
lib/Test/Builder/Tester.pm
lib/Test/Builder/Tester/Color.pm
lib/Test/More.pm
lib/Test/Simple.pm
lib/Test/Simple/t/00test_harness_check.t
lib/Test/Simple/t/BEGIN_require_ok.t
lib/Test/Simple/t/BEGIN_use_ok.t
lib/Test/Simple/t/Builder/Builder.t [moved from lib/Test/Simple/t/Builder.t with 86% similarity]
lib/Test/Simple/t/Builder/carp.t [moved from lib/Test/Simple/t/carp.t with 85% similarity]
lib/Test/Simple/t/Builder/create.t [moved from lib/Test/Simple/t/create.t with 89% similarity]
lib/Test/Simple/t/Builder/curr_test.t [moved from lib/Test/Simple/t/curr_test.t with 71% similarity]
lib/Test/Simple/t/Builder/details.t [moved from lib/Test/Simple/t/details.t with 96% similarity]
lib/Test/Simple/t/Builder/has_plan.t [moved from lib/Test/Simple/t/has_plan.t with 78% similarity]
lib/Test/Simple/t/Builder/has_plan2.t [moved from lib/Test/Simple/t/has_plan2.t with 77% similarity]
lib/Test/Simple/t/Builder/is_fh.t [moved from lib/Test/Simple/t/is_fh.t with 90% similarity]
lib/Test/Simple/t/Builder/maybe_regex.t [moved from lib/Test/Simple/t/maybe_regex.t with 92% similarity]
lib/Test/Simple/t/Builder/no_diag.t [moved from lib/Test/Simple/t/no_diag.t with 59% similarity]
lib/Test/Simple/t/Builder/no_ending.t [moved from lib/Test/Simple/t/no_ending.t with 76% similarity]
lib/Test/Simple/t/Builder/no_header.t [moved from lib/Test/Simple/t/no_header.t with 74% similarity]
lib/Test/Simple/t/Builder/ok_obj.t [moved from lib/Test/Simple/t/ok_obj.t with 82% similarity]
lib/Test/Simple/t/Builder/output.t [moved from lib/Test/Simple/t/output.t with 94% similarity]
lib/Test/Simple/t/Builder/reset.t [moved from lib/Test/Simple/t/reset.t with 95% similarity]
lib/Test/Simple/t/Builder/try.t [moved from lib/Test/Simple/t/try.t with 82% similarity]
lib/Test/Simple/t/More.t
lib/Test/Simple/t/Tester/tbt_01basic.t [moved from lib/Test/Simple/t/tbt_01basic.t with 84% similarity]
lib/Test/Simple/t/Tester/tbt_02fhrestore.t [moved from lib/Test/Simple/t/tbt_02fhrestore.t with 91% similarity]
lib/Test/Simple/t/Tester/tbt_03die.t [moved from lib/Test/Simple/t/tbt_03die.t with 68% similarity]
lib/Test/Simple/t/Tester/tbt_04line_num.t [new file with mode: 0644]
lib/Test/Simple/t/Tester/tbt_05faildiag.t [moved from lib/Test/Simple/t/tbt_05faildiag.t with 88% similarity]
lib/Test/Simple/t/Tester/tbt_06errormess.t [moved from lib/Test/Simple/t/tbt_06errormess.t with 96% similarity]
lib/Test/Simple/t/Tester/tbt_07args.t [moved from lib/Test/Simple/t/tbt_07args.t with 98% similarity]
lib/Test/Simple/t/bad_plan.t
lib/Test/Simple/t/bail_out.t
lib/Test/Simple/t/buffer.t
lib/Test/Simple/t/circular_data.t
lib/Test/Simple/t/cmp_ok.t
lib/Test/Simple/t/diag.t
lib/Test/Simple/t/died.t [new file with mode: 0644]
lib/Test/Simple/t/dont_overwrite_die_handler.t
lib/Test/Simple/t/eq_set.t
lib/Test/Simple/t/exit.t
lib/Test/Simple/t/explain.t [new file with mode: 0644]
lib/Test/Simple/t/extra.t
lib/Test/Simple/t/extra_one.t
lib/Test/Simple/t/fail-like.t
lib/Test/Simple/t/fail-more.t
lib/Test/Simple/t/fail.t
lib/Test/Simple/t/fail_one.t
lib/Test/Simple/t/filehandles.t
lib/Test/Simple/t/fork.t
lib/Test/Simple/t/harness_active.t
lib/Test/Simple/t/import.t
lib/Test/Simple/t/is_deeply_dne_bug.t
lib/Test/Simple/t/is_deeply_fail.t
lib/Test/Simple/t/is_deeply_with_threads.t
lib/Test/Simple/t/lib/Dummy.pm
lib/Test/Simple/t/lib/MyOverload.pm
lib/Test/Simple/t/lib/NoExporter.pm
lib/Test/Simple/t/missing.t
lib/Test/Simple/t/new_ok.t [new file with mode: 0644]
lib/Test/Simple/t/no_plan.t
lib/Test/Simple/t/no_tests.t [new file with mode: 0644]
lib/Test/Simple/t/note.t [new file with mode: 0644]
lib/Test/Simple/t/overload.t
lib/Test/Simple/t/overload_threads.t
lib/Test/Simple/t/plan.t
lib/Test/Simple/t/plan_bad.t
lib/Test/Simple/t/plan_is_noplan.t
lib/Test/Simple/t/plan_no_plan.t
lib/Test/Simple/t/plan_shouldnt_import.t
lib/Test/Simple/t/plan_skip_all.t
lib/Test/Simple/t/require_ok.t
lib/Test/Simple/t/simple.t
lib/Test/Simple/t/skip.t
lib/Test/Simple/t/skipall.t
lib/Test/Simple/t/tbm_doesnt_set_exported_to.t
lib/Test/Simple/t/tbt_04line_num.t [deleted file]
lib/Test/Simple/t/thread_taint.t
lib/Test/Simple/t/threads.t
lib/Test/Simple/t/todo.t
lib/Test/Simple/t/undef.t
lib/Test/Simple/t/use_ok.t
lib/Test/Simple/t/useing.t
lib/Test/Simple/t/utf8.t
lib/Test/Tutorial.pod

index 1a2cdb0..38a15d4 100644 (file)
@@ -1,20 +1,22 @@
 package Test::Builder;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder.pm 67223 2008-10-15T03:08:18.888155Z schwern  $
 
 use 5.006;
 use strict;
+use warnings;
 
-our $VERSION = '0.80';
-$VERSION = eval { $VERSION }; # make the alpha version come out as a number
+our $VERSION = '0.82';
+$VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
 # Make Test::Builder thread-safe for ithreads.
 BEGIN {
     use Config;
     # Load threads::shared when threads are turned on.
     # 5.8.0's threads are so busted we no longer support them.
-    if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
+    if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
         require threads::shared;
 
-        # Hack around YET ANOTHER threads::shared bug.  It would 
+        # Hack around YET ANOTHER threads::shared bug.  It would
         # occassionally forget the contents of the variable when sharing it.
         # So we first copy the data, then share, then put our copy back.
         *share = sub (\[$@%]) {
@@ -22,31 +24,31 @@ BEGIN {
             my $data;
 
             if( $type eq 'HASH' ) {
-                %$data = %{$_[0]};
+                %$data = %{ $_[0] };
             }
             elsif( $type eq 'ARRAY' ) {
-                @$data = @{$_[0]};
+                @$data = @{ $_[0] };
             }
             elsif( $type eq 'SCALAR' ) {
-                $$data = ${$_[0]};
+                $$data = ${ $_[0] };
             }
             else {
-                die("Unknown type: ".$type);
+                die( "Unknown type: " . $type );
             }
 
-            $_[0] = &threads::shared::share($_[0]);
+            $_[0] = &threads::shared::share( $_[0] );
 
             if( $type eq 'HASH' ) {
-                %{$_[0]} = %$data;
+                %{ $_[0] } = %$data;
             }
             elsif( $type eq 'ARRAY' ) {
-                @{$_[0]} = @$data;
+                @{ $_[0] } = @$data;
             }
             elsif( $type eq 'SCALAR' ) {
-                ${$_[0]} = $$data;
+                ${ $_[0] } = $$data;
             }
             else {
-                die("Unknown type: ".$type);
+                die( "Unknown type: " . $type );
             }
 
             return $_[0];
@@ -60,7 +62,6 @@ BEGIN {
     }
 }
 
-
 =head1 NAME
 
 Test::Builder - Backend for building test libraries
@@ -110,13 +111,13 @@ singleton, use C<create>.
 =cut
 
 my $Test = Test::Builder->new;
+
 sub new {
     my($class) = shift;
     $Test ||= $class->create;
     return $Test;
 }
 
-
 =item B<create>
 
   my $Test = Test::Builder->create;
@@ -150,10 +151,10 @@ test might be run multiple times in the same process.
 
 =cut
 
-use vars qw($Level);
+our $Level;
 
-sub reset {
-    my ($self) = @_;
+sub reset {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+    my($self) = @_;
 
     # We leave this a global because it has to be localized and localizing
     # hash keys is just asking for pain.  Also, it was documented.
@@ -163,23 +164,25 @@ sub reset {
     $self->{No_Plan}      = 0;
     $self->{Original_Pid} = $$;
 
-    share($self->{Curr_Test});
-    $self->{Curr_Test}    = 0;
-    $self->{Test_Results} = &share([]);
+    share( $self->{Curr_Test} );
+    $self->{Curr_Test} = 0;
+    $self->{Test_Results} = &share( [] );
 
     $self->{Exported_To}    = undef;
     $self->{Expected_Tests} = 0;
 
-    $self->{Skip_All}   = 0;
+    $self->{Skip_All} = 0;
 
-    $self->{Use_Nums}   = 1;
+    $self->{Use_Nums} = 1;
 
-    $self->{No_Header}  = 0;
-    $self->{No_Ending}  = 0;
+    $self->{No_Header} = 0;
+    $self->{No_Ending} = 0;
 
-    $self->{TODO}       = undef;
+    $self->{Todo}       = undef;
+    $self->{Todo_Stack} = [];
+    $self->{Start_Todo} = 0;
 
-    $self->_dup_stdhandles unless $^C;
+    $self->_dup_stdhandles;
 
     return;
 }
@@ -207,36 +210,36 @@ If you call plan(), don't call any of the other methods below.
 =cut
 
 sub plan {
-    my($self, $cmd, $arg) = @_;
+    my( $self, $cmd, $arg ) = @_;
 
     return unless $cmd;
 
     local $Level = $Level + 1;
 
-    if( $self->{Have_Plan} ) {
-        $self->croak("You tried to plan twice");
-    }
+    $self->croak("You tried to plan twice")
+      if $self->{Have_Plan};
 
     if( $cmd eq 'no_plan' ) {
+        $self->carp("no_plan takes no arguments") if $arg;
         $self->no_plan;
     }
     elsif( $cmd eq 'skip_all' ) {
         return $self->skip_all($arg);
     }
     elsif( $cmd eq 'tests' ) {
-        if( $arg ) {
+        if($arg) {
             local $Level = $Level + 1;
             return $self->expected_tests($arg);
         }
         elsif( !defined $arg ) {
             $self->croak("Got an undefined number of tests");
         }
-        elsif( !$arg ) {
+        else {
             $self->croak("You said to run 0 tests");
         }
     }
     else {
-        my @args = grep { defined } ($cmd, $arg);
+        my @args = grep { defined } ( $cmd, $arg );
         $self->croak("plan() doesn't understand @args");
     }
 
@@ -257,9 +260,9 @@ sub expected_tests {
     my $self = shift;
     my($max) = @_;
 
-    if( @_ ) {
+    if(@_) {
         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
-          unless $max =~ /^\+?\d+$/ and $max > 0;
+          unless $max =~ /^\+?\d+$/;
 
         $self->{Expected_Tests} = $max;
         $self->{Have_Plan}      = 1;
@@ -269,7 +272,6 @@ sub expected_tests {
     return $self->{Expected_Tests};
 }
 
-
 =item B<no_plan>
 
   $Test->no_plan;
@@ -283,6 +285,8 @@ sub no_plan {
 
     $self->{No_Plan}   = 1;
     $self->{Have_Plan} = 1;
+
+    return 1;
 }
 
 =item B<has_plan>
@@ -296,11 +300,10 @@ Find out whether a plan has been defined. $plan is either C<undef> (no plan has
 sub has_plan {
     my $self = shift;
 
-    return($self->{Expected_Tests}) if $self->{Expected_Tests};
+    return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
     return('no_plan') if $self->{No_Plan};
     return(undef);
-};
-
+}
 
 =item B<skip_all>
 
@@ -312,7 +315,7 @@ Skips all the tests, using the given $reason.  Exits immediately with 0.
 =cut
 
 sub skip_all {
-    my($self, $reason) = @_;
+    my( $self, $reason ) = @_;
 
     my $out = "1..0";
     $out .= " # Skip $reason" if $reason;
@@ -324,7 +327,6 @@ sub skip_all {
     exit(0);
 }
 
-
 =item B<exported_to>
 
   my $pack = $Test->exported_to;
@@ -339,7 +341,7 @@ the last one will be honored.
 =cut
 
 sub exported_to {
-    my($self, $pack) = @_;
+    my( $self, $pack ) = @_;
 
     if( defined $pack ) {
         $self->{Exported_To} = $pack;
@@ -369,7 +371,7 @@ like Test::Simple's ok().
 =cut
 
 sub ok {
-    my($self, $test, $name) = @_;
+    my( $self, $test, $name ) = @_;
 
     # $test might contain an object which we don't want to accidentally
     # store, so we turn it into a boolean.
@@ -381,27 +383,27 @@ sub ok {
     $self->{Curr_Test}++;
 
     # In case $name is a string overloaded object, force it to stringify.
-    $self->_unoverload_str(\$name);
+    $self->_unoverload_str( \$name );
 
-    $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+    $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
     You named your test '$name'.  You shouldn't use numbers for your test names.
     Very confusing.
 ERR
 
-    my $todo = $self->todo();
-    
     # Capture the value of $TODO for the rest of this ok() call
     # so it can more easily be found by other routines.
-    local $self->{TODO} = $todo;
+    my $todo    = $self->todo();
+    my $in_todo = $self->in_todo;
+    local $self->{Todo} = $todo if $in_todo;
 
-    $self->_unoverload_str(\$todo);
+    $self->_unoverload_str( \$todo );
 
     my $out;
-    my $result = &share({});
+    my $result = &share( {} );
 
-    unless( $test ) {
+    unless($test) {
         $out .= "not ";
-        @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+        @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
     }
     else {
         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
@@ -411,16 +413,16 @@ ERR
     $out .= " $self->{Curr_Test}" if $self->use_numbers;
 
     if( defined $name ) {
-        $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
-        $out   .= " - $name";
+        $name =~ s|#|\\#|g;    # # in a name can confuse Test::Harness.
+        $out .= " - $name";
         $result->{name} = $name;
     }
     else {
         $result->{name} = '';
     }
 
-    if( $todo ) {
-        $out   .= " # TODO $todo";
+    if( $self->in_todo ) {
+        $out .= " # TODO $todo";
         $result->{reason} = $todo;
         $result->{type}   = 'todo';
     }
@@ -429,16 +431,16 @@ ERR
         $result->{type}   = '';
     }
 
-    $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
+    $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
     $out .= "\n";
 
     $self->_print($out);
 
-    unless( $test ) {
-        my $msg = $todo ? "Failed (TODO)" : "Failed";
-        $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
+    unless($test) {
+        my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
+        $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
 
-    my(undef, $file, $line) = $self->caller;
+        my( undef, $file, $line ) = $self->caller;
         if( defined $name ) {
             $self->diag(qq[  $msg test '$name'\n]);
             $self->diag(qq[  at $file line $line.\n]);
@@ -446,64 +448,62 @@ ERR
         else {
             $self->diag(qq[  $msg test at $file line $line.\n]);
         }
-    } 
+    }
 
     return $test ? 1 : 0;
 }
 
-
 sub _unoverload {
-    my $self  = shift;
-    my $type  = shift;
+    my $self = shift;
+    my $type = shift;
 
-    $self->_try(sub { require overload } ) || return;
+    $self->_try( sub { require overload } ) || return;
 
     foreach my $thing (@_) {
         if( $self->_is_object($$thing) ) {
-            if( my $string_meth = overload::Method($$thing, $type) ) {
+            if( my $string_meth = overload::Method( $$thing, $type ) ) {
                 $$thing = $$thing->$string_meth();
             }
         }
     }
-}
 
+    return;
+}
 
 sub _is_object {
-    my($self, $thing) = @_;
+    my( $self, $thing ) = @_;
 
-    return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
+    return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
 }
 
-
 sub _unoverload_str {
     my $self = shift;
 
-    $self->_unoverload(q[""], @_);
-}    
+    return $self->_unoverload( q[""], @_ );
+}
 
 sub _unoverload_num {
     my $self = shift;
 
-    $self->_unoverload('0+', @_);
+    $self->_unoverload( '0+', @_ );
 
     for my $val (@_) {
         next unless $self->_is_dualvar($$val);
-        $$val = $$val+0;
+        $$val = $$val + 0;
     }
-}
 
+    return;
+}
 
 # This is a hack to detect a dualvar such as $!
 sub _is_dualvar {
-    my($self, $val) = @_;
+    my( $self, $val ) = @_;
 
-    local $^W = 0;
-    my $numval = $val+0;
-    return 1 if $numval != 0 and $numval ne $val;
+    no warnings 'numeric';
+    my $numval = $val + 0;
+    return $numval != 0 and $numval ne $val ? 1 : 0;
 }
 
-
-
 =item B<is_eq>
 
   $Test->is_eq($got, $expected, $name);
@@ -521,67 +521,85 @@ numeric version.
 =cut
 
 sub is_eq {
-    my($self, $got, $expect, $name) = @_;
+    my( $self, $got, $expect, $name ) = @_;
     local $Level = $Level + 1;
 
-    $self->_unoverload_str(\$got, \$expect);
+    $self->_unoverload_str( \$got, \$expect );
 
     if( !defined $got || !defined $expect ) {
         # undef only matches undef and nothing else
         my $test = !defined $got && !defined $expect;
 
-        $self->ok($test, $name);
-        $self->_is_diag($got, 'eq', $expect) unless $test;
+        $self->ok( $test, $name );
+        $self->_is_diag( $got, 'eq', $expect ) unless $test;
         return $test;
     }
 
-    return $self->cmp_ok($got, 'eq', $expect, $name);
+    return $self->cmp_ok( $got, 'eq', $expect, $name );
 }
 
 sub is_num {
-    my($self, $got, $expect, $name) = @_;
+    my( $self, $got, $expect, $name ) = @_;
     local $Level = $Level + 1;
 
-    $self->_unoverload_num(\$got, \$expect);
+    $self->_unoverload_num( \$got, \$expect );
 
     if( !defined $got || !defined $expect ) {
         # undef only matches undef and nothing else
         my $test = !defined $got && !defined $expect;
 
-        $self->ok($test, $name);
-        $self->_is_diag($got, '==', $expect) unless $test;
+        $self->ok( $test, $name );
+        $self->_is_diag( $got, '==', $expect ) unless $test;
         return $test;
     }
 
-    return $self->cmp_ok($got, '==', $expect, $name);
+    return $self->cmp_ok( $got, '==', $expect, $name );
 }
 
-sub _is_diag {
-    my($self, $got, $type, $expect) = @_;
+sub _diag_fmt {
+    my( $self, $type, $val ) = @_;
 
-    foreach my $val (\$got, \$expect) {
-        if( defined $$val ) {
-            if( $type eq 'eq' ) {
-                # quote and force string context
-                $$val = "'$$val'"
-            }
-            else {
-                # force numeric context
-                $self->_unoverload_num($val);
-            }
+    if( defined $$val ) {
+        if( $type eq 'eq' or $type eq 'ne' ) {
+            # quote and force string context
+            $$val = "'$$val'";
         }
         else {
-            $$val = 'undef';
+            # force numeric context
+            $self->_unoverload_num($val);
         }
     }
+    else {
+        $$val = 'undef';
+    }
+
+    return;
+}
+
+sub _is_diag {
+    my( $self, $got, $type, $expect ) = @_;
+
+    $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
 
     local $Level = $Level + 1;
-    return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
-         got: %s
-    expected: %s
+    return $self->diag(<<"DIAGNOSTIC");
+         got: $got
+    expected: $expect
 DIAGNOSTIC
 
-}    
+}
+
+sub _isnt_diag {
+    my( $self, $got, $type ) = @_;
+
+    $self->_diag_fmt( $type, \$got );
+
+    local $Level = $Level + 1;
+    return $self->diag(<<"DIAGNOSTIC");
+         got: $got
+    expected: anything else
+DIAGNOSTIC
+}
 
 =item B<isnt_eq>
 
@@ -600,38 +618,37 @@ the numeric version.
 =cut
 
 sub isnt_eq {
-    my($self, $got, $dont_expect, $name) = @_;
+    my( $self, $got, $dont_expect, $name ) = @_;
     local $Level = $Level + 1;
 
     if( !defined $got || !defined $dont_expect ) {
         # undef only matches undef and nothing else
         my $test = defined $got || defined $dont_expect;
 
-        $self->ok($test, $name);
-        $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
+        $self->ok( $test, $name );
+        $self->_isnt_diag( $got, 'ne' ) unless $test;
         return $test;
     }
 
-    return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+    return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
 }
 
 sub isnt_num {
-    my($self, $got, $dont_expect, $name) = @_;
+    my( $self, $got, $dont_expect, $name ) = @_;
     local $Level = $Level + 1;
 
     if( !defined $got || !defined $dont_expect ) {
         # undef only matches undef and nothing else
         my $test = defined $got || defined $dont_expect;
 
-        $self->ok($test, $name);
-        $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
+        $self->ok( $test, $name );
+        $self->_isnt_diag( $got, '!=' ) unless $test;
         return $test;
     }
 
-    return $self->cmp_ok($got, '!=', $dont_expect, $name);
+    return $self->cmp_ok( $got, '!=', $dont_expect, $name );
 }
 
-
 =item B<like>
 
   $Test->like($this, qr/$regex/, $name);
@@ -652,20 +669,19 @@ given $regex.
 =cut
 
 sub like {
-    my($self, $this, $regex, $name) = @_;
+    my( $self, $this, $regex, $name ) = @_;
 
     local $Level = $Level + 1;
-    $self->_regex_ok($this, $regex, '=~', $name);
+    return $self->_regex_ok( $this, $regex, '=~', $name );
 }
 
 sub unlike {
-    my($self, $this, $regex, $name) = @_;
+    my( $self, $this, $regex, $name ) = @_;
 
     local $Level = $Level + 1;
-    $self->_regex_ok($this, $regex, '!~', $name);
+    return $self->_regex_ok( $this, $regex, '!~', $name );
 }
 
-
 =item B<cmp_ok>
 
   $Test->cmp_ok($this, $type, $that, $name);
@@ -676,28 +692,29 @@ Works just like Test::More's cmp_ok().
 
 =cut
 
-
-my %numeric_cmps = map { ($_, 1) } 
-                       ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
 
 sub cmp_ok {
-    my($self, $got, $type, $expect, $name) = @_;
+    my( $self, $got, $type, $expect, $name ) = @_;
 
     # Treat overloaded objects as numbers if we're asked to do a
     # numeric comparison.
-    my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
-                                          : '_unoverload_str';
-
-    $self->$unoverload(\$got, \$expect);
+    my $unoverload
+      = $numeric_cmps{$type}
+      ? '_unoverload_num'
+      : '_unoverload_str';
 
+    $self->$unoverload( \$got, \$expect );
 
     my $test;
     {
-        local($@,$!,$SIG{__DIE__});  # isolate eval
+        ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+        local( $@, $!, $SIG{__DIE__} );    # isolate eval
 
         my $code = $self->_caller_context;
 
-        # Yes, it has to look like this or 5.4.5 won't see the #line 
+        # Yes, it has to look like this or 5.4.5 won't see the #line
         # directive.
         # Don't ask me, man, I just work here.
         $test = eval "
@@ -705,38 +722,40 @@ $code" . "\$got $type \$expect;";
 
     }
     local $Level = $Level + 1;
-    my $ok = $self->ok($test, $name);
+    my $ok = $self->ok( $test, $name );
 
-    unless( $ok ) {
+    unless($ok) {
         if( $type =~ /^(eq|==)$/ ) {
-            $self->_is_diag($got, $type, $expect);
+            $self->_is_diag( $got, $type, $expect );
+        }
+        elsif( $type =~ /^(ne|!=)$/ ) {
+            $self->_isnt_diag( $got, $type );
         }
         else {
-            $self->_cmp_diag($got, $type, $expect);
+            $self->_cmp_diag( $got, $type, $expect );
         }
     }
     return $ok;
 }
 
 sub _cmp_diag {
-    my($self, $got, $type, $expect) = @_;
-    
+    my( $self, $got, $type, $expect ) = @_;
+
     $got    = defined $got    ? "'$got'"    : 'undef';
     $expect = defined $expect ? "'$expect'" : 'undef';
-    
+
     local $Level = $Level + 1;
-    return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
-    %s
-        %s
-    %s
+    return $self->diag(<<"DIAGNOSTIC");
+    $got
+        $type
+    $expect
 DIAGNOSTIC
 }
 
-
 sub _caller_context {
     my $self = shift;
 
-    my($pack, $file, $line) = $self->caller(1);
+    my( $pack, $file, $line ) = $self->caller(1);
 
     my $code = '';
     $code .= "#line $line $file\n" if defined $file and defined $line;
@@ -766,7 +785,7 @@ It will exit with 255.
 =cut
 
 sub BAIL_OUT {
-    my($self, $reason) = @_;
+    my( $self, $reason ) = @_;
 
     $self->{Bailed_Out} = 1;
     $self->_print("Bail out!  $reason");
@@ -780,7 +799,6 @@ BAIL_OUT() used to be BAILOUT()
 
 *BAILOUT = \&BAIL_OUT;
 
-
 =item B<skip>
 
     $Test->skip;
@@ -791,35 +809,36 @@ Skips the current test, reporting $why.
 =cut
 
 sub skip {
-    my($self, $why) = @_;
+    my( $self, $why ) = @_;
     $why ||= '';
-    $self->_unoverload_str(\$why);
+    $self->_unoverload_str( \$why );
 
     $self->_plan_check;
 
-    lock($self->{Curr_Test});
+    lock( $self->{Curr_Test} );
     $self->{Curr_Test}++;
 
-    $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
-        'ok'      => 1,
-        actual_ok => 1,
-        name      => '',
-        type      => 'skip',
-        reason    => $why,
-    });
+    $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+        {
+            'ok'      => 1,
+            actual_ok => 1,
+            name      => '',
+            type      => 'skip',
+            reason    => $why,
+        }
+    );
 
     my $out = "ok";
-    $out   .= " $self->{Curr_Test}" if $self->use_numbers;
-    $out   .= " # skip";
-    $out   .= " $why"       if length $why;
-    $out   .= "\n";
+    $out .= " $self->{Curr_Test}" if $self->use_numbers;
+    $out .= " # skip";
+    $out .= " $why"               if length $why;
+    $out .= "\n";
 
     $self->_print($out);
 
     return 1;
 }
 
-
 =item B<todo_skip>
 
   $Test->todo_skip;
@@ -833,32 +852,33 @@ to
 =cut
 
 sub todo_skip {
-    my($self, $why) = @_;
+    my( $self, $why ) = @_;
     $why ||= '';
 
     $self->_plan_check;
 
-    lock($self->{Curr_Test});
+    lock( $self->{Curr_Test} );
     $self->{Curr_Test}++;
 
-    $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
-        'ok'      => 1,
-        actual_ok => 0,
-        name      => '',
-        type      => 'todo_skip',
-        reason    => $why,
-    });
+    $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
+        {
+            'ok'      => 1,
+            actual_ok => 0,
+            name      => '',
+            type      => 'todo_skip',
+            reason    => $why,
+        }
+    );
 
     my $out = "not ok";
-    $out   .= " $self->{Curr_Test}" if $self->use_numbers;
-    $out   .= " # TODO & SKIP $why\n";
+    $out .= " $self->{Curr_Test}" if $self->use_numbers;
+    $out .= " # TODO & SKIP $why\n";
 
     $self->_print($out);
 
     return 1;
 }
 
-
 =begin _unimplemented
 
 =item B<skip_rest>
@@ -895,7 +915,7 @@ Takes a quoted regular expression produced by qr//, or a string
 representing a regular expression.
 
 Returns a Perl value which may be used instead of the corresponding
-regular expression, or undef if it's argument is not recognised.
+regular expression, or undef if its argument is not recognised.
 
 For example, a version of like(), sans the useful diagnostic messages,
 could be written as:
@@ -910,23 +930,22 @@ could be written as:
 
 =cut
 
-
 sub maybe_regex {
-    my ($self, $regex) = @_;
+    my( $self, $regex ) = @_;
     my $usable_regex = undef;
 
     return $usable_regex unless defined $regex;
 
-    my($re, $opts);
+    my( $re, $opts );
 
     # Check for qr/foo/
     if( _is_qr($regex) ) {
         $usable_regex = $regex;
     }
     # Check for '/foo/' or 'm,foo,'
-    elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
-           (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
-         )
+    elsif(( $re, $opts )        = $regex =~ m{^ /(.*)/ (\w*) $ }sx              or
+          ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+    )
     {
         $usable_regex = length $opts ? "(?$opts)$re" : $re;
     }
@@ -934,35 +953,36 @@ sub maybe_regex {
     return $usable_regex;
 }
 
-
 sub _is_qr {
     my $regex = shift;
-    
+
     # is_regexp() checks for regexes in a robust manner, say if they're
     # blessed.
     return re::is_regexp($regex) if defined &re::is_regexp;
     return ref $regex eq 'Regexp';
 }
 
-
 sub _regex_ok {
-    my($self, $this, $regex, $cmp, $name) = @_;
+    my( $self, $this, $regex, $cmp, $name ) = @_;
 
-    my $ok = 0;
+    my $ok           = 0;
     my $usable_regex = $self->maybe_regex($regex);
-    unless (defined $usable_regex) {
+    unless( defined $usable_regex ) {
+        local $Level = $Level + 1;
         $ok = $self->ok( 0, $name );
         $self->diag("    '$regex' doesn't look much like a regex to me.");
         return $ok;
     }
 
     {
+        ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
         my $test;
         my $code = $self->_caller_context;
 
-        local($@, $!, $SIG{__DIE__}); # isolate eval
+        local( $@, $!, $SIG{__DIE__} );    # isolate eval
 
-        # Yes, it has to look like this or 5.4.5 won't see the #line 
+        # Yes, it has to look like this or 5.4.5 won't see the #line
         # directive.
         # Don't ask me, man, I just work here.
         $test = eval "
@@ -974,12 +994,12 @@ $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
         $ok = $self->ok( $test, $name );
     }
 
-    unless( $ok ) {
+    unless($ok) {
         $this = defined $this ? "'$this'" : 'undef';
         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
 
         local $Level = $Level + 1;
-        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+        $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
                   %s
     %13s '%s'
 DIAGNOSTIC
@@ -989,7 +1009,6 @@ DIAGNOSTIC
     return $ok;
 }
 
-
 # I'm not ready to publish this.  It doesn't deal with array return
 # values from the code or context.
 
@@ -1000,7 +1019,10 @@ DIAGNOSTIC
     my $return_from_code          = $Test->try(sub { code });
     my($return_from_code, $error) = $Test->try(sub { code });
 
-Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
+Works like eval BLOCK except it ensures it has no effect on the rest
+of the test (ie. $@ is not set) nor is effected by outside
+interference (ie. $SIG{__DIE__}) and works around some quirks in older
+Perls.
 
 $error is what would normally be in $@.
 
@@ -1009,14 +1031,14 @@ It is suggested you use this in place of eval BLOCK.
 =cut
 
 sub _try {
-    my($self, $code) = @_;
-    
+    my( $self, $code ) = @_;
+
     local $!;               # eval can mess up $!
     local $@;               # don't set $@ in the test
     local $SIG{__DIE__};    # don't trip an outside DIE handler.
     my $return = eval { $code->() };
-    
-    return wantarray ? ($return, $@) : $return;
+
+    return wantarray ? ( $return, $@ ) : $return;
 }
 
 =end private
@@ -1031,19 +1053,18 @@ Determines if the given $thing can be used as a filehandle.
 =cut
 
 sub is_fh {
-    my $self = shift;
+    my $self     = shift;
     my $maybe_fh = shift;
     return 0 unless defined $maybe_fh;
 
-    return 1 if ref $maybe_fh  eq 'GLOB'; # its a glob ref
-    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+    return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
+    return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob
 
     return eval { $maybe_fh->isa("IO::Handle") } ||
            # 5.5.4's tied() and can() doesn't like getting undef
-           eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
+           eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
 }
 
-
 =back
 
 
@@ -1076,7 +1097,7 @@ To be polite to other functions wrapping your own you usually want to increment
 =cut
 
 sub level {
-    my($self, $level) = @_;
+    my( $self, $level ) = @_;
 
     if( defined $level ) {
         $Level = $level;
@@ -1084,7 +1105,6 @@ sub level {
     return $Level;
 }
 
-
 =item B<use_numbers>
 
     $Test->use_numbers($on_or_off);
@@ -1109,7 +1129,7 @@ Defaults to on.
 =cut
 
 sub use_numbers {
-    my($self, $use_nums) = @_;
+    my( $self, $use_nums ) = @_;
 
     if( defined $use_nums ) {
         $self->{Use_Nums} = $use_nums;
@@ -1117,7 +1137,6 @@ sub use_numbers {
     return $self->{Use_Nums};
 }
 
-
 =item B<no_diag>
 
     $Test->no_diag($no_diag);
@@ -1146,7 +1165,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
     my $method = lc $attribute;
 
     my $code = sub {
-        my($self, $no) = @_;
+        my( $self, $no ) = @_;
 
         if( defined $no ) {
             $self->{$attribute} = $no;
@@ -1154,11 +1173,10 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
         return $self->{$attribute};
     };
 
-    no strict 'refs';   ## no critic
-    *{__PACKAGE__.'::'.$method} = $code;
+    no strict 'refs';    ## no critic
+    *{ __PACKAGE__ . '::' . $method } = $code;
 }
 
-
 =back
 
 =head2 Output
@@ -1197,7 +1215,35 @@ Mark Fowler <mark@twoshortplanks.com>
 =cut
 
 sub diag {
-    my($self, @msgs) = @_;
+    my $self = shift;
+
+    $self->_print_comment( $self->_diag_fh, @_ );
+}
+
+=item B<note>
+
+    $Test->note(@msgs);
+
+Like diag(), but it prints to the C<output()> handle so it will not
+normally be seen by the user except in verbose mode.
+
+=cut
+
+sub note {
+    my $self = shift;
+
+    $self->_print_comment( $self->output, @_ );
+}
+
+sub _diag_fh {
+    my $self = shift;
+
+    local $Level = $Level + 1;
+    return $self->in_todo ? $self->todo_output : $self->failure_output;
+}
+
+sub _print_comment {
+    my( $self, $fh, @msgs ) = @_;
 
     return if $self->no_diag;
     return unless @msgs;
@@ -1209,18 +1255,47 @@ sub diag {
     # Convert undef to 'undef' so its readable.
     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
 
-    # Escape each line with a #.
-    $msg =~ s/^/# /gm;
-
-    # Stick a newline on the end if it needs it.
-    $msg .= "\n" unless $msg =~ /\n\Z/;
+    # Escape the beginning, _print will take care of the rest.
+    $msg =~ s/^/# /;
 
     local $Level = $Level + 1;
-    $self->_print_diag($msg);
+    $self->_print_to_fh( $fh, $msg );
 
     return 0;
 }
 
+=item B<explain>
+
+    my @dump = $Test->explain(@msgs);
+
+Will dump the contents of any references in a human readable format.
+Handy for things like...
+
+    is_deeply($have, $want) || diag explain $have;
+
+or
+
+    is_deeply($have, $want) || note explain $have;
+
+=cut
+
+sub explain {
+    my $self = shift;
+
+    return map {
+        ref $_
+          ? do {
+            require Data::Dumper;
+
+            my $dumper = Data::Dumper->new( [$_] );
+            $dumper->Indent(1)->Terse(1);
+            $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+            $dumper->Dump;
+          }
+          : $_
+    } @_;
+}
+
 =begin _private
 
 =item B<_print>
@@ -1234,7 +1309,12 @@ Prints to the output() filehandle.
 =cut
 
 sub _print {
-    my($self, @msgs) = @_;
+    my $self = shift;
+    return $self->_print_to_fh( $self->output, @_ );
+}
+
+sub _print_to_fh {
+    my( $self, $fh, @msgs ) = @_;
 
     # Prevent printing headers when only compiling.  Mostly for when
     # tests are deparsed with B::Deparse
@@ -1242,8 +1322,7 @@ sub _print {
 
     my $msg = join '', @msgs;
 
-    local($\, $", $,) = (undef, ' ', '');
-    my $fh = $self->output;
+    local( $\, $", $, ) = ( undef, ' ', '' );
 
     # Escape each line after the first with a # so we don't
     # confuse Test::Harness.
@@ -1252,29 +1331,9 @@ sub _print {
     # Stick a newline on the end if it needs it.
     $msg .= "\n" unless $msg =~ /\n\Z/;
 
-    print $fh $msg;
+    return print $fh $msg;
 }
 
-=begin private
-
-=item B<_print_diag>
-
-    $Test->_print_diag(@msg);
-
-Like _print, but prints to the current diagnostic filehandle.
-
-=end private
-
-=cut
-
-sub _print_diag {
-    my $self = shift;
-
-    local($\, $", $,) = (undef, ' ', '');
-    my $fh = $self->todo ? $self->todo_output : $self->failure_output;
-    print $fh @_;
-}    
-
 =item B<output>
 
     $Test->output($fh);
@@ -1305,7 +1364,7 @@ Defaults to STDOUT.
 =cut
 
 sub output {
-    my($self, $fh) = @_;
+    my( $self, $fh ) = @_;
 
     if( defined $fh ) {
         $self->{Out_FH} = $self->_new_fh($fh);
@@ -1314,7 +1373,7 @@ sub output {
 }
 
 sub failure_output {
-    my($self, $fh) = @_;
+    my( $self, $fh ) = @_;
 
     if( defined $fh ) {
         $self->{Fail_FH} = $self->_new_fh($fh);
@@ -1323,7 +1382,7 @@ sub failure_output {
 }
 
 sub todo_output {
-    my($self, $fh) = @_;
+    my( $self, $fh ) = @_;
 
     if( defined $fh ) {
         $self->{Todo_FH} = $self->_new_fh($fh);
@@ -1331,7 +1390,6 @@ sub todo_output {
     return $self->{Todo_FH};
 }
 
-
 sub _new_fh {
     my $self = shift;
     my($file_or_fh) = shift;
@@ -1341,24 +1399,25 @@ sub _new_fh {
         $fh = $file_or_fh;
     }
     else {
-        open $fh, ">", $file_or_fh or
-            $self->croak("Can't open test output log $file_or_fh: $!");
+        open $fh, ">", $file_or_fh
+          or $self->croak("Can't open test output log $file_or_fh: $!");
         _autoflush($fh);
     }
 
     return $fh;
 }
 
-
 sub _autoflush {
     my($fh) = shift;
     my $old_fh = select $fh;
     $| = 1;
     select $old_fh;
+
+    return;
 }
 
+my( $Testout, $Testerr );
 
-my($Testout, $Testerr);
 sub _dup_stdhandles {
     my $self = shift;
 
@@ -1367,43 +1426,66 @@ sub _dup_stdhandles {
     # Set everything to unbuffered else plain prints to STDOUT will
     # come out in the wrong order from our own prints.
     _autoflush($Testout);
-    _autoflush(\*STDOUT);
+    _autoflush( \*STDOUT );
     _autoflush($Testerr);
-    _autoflush(\*STDERR);
+    _autoflush( \*STDERR );
 
-    $self->output        ($Testout);
-    $self->failure_output($Testerr);
-    $self->todo_output   ($Testout);
-}
+    $self->reset_outputs;
 
+    return;
+}
 
 my $Opened_Testhandles = 0;
+
 sub _open_testhandles {
     my $self = shift;
-    
+
     return if $Opened_Testhandles;
-    
+
     # We dup STDOUT and STDERR so people can change them in their
     # test suites while still getting normal test output.
-    open( $Testout, ">&STDOUT") or die "Can't dup STDOUT:  $!";
-    open( $Testerr, ">&STDERR") or die "Can't dup STDERR:  $!";
+    open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT:  $!";
+    open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR:  $!";
+
+    #    $self->_copy_io_layers( \*STDOUT, $Testout );
+    #    $self->_copy_io_layers( \*STDERR, $Testerr );
 
-#    $self->_copy_io_layers( \*STDOUT, $Testout );
-#    $self->_copy_io_layers( \*STDERR, $Testerr );
-    
     $Opened_Testhandles = 1;
-}
 
+    return;
+}
 
 sub _copy_io_layers {
-    my($self, $src, $dst) = @_;
-    
-    $self->_try(sub {
-        require PerlIO;
-        my @src_layers = PerlIO::get_layers($src);
+    my( $self, $src, $dst ) = @_;
+
+    $self->_try(
+        sub {
+            require PerlIO;
+            my @src_layers = PerlIO::get_layers($src);
+
+            binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+        }
+    );
+
+    return;
+}
+
+=item reset_outputs
+
+  $tb->reset_outputs;
+
+Resets all the output filehandles back to their defaults.
+
+=cut
+
+sub reset_outputs {
+    my $self = shift;
 
-        binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
-    });
+    $self->output        ($Testout);
+    $self->failure_output($Testerr);
+    $self->todo_output   ($Testout);
+
+    return;
 }
 
 =item carp
@@ -1426,18 +1508,18 @@ sub _message_at_caller {
     my $self = shift;
 
     local $Level = $Level + 1;
-    my($pack, $file, $line) = $self->caller;
-    return join("", @_) . " at $file line $line.\n";
+    my( $pack, $file, $line ) = $self->caller;
+    return join( "", @_ ) . " at $file line $line.\n";
 }
 
 sub carp {
     my $self = shift;
-    warn $self->_message_at_caller(@_);
+    return warn $self->_message_at_caller(@_);
 }
 
 sub croak {
     my $self = shift;
-    die $self->_message_at_caller(@_);
+    return die $self->_message_at_caller(@_);
 }
 
 sub _plan_check {
@@ -1447,6 +1529,8 @@ sub _plan_check {
         local $Level = $Level + 2;
         $self->croak("You tried to run a test without a plan");
     }
+
+    return;
 }
 
 =back
@@ -1471,13 +1555,12 @@ can erase history if you really want to.
 =cut
 
 sub current_test {
-    my($self, $num) = @_;
+    my( $self, $num ) = @_;
 
-    lock($self->{Curr_Test});
+    lock( $self->{Curr_Test} );
     if( defined $num ) {
-        unless( $self->{Have_Plan} ) {
-            $self->croak("Can't change the current test number without a plan!");
-        }
+        $self->croak("Can't change the current test number without a plan!")
+          unless $self->{Have_Plan};
 
         $self->{Curr_Test} = $num;
 
@@ -1485,14 +1568,16 @@ sub current_test {
         my $test_results = $self->{Test_Results};
         if( $num > @$test_results ) {
             my $start = @$test_results ? @$test_results : 0;
-            for ($start..$num-1) {
-                $test_results->[$_] = &share({
-                    'ok'      => 1, 
-                    actual_ok => undef, 
-                    reason    => 'incrementing test number', 
-                    type      => 'unknown', 
-                    name      => undef 
-                });
+            for( $start .. $num - 1 ) {
+                $test_results->[$_] = &share(
+                    {
+                        'ok'      => 1,
+                        actual_ok => undef,
+                        reason    => 'incrementing test number',
+                        type      => 'unknown',
+                        name      => undef
+                    }
+                );
             }
         }
         # If backward, wipe history.  Its their funeral.
@@ -1503,7 +1588,6 @@ sub current_test {
     return $self->{Curr_Test};
 }
 
-
 =item B<summary>
 
     my @tests = $Test->summary;
@@ -1554,7 +1638,7 @@ of ''.  Type can be one of the following:
 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.
+its type is 'unknown'.  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
@@ -1580,10 +1664,13 @@ sub details {
     my $todo_reason = $Test->todo;
     my $todo_reason = $Test->todo($pack);
 
-todo() looks for a $TODO variable in your tests.  If set, all tests
-will be considered 'todo' (see Test::More and Test::Harness for
-details).  Returns the reason (ie. the value of $TODO) if running as
-todo tests, false otherwise.
+If the current tests are considered "TODO" it will return the reason,
+if any.  This reason can come from a $TODO variable or the last call
+to C<<todo_start()>>.
+
+Since a TODO test does not need a reason, this function can return an
+empty string even when inside a TODO block.  Use C<<$Test->in_todo>>
+to determine if you are currently inside a TODO block.
 
 todo() is about finding the right package to look for $TODO in.  It's
 pretty good at guessing the right package to look at.  It first looks for
@@ -1597,16 +1684,134 @@ what $pack to use.
 =cut
 
 sub todo {
-    my($self, $pack) = @_;
+    my( $self, $pack ) = @_;
+
+    return $self->{Todo} if defined $self->{Todo};
+
+    local $Level = $Level + 1;
+    my $todo = $self->find_TODO($pack);
+    return $todo if defined $todo;
+
+    return '';
+}
+
+=item B<find_TODO>
 
-    return $self->{TODO} if defined $self->{TODO};
+    my $todo_reason = $Test->find_TODO();
+    my $todo_reason = $Test->find_TODO($pack):
+
+Like C<<todo()>> but only returns the value of C<<$TODO>> ignoring
+C<<todo_start()>>.
+
+=cut
+
+sub find_TODO {
+    my( $self, $pack ) = @_;
 
     $pack = $pack || $self->caller(1) || $self->exported_to;
-    return unless $pack;
+    return unless $pack;
 
-    no strict 'refs';   ## no critic
-    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
-                                     : 0;
+    no strict 'refs';    ## no critic
+    return ${ $pack . '::TODO' };
+}
+
+=item B<in_todo>
+
+    my $in_todo = $Test->in_todo;
+
+Returns true if the test is currently inside a TODO block.
+
+=cut
+
+sub in_todo {
+    my $self = shift;
+
+    local $Level = $Level + 1;
+    return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
+}
+
+=item B<todo_start>
+
+    $Test->todo_start();
+    $Test->todo_start($message);
+
+This method allows you declare all subsequent tests as TODO tests, up until
+the C<todo_end> method has been called.
+
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
+whether or not we're in a TODO test.  However, often we find that this is not
+possible to determine (such as when we want to use C<$TODO> but
+the tests are being executed in other packages which can't be inferred
+beforehand).
+
+Note that you can use this to nest "todo" tests
+
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+
+This is generally not recommended, but large testing systems often have weird
+internal needs.
+
+We've tried to make this also work with the TODO: syntax, but it's not
+guaranteed and its use is also discouraged:
+
+ TODO: {
+     local $TODO = 'We have work to do!';
+     $Test->todo_start('working on this');
+     # lots of code
+     $Test->todo_start('working on that');
+     # more code
+     $Test->todo_end;
+     $Test->todo_end;
+ }
+
+Pick one style or another of "TODO" to be on the safe side.
+
+=cut
+
+sub todo_start {
+    my $self = shift;
+    my $message = @_ ? shift : '';
+
+    $self->{Start_Todo}++;
+    if( $self->in_todo ) {
+        push @{ $self->{Todo_Stack} } => $self->todo;
+    }
+    $self->{Todo} = $message;
+
+    return;
+}
+
+=item C<todo_end>
+
+ $Test->todo_end;
+
+Stops running tests as "TODO" tests.  This method is fatal if called without a
+preceding C<todo_start> method call.
+
+=cut
+
+sub todo_end {
+    my $self = shift;
+
+    if( !$self->{Start_Todo} ) {
+        $self->croak('todo_end() called without todo_start()');
+    }
+
+    $self->{Start_Todo}--;
+
+    if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
+        $self->{Todo} = pop @{ $self->{Todo_Stack} };
+    }
+    else {
+        delete $self->{Todo};
+    }
+
+    return;
 }
 
 =item B<caller>
@@ -1621,11 +1826,11 @@ C<$height> will be added to the level().
 
 =cut
 
-sub caller {
-    my($self, $height) = @_;
+sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+    my( $self, $height ) = @_;
     $height ||= 0;
 
-    my @caller = CORE::caller($self->level + $height + 1);
+    my @caller = CORE::caller( $self->level + $height + 1 );
     return wantarray ? @caller : $caller[0];
 }
 
@@ -1651,11 +1856,13 @@ error message.
 sub _sanity_check {
     my $self = shift;
 
-    $self->_whoa($self->{Curr_Test} < 0,  'Says here you ran a negative number of tests!');
-    $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 
-          'Somehow your tests ran without a plan!');
-    $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
-          'Somehow you got a different number of results than tests ran!');
+    $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
+    $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test},
+        'Somehow your tests ran without a plan!' );
+    $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
+        'Somehow you got a different number of results than tests ran!' );
+
+    return;
 }
 
 =item B<_whoa>
@@ -1669,14 +1876,16 @@ a note to contact the author.
 =cut
 
 sub _whoa {
-    my($self, $check, $desc) = @_;
-    if( $check ) {
+    my( $self, $check, $desc ) = @_;
+    if($check) {
         local $Level = $Level + 1;
         $self->croak(<<"WHOA");
 WHOA!  $desc
 This should never happen!  Please contact the author immediately!
 WHOA
     }
+
+    return;
 }
 
 =item B<_my_exit>
@@ -1691,12 +1900,11 @@ doesn't actually exit, that's your job.
 =cut
 
 sub _my_exit {
-    $? = $_[0];
+    $? = $_[0];    ## no critic (Variables::RequireLocalizedPunctuationVars)
 
     return 1;
 }
 
-
 =back
 
 =end _private
@@ -1714,8 +1922,8 @@ sub _ending {
     if( $self->{Original_Pid} != $$ ) {
         return;
     }
-    
-    # Exit if plan() was never called.  This is so "require Test::Simple" 
+
+    # Exit if plan() was never called.  This is so "require Test::Simple"
     # doesn't puke.
     if( !$self->{Have_Plan} ) {
         return;
@@ -1728,7 +1936,7 @@ sub _ending {
 
     # Figure out if we passed or failed and print helpful messages.
     my $test_results = $self->{Test_Results};
-    if( @$test_results ) {
+    if(@$test_results) {
         # The plan?  We have no plan.
         if( $self->{No_Plan} ) {
             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
@@ -1738,31 +1946,24 @@ sub _ending {
         # Auto-extended arrays and elements which aren't explicitly
         # filled in with a shared reference will puke under 5.8.0
         # ithreads.  So we have to fill them in by hand. :(
-        my $empty_result = &share({});
-        for my $idx ( 0..$self->{Expected_Tests}-1 ) {
+        my $empty_result = &share( {} );
+        for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
             $test_results->[$idx] = $empty_result
               unless defined $test_results->[$idx];
         }
 
-        my $num_failed = grep !$_->{'ok'}, 
-                              @{$test_results}[0..$self->{Curr_Test}-1];
+        my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
 
         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
 
-        if( $num_extra < 0 ) {
+        if( $num_extra != 0 ) {
             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
             $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
-FAIL
-        }
-        elsif( $num_extra > 0 ) {
-            my $s = $self->{Expected_Tests} == 1 ? '' : 's';
-            $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
+Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
 FAIL
         }
 
-        if ( $num_failed ) {
+        if($num_failed) {
             my $num_tests = $self->{Curr_Test};
             my $s = $num_failed == 1 ? '' : 's';
 
@@ -1773,16 +1974,16 @@ Looks like you failed $num_failed test$s of $num_tests$qualifier.
 FAIL
         }
 
-        if( $real_exit_code ) {
+        if($real_exit_code) {
             $self->diag(<<"FAIL");
-Looks like your test died just after $self->{Curr_Test}.
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
 FAIL
 
-            _my_exit( 255 ) && return;
+            _my_exit($real_exit_code) && return;
         }
 
         my $exit_code;
-        if( $num_failed ) {
+        if($num_failed) {
             $exit_code = $num_failed <= 254 ? $num_failed : 254;
         }
         elsif( $num_extra != 0 ) {
@@ -1792,21 +1993,23 @@ FAIL
             $exit_code = 0;
         }
 
-        _my_exit( $exit_code ) && return;
+        _my_exit($exit_code) && return;
     }
-    elsif ( $self->{Skip_All} ) {
-        _my_exit( 0 ) && return;
+    elsif( $self->{Skip_All} ) {
+        _my_exit(0) && return;
     }
-    elsif ( $real_exit_code ) {
-        $self->diag(<<'FAIL');
-Looks like your test died before it could output anything.
+    elsif($real_exit_code) {
+        $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code before it could output anything.
 FAIL
-        _my_exit( 255 ) && return;
+        _my_exit($real_exit_code) && return;
     }
     else {
         $self->diag("No tests run!\n");
-        _my_exit( 255 ) && return;
+        _my_exit(255) && return;
     }
+
+    $self->_whoa( 1, "We fell off the end of _ending()" );
 }
 
 END {
@@ -1860,8 +2063,8 @@ E<lt>schwern@pobox.comE<gt>
 
 =head1 COPYRIGHT
 
-Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
-                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+                       Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 
 This program is free software; you can redistribute it and/or 
 modify it under the same terms as Perl itself.
@@ -1871,3 +2074,4 @@ See F<http://www.perl.com/perl/misc/Artistic.html>
 =cut
 
 1;
+
index ea2f2d9..c5e36e8 100644 (file)
@@ -1,4 +1,5 @@
 package Test::Builder::Module;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Module.pm 67223 2008-10-15T03:08:18.888155Z schwern  $
 
 use strict;
 
@@ -7,18 +8,17 @@ use Test::Builder;
 require Exporter;
 our @ISA = qw(Exporter);
 
-our $VERSION = '0.80';
+our $VERSION = '0.82';
 
 # 5.004's Exporter doesn't have export_to_level.
 my $_export_to_level = sub {
-      my $pkg = shift;
-      my $level = shift;
-      (undef) = shift;                  # redundant arg
-      my $callpkg = caller($level);
-      $pkg->export($callpkg, @_);
+    my $pkg   = shift;
+    my $level = shift;
+    (undef) = shift;    # redundant arg
+    my $callpkg = caller($level);
+    $pkg->export( $callpkg, @_ );
 };
 
-
 =head1 NAME
 
 Test::Builder::Module - Base class for test modules
@@ -83,7 +83,7 @@ import_extra().
 
 sub import {
     my($class) = shift;
-    
+
     # Don't run all this when loading ourself.
     return 1 if $class eq 'Test::Builder::Module';
 
@@ -93,27 +93,26 @@ sub import {
 
     $test->exported_to($caller);
 
-    $class->import_extra(\@_);
-    my(@imports) = $class->_strip_imports(\@_);
+    $class->import_extra( \@_ );
+    my(@imports) = $class->_strip_imports( \@_ );
 
     $test->plan(@_);
 
-    $class->$_export_to_level(1, $class, @imports);
+    $class->$_export_to_level( 1, $class, @imports );
 }
 
-
 sub _strip_imports {
     my $class = shift;
     my $list  = shift;
 
     my @imports = ();
     my @other   = ();
-    my $idx = 0;
+    my $idx     = 0;
     while( $idx <= $#{$list} ) {
         my $item = $list->[$idx];
 
         if( defined $item and $item eq 'import' ) {
-            push @imports, @{$list->[$idx+1]};
+            push @imports, @{ $list->[ $idx + 1 ] };
             $idx++;
         }
         else {
@@ -128,7 +127,6 @@ sub _strip_imports {
     return @imports;
 }
 
-
 =head3 import_extra
 
     Your::Module->import_extra(\@import_args);
@@ -146,8 +144,7 @@ feels like a bit of an ugly hack in its current form.
 
 =cut
 
-sub import_extra {}
-
+sub import_extra { }
 
 =head2 Builder
 
@@ -181,5 +178,4 @@ sub builder {
     return Test::Builder->new;
 }
 
-
 1;
index fdb3fb1..772775e 100644 (file)
@@ -1,7 +1,8 @@
 package Test::Builder::Tester;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Tester.pm 67223 2008-10-15T03:08:18.888155Z schwern  $
 
 use strict;
-our $VERSION = "1.13";
+our $VERSION = "1.15";
 
 use Test::Builder;
 use Symbol;
@@ -63,13 +64,12 @@ our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
 # the king of cargo cult programming ;-)
 
 # 5.004's Exporter doesn't have export_to_level.
-sub _export_to_level
-{
-      my $pkg = shift;
-      my $level = shift;
-      (undef) = shift;                  # XXX redundant arg
-      my $callpkg = caller($level);
-      $pkg->export($callpkg, @_);
+sub _export_to_level {
+    my $pkg   = shift;
+    my $level = shift;
+    (undef) = shift;    # XXX redundant arg
+    my $callpkg = caller($level);
+    $pkg->export( $callpkg, @_ );
 }
 
 sub import {
@@ -82,14 +82,14 @@ sub import {
     $t->plan(@plan);
 
     my @imports = ();
-    foreach my $idx (0..$#plan) {
+    foreach my $idx ( 0 .. $#plan ) {
         if( $plan[$idx] eq 'import' ) {
-            @imports = @{$plan[$idx+1]};
+            @imports = @{ $plan[ $idx + 1 ] };
             last;
         }
     }
 
-    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+    __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports );
 }
 
 ###
@@ -123,8 +123,7 @@ my $original_harness_state;
 my $original_harness_env;
 
 # function that starts testing and redirects the filehandles for now
-sub _start_testing
-{
+sub _start_testing {
     # even if we're running under Test::Harness pretend we're not
     # for now.  This needed so Test::Builder doesn't add extra spaces
     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
@@ -145,7 +144,7 @@ sub _start_testing
     $err->reset();
 
     # remeber that we're testing
-    $testing = 1;
+    $testing     = 1;
     $testing_num = $t->current_test;
     $t->current_test(0);
 
@@ -187,20 +186,18 @@ output filehandles)
 
 =cut
 
-sub test_out
-{
+sub test_out {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
-    $out->expect(@_)
+    $out->expect(@_);
 }
 
-sub test_err
-{
+sub test_err {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
-    $err->expect(@_)
+    $err->expect(@_);
 }
 
 =item test_fail
@@ -229,14 +226,13 @@ more simply as:
 
 =cut
 
-sub test_fail
-{
+sub test_fail {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
     # work out what line we should be on
-    my ($package, $filename, $line) = caller;
-    $line = $line + (shift() || 0); # prevent warnings
+    my( $package, $filename, $line ) = caller;
+    $line = $line + ( shift() || 0 );    # prevent warnings
 
     # expect that on stderr
     $err->expect("#     Failed test ($0 at line $line)");
@@ -272,14 +268,13 @@ without the newlines.
 
 =cut
 
-sub test_diag
-{
+sub test_diag {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
     # expect the same thing, but prepended with "#     "
     local $_;
-    $err->expect(map {"# $_"} @_)
+    $err->expect( map { "# $_" } @_ );
 }
 
 =item test_test
@@ -321,24 +316,23 @@ will function normally and cause success/errors for B<Test::Harness>.
 
 =cut
 
-sub test_test
-{
-   # decode the arguements as described in the pod
-   my $mess;
-   my %args;
-   if (@_ == 1)
-     { $mess = shift }
-   else
-   {
-     %args = @_;
-     $mess = $args{name} if exists($args{name});
-     $mess = $args{title} if exists($args{title});
-     $mess = $args{label} if exists($args{label});
-   }
+sub test_test {
+    # decode the arguements as described in the pod
+    my $mess;
+    my %args;
+    if( @_ == 1 ) {
+        $mess = shift
+    }
+    else {
+        %args = @_;
+        $mess = $args{name} if exists( $args{name} );
+        $mess = $args{title} if exists( $args{title} );
+        $mess = $args{label} if exists( $args{label} );
+    }
 
     # er, are we testing?
     croak "Not testing.  You must declare output with a test function first."
-       unless $testing;
+      unless $testing;
 
     # okay, reconnect the test suite back to the saved handles
     $t->output($original_output_handle);
@@ -353,20 +347,20 @@ sub test_test
     $ENV{HARNESS_ACTIVE} = $original_harness_env;
 
     # check the output we've stashed
-    unless ($t->ok(    ($args{skip_out} || $out->check)
-                    && ($args{skip_err} || $err->check),
-                   $mess))
+    unless( $t->ok( ( $args{skip_out} || $out->check ) &&
+                    ( $args{skip_err} || $err->check ), $mess ) 
+    )
     {
-      # print out the diagnostic information about why this
-      # test failed
+        # print out the diagnostic information about why this
+        # test failed
 
-      local $_;
+        local $_;
 
-      $t->diag(map {"$_\n"} $out->complaint)
-       unless $args{skip_out} || $out->check;
+        $t->diag( map { "$_\n" } $out->complaint )
+          unless $args{skip_out} || $out->check;
 
-      $t->diag(map {"$_\n"} $err->complaint)
-       unless $args{skip_err} || $err->check;
+        $t->diag( map { "$_\n" } $err->complaint )
+          unless $args{skip_err} || $err->check;
     }
 }
 
@@ -382,10 +376,9 @@ C<line_num(+3)> idiom is arguably nicer.
 
 =cut
 
-sub line_num
-{
-    my ($package, $filename, $line) = caller;
-    return $line + (shift() || 0); # prevent warnings
+sub line_num {
+    my( $package, $filename, $line ) = caller;
+    return $line + ( shift() || 0 );    # prevent warnings
 }
 
 =back
@@ -431,10 +424,10 @@ the PERL5LIB.
 =cut
 
 my $color;
-sub color
-{
-  $color = shift if @_;
-  $color;
+
+sub color {
+    $color = shift if @_;
+    $color;
 }
 
 =back
@@ -489,21 +482,18 @@ package Test::Builder::Tester::Tie;
 ##
 # add line(s) to be expected
 
-sub expect
-{
+sub expect {
     my $self = shift;
 
     my @checks = @_;
     foreach my $check (@checks) {
         $check = $self->_translate_Failed_check($check);
-        push @{$self->{wanted}}, ref $check ? $check : "$check\n";
+        push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
     }
 }
 
-
-sub _translate_Failed_check
-{
-    my($self, $check) = @_;
+sub _translate_Failed_check {
+    my( $self, $check ) = @_;
 
     if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
@@ -512,21 +502,19 @@ sub _translate_Failed_check
     return $check;
 }
 
-
 ##
 # return true iff the expected data matches the got data
 
-sub check
-{
+sub check {
     my $self = shift;
 
     # turn off warnings as these might be undef
     local $^W = 0;
 
-    my @checks = @{$self->{wanted}};
-    my $got = $self->{got};
+    my @checks = @{ $self->{wanted} };
+    my $got    = $self->{got};
     foreach my $check (@checks) {
-        $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check);
+        $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
         return 0 unless $got =~ s/^$check//;
     }
 
@@ -537,82 +525,71 @@ sub check
 # a complaint message about the inputs not matching (to be
 # used for debugging messages)
 
-sub complaint
-{
-    my $self = shift;
+sub complaint {
+    my $self   = shift;
     my $type   = $self->type;
     my $got    = $self->got;
-    my $wanted = join "\n", @{$self->wanted};
+    my $wanted = join "\n", @{ $self->wanted };
 
     # are we running in colour mode?
-    if (Test::Builder::Tester::color)
-    {
-      # get color
-      eval { require Term::ANSIColor };
-      unless ($@)
-      {
-        # colours
-
-        my $green = Term::ANSIColor::color("black").
-                    Term::ANSIColor::color("on_green");
-        my $red   = Term::ANSIColor::color("black").
-                    Term::ANSIColor::color("on_red");
-        my $reset = Term::ANSIColor::color("reset");
-
-        # work out where the two strings start to differ
-        my $char = 0;
-        $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
-
-        # get the start string and the two end strings
-        my $start     = $green . substr($wanted, 0,   $char);
-        my $gotend    = $red   . substr($got   , $char) . $reset;
-        my $wantedend = $red   . substr($wanted, $char) . $reset;
-
-        # make the start turn green on and off
-        $start =~ s/\n/$reset\n$green/g;
-
-        # make the ends turn red on and off
-        $gotend    =~ s/\n/$reset\n$red/g;
-        $wantedend =~ s/\n/$reset\n$red/g;
-
-        # rebuild the strings
-        $got    = $start . $gotend;
-        $wanted = $start . $wantedend;
-      }
+    if(Test::Builder::Tester::color) {
+        # get color
+        eval { require Term::ANSIColor };
+        unless($@) {
+            # colours
+
+            my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
+            my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
+            my $reset = Term::ANSIColor::color("reset");
+
+            # work out where the two strings start to differ
+            my $char = 0;
+            $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
+
+            # get the start string and the two end strings
+            my $start = $green . substr( $wanted, 0, $char );
+            my $gotend    = $red . substr( $got,    $char ) . $reset;
+            my $wantedend = $red . substr( $wanted, $char ) . $reset;
+
+            # make the start turn green on and off
+            $start =~ s/\n/$reset\n$green/g;
+
+            # make the ends turn red on and off
+            $gotend    =~ s/\n/$reset\n$red/g;
+            $wantedend =~ s/\n/$reset\n$red/g;
+
+            # rebuild the strings
+            $got    = $start . $gotend;
+            $wanted = $start . $wantedend;
+        }
     }
 
-    return "$type is:\n" .
-           "$got\nnot:\n$wanted\nas expected"
+    return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
 }
 
 ##
 # forget all expected and got data
 
-sub reset
-{
+sub reset {
     my $self = shift;
     %$self = (
-              type   => $self->{type},
-              got    => '',
-              wanted => [],
-             );
+        type   => $self->{type},
+        got    => '',
+        wanted => [],
+    );
 }
 
-
-sub got
-{
+sub got {
     my $self = shift;
     return $self->{got};
 }
 
-sub wanted
-{
+sub wanted {
     my $self = shift;
     return $self->{wanted};
 }
 
-sub type
-{
+sub type {
     my $self = shift;
     return $self->{type};
 }
@@ -621,26 +598,24 @@ sub type
 # tie interface
 ###
 
-sub PRINT  {
+sub PRINT {
     my $self = shift;
     $self->{got} .= join '', @_;
 }
 
 sub TIEHANDLE {
-    my($class, $type) = @_;
+    my( $class, $type ) = @_;
 
-    my $self = bless {
-                   type => $type
-               }, $class;
+    my $self = bless { type => $type }, $class;
 
     $self->reset;
 
     return $self;
 }
 
-sub READ {}
-sub READLINE {}
-sub GETC {}
-sub FILENO {}
+sub READ     { }
+sub READLINE { }
+sub GETC     { }
+sub FILENO   { }
 
 1;
index b479e71..27fc868 100644 (file)
@@ -1,4 +1,5 @@
 package Test::Builder::Tester::Color;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder/Tester/Color.pm 67132 2008-10-01T01:11:04.501643Z schwern  $
 
 use strict;
 
@@ -25,8 +26,7 @@ from the command line.
 
 =cut
 
-sub import
-{
+sub import {
     Test::Builder::Tester::color(1);
 }
 
index 5842e05..0186397 100644 (file)
@@ -1,38 +1,40 @@
 package Test::More;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/More.pm 67223 2008-10-15T03:08:18.888155Z schwern  $
 
 use 5.006;
 use strict;
+use warnings;
 
+#---- perlcritic exemptions. ----#
+
+# We use a lot of subroutine prototypes
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
 
 # Can't use Carp because it might cause use_ok() to accidentally succeed
 # even though the module being used forgot to use Carp.  Yes, this
 # actually happened.
 sub _carp {
-    my($file, $line) = (caller(1))[1,2];
-    warn @_, " at $file line $line\n";
+    my( $file, $line ) = ( caller(1) )[ 1, 2 ];
+    return warn @_, " at $file line $line\n";
 }
 
-
-
-use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.80';
-$VERSION = eval $VERSION;    # make the alpha version come out as a number
+our $VERSION = '0.82';
+$VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
 use Test::Builder::Module;
-@ISA    = qw(Test::Builder::Module);
-@EXPORT = qw(ok use_ok require_ok
-             is isnt like unlike is_deeply
-             cmp_ok
-             skip todo todo_skip
-             pass fail
-             eq_array eq_hash eq_set
-             $TODO
-             plan
-             can_ok  isa_ok
-             diag
-             BAIL_OUT
-            );
-
+our @ISA    = qw(Test::Builder::Module);
+our @EXPORT = qw(ok use_ok require_ok
+  is isnt like unlike is_deeply
+  cmp_ok
+  skip todo todo_skip
+  pass fail
+  eq_array eq_hash eq_set
+  $TODO
+  plan
+  can_ok isa_ok new_ok
+  diag note explain
+  BAIL_OUT
+);
 
 =head1 NAME
 
@@ -158,10 +160,9 @@ or for deciding between running the tests at all:
 sub plan {
     my $tb = Test::More->builder;
 
-    $tb->plan(@_);
+    return $tb->plan(@_);
 }
 
-
 # This implements "use Test::More 'no_diag'" but the behavior is
 # deprecated.
 sub import_extra {
@@ -169,7 +170,7 @@ sub import_extra {
     my $list  = shift;
 
     my @other = ();
-    my $idx = 0;
+    my $idx   = 0;
     while( $idx <= $#{$list} ) {
         my $item = $list->[$idx];
 
@@ -184,8 +185,9 @@ sub import_extra {
     }
 
     @$list = @other;
-}
 
+    return;
+}
 
 =head2 Test names
 
@@ -256,10 +258,10 @@ This is the same as Test::Simple's ok() routine.
 =cut
 
 sub ok ($;$) {
-    my($test, $name) = @_;
+    my( $test, $name ) = @_;
     my $tb = Test::More->builder;
 
-    $tb->ok($test, $name);
+    return $tb->ok( $test, $name );
 }
 
 =item B<is>
@@ -325,18 +327,17 @@ function which is an alias of isnt().
 sub is ($$;$) {
     my $tb = Test::More->builder;
 
-    $tb->is_eq(@_);
+    return $tb->is_eq(@_);
 }
 
 sub isnt ($$;$) {
     my $tb = Test::More->builder;
 
-    $tb->isnt_eq(@_);
+    return $tb->isnt_eq(@_);
 }
 
 *isn't = \&isnt;
 
-
 =item B<like>
 
   like( $got, qr/expected/, $test_name );
@@ -370,10 +371,9 @@ diagnostics on failure.
 sub like ($$;$) {
     my $tb = Test::More->builder;
 
-    $tb->like(@_);
+    return $tb->like(@_);
 }
 
-
 =item B<unlike>
 
   unlike( $got, qr/expected/, $test_name );
@@ -386,10 +386,9 @@ given pattern.
 sub unlike ($$;$) {
     my $tb = Test::More->builder;
 
-    $tb->unlike(@_);
+    return $tb->unlike(@_);
 }
 
-
 =item B<cmp_ok>
 
   cmp_ok( $got, $op, $expected, $test_name );
@@ -426,10 +425,9 @@ is()'s use of C<eq> will interfere:
 sub cmp_ok($$$;$) {
     my $tb = Test::More->builder;
 
-    $tb->cmp_ok(@_);
+    return $tb->cmp_ok(@_);
 }
 
-
 =item B<can_ok>
 
   can_ok($module, @methods);
@@ -460,17 +458,17 @@ as one test.  If you desire otherwise, use:
 =cut
 
 sub can_ok ($@) {
-    my($proto, @methods) = @_;
+    my( $proto, @methods ) = @_;
     my $class = ref $proto || $proto;
     my $tb = Test::More->builder;
 
-    unless( $class ) {
+    unless($class) {
         my $ok = $tb->ok( 0, "->can(...)" );
         $tb->diag('    can_ok() called with empty class or reference');
         return $ok;
     }
 
-    unless( @methods ) {
+    unless(@methods) {
         my $ok = $tb->ok( 0, "$class->can(...)" );
         $tb->diag('    can_ok() called with no methods');
         return $ok;
@@ -478,16 +476,15 @@ sub can_ok ($@) {
 
     my @nok = ();
     foreach my $method (@methods) {
-        $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
+        $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
     }
 
-    my $name;
-    $name = @methods == 1 ? "$class->can('$methods[0]')" 
-                          : "$class->can(...)";
+    my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
+                                 "$class->can(...)"           ;
 
     my $ok = $tb->ok( !@nok, $name );
 
-    $tb->diag(map "    $class->can('$_') failed\n", @nok);
+    $tb->diag( map "    $class->can('$_') failed\n", @nok );
 
     return $ok;
 }
@@ -522,7 +519,7 @@ you'd like them to be more specific, you can supply an $object_name
 =cut
 
 sub isa_ok ($$;$) {
-    my($object, $class, $obj_name) = @_;
+    my( $object, $class, $obj_name ) = @_;
     my $tb = Test::More->builder;
 
     my $diag;
@@ -536,15 +533,16 @@ sub isa_ok ($$;$) {
     }
     else {
         # We can't use UNIVERSAL::isa because we want to honor isa() overrides
-        my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
-        if( $error ) {
+        my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
+        if($error) {
             if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
                 # Its an unblessed reference
-                if( !UNIVERSAL::isa($object, $class) ) {
+                if( !UNIVERSAL::isa( $object, $class ) ) {
                     my $ref = ref $object;
                     $diag = "$obj_name isn't a '$class' it's a '$ref'";
                 }
-            } else {
+            }
+            else {
                 die <<WHOA;
 WHOA! I tried to call ->isa on your object and got some weird error.
 Here's the error.
@@ -557,11 +555,9 @@ WHOA
             $diag = "$obj_name isn't a '$class' it's a '$ref'";
         }
     }
-            
-      
 
     my $ok;
-    if( $diag ) {
+    if($diag) {
         $ok = $tb->ok( 0, $name );
         $tb->diag("    $diag\n");
     }
@@ -572,6 +568,49 @@ WHOA
     return $ok;
 }
 
+=item B<new_ok>
+
+  my $obj = new_ok( $class );
+  my $obj = new_ok( $class => \@args );
+  my $obj = new_ok( $class => \@args, $object_name );
+
+A convenience function which combines creating an object and calling
+isa_ok() on that object.
+
+It is basically equivalent to:
+
+    my $obj = $class->new(@args);
+    isa_ok $obj, $class, $object_name;
+
+If @args is not given, an empty list will be used.
+
+This function only works on new() and it assumes new() will return
+just a single object which isa C<$class>.
+
+=cut
+
+sub new_ok {
+    my $tb = Test::More->builder;
+    $tb->croak("new_ok() must be given at least a class") unless @_;
+
+    my( $class, $args, $object_name ) = @_;
+
+    $args ||= [];
+    $object_name = "The object" unless defined $object_name;
+
+    my $obj;
+    my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
+    if($success) {
+        local $Test::Builder::Level = $Test::Builder::Level + 1;
+        isa_ok $obj, $class, $object_name;
+    }
+    else {
+        $tb->ok( 0, "new() died" );
+        $tb->diag("    Error was:  $error");
+    }
+
+    return $obj;
+}
 
 =item B<pass>
 
@@ -592,12 +631,14 @@ Use these very, very, very sparingly.
 
 sub pass (;$) {
     my $tb = Test::More->builder;
-    $tb->ok(1, @_);
+
+    return $tb->ok( 1, @_ );
 }
 
 sub fail (;$) {
     my $tb = Test::More->builder;
-    $tb->ok(0, @_);
+
+    return $tb->ok( 0, @_ );
 }
 
 =back
@@ -652,11 +693,11 @@ because the notion of "compile-time" is relative.  Instead, you want:
 =cut
 
 sub use_ok ($;@) {
-    my($module, @imports) = @_;
+    my( $module, @imports ) = @_;
     @imports = () unless @imports;
     my $tb = Test::More->builder;
 
-    my($pack,$filename,$line) = caller;
+    my( $pack, $filename, $line ) = caller;
 
     my $code;
     if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
@@ -676,11 +717,10 @@ use $module \@{\$args[0]};
 USE
     }
 
-
-    my($eval_result, $eval_error) = _eval($code, \@imports);
+    my( $eval_result, $eval_error ) = _eval( $code, \@imports );
     my $ok = $tb->ok( $eval_result, "use $module;" );
-    
-    unless( $ok ) {
+
+    unless($ok) {
         chomp $eval_error;
         $@ =~ s{^BEGIN failed--compilation aborted at .*$}
                 {BEGIN failed--compilation aborted at $filename line $line.}m;
@@ -694,18 +734,22 @@ DIAGNOSTIC
     return $ok;
 }
 
-
 sub _eval {
-    my($code) = shift;
-    my @args = @_;
+    my( $code, @args ) = @_;
 
     # Work around oddities surrounding resetting of $@ by immediately
     # storing it.
-    local($@,$!,$SIG{__DIE__});   # isolate eval
-    my $eval_result = eval $code;
-    my $eval_error  = $@;
+    my( $sigdie, $eval_result, $eval_error );
+    {
+        local( $@, $!, $SIG{__DIE__} );    # isolate eval
+        $eval_result = eval $code;              ## no critic (BuiltinFunctions::ProhibitStringyEval)
+        $eval_error  = $@;
+        $sigdie      = $SIG{__DIE__} || undef;
+    }
+    # make sure that $code got a chance to set $SIG{__DIE__}
+    $SIG{__DIE__} = $sigdie if defined $sigdie;
 
-    return($eval_result, $eval_error);
+    return( $eval_result, $eval_error );
 }
 
 =item B<require_ok>
@@ -733,10 +777,10 @@ require $module;
 1;
 REQUIRE
 
-    my($eval_result, $eval_error) = _eval($code);
+    my( $eval_result, $eval_error ) = _eval($code);
     my $ok = $tb->ok( $eval_result, "require $module;" );
 
-    unless( $ok ) {
+    unless($ok) {
         chomp $eval_error;
         $tb->diag(<<DIAGNOSTIC);
     Tried to require '$module'.
@@ -748,7 +792,6 @@ DIAGNOSTIC
     return $ok;
 }
 
-
 sub _is_module_name {
     my $module = shift;
 
@@ -756,7 +799,8 @@ sub _is_module_name {
     # End with an alphanumeric.
     # The rest is an alphanumeric or ::
     $module =~ s/\b::\b//g;
-    $module =~ /^[a-zA-Z]\w*$/;
+
+    return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
 }
 
 =back
@@ -794,50 +838,50 @@ along these lines.
 
 =cut
 
-use vars qw(@Data_Stack %Refs_Seen);
+our( @Data_Stack, %Refs_Seen );
 my $DNE = bless [], 'Does::Not::Exist';
 
 sub _dne {
-    ref $_[0] eq ref $DNE;
+    return ref $_[0] eq ref $DNE;
 }
 
-
+## no critic (Subroutines::RequireArgUnpacking)
 sub is_deeply {
     my $tb = Test::More->builder;
 
     unless( @_ == 2 or @_ == 3 ) {
-        my $msg = <<WARNING;
+        my $msg = <<'WARNING';
 is_deeply() takes two or three args, you gave %d.
 This usually means you passed an array or hash instead 
 of a reference to it
 WARNING
-        chop $msg;   # clip off newline so carp() will put in line/file
+        chop $msg;    # clip off newline so carp() will put in line/file
 
         _carp sprintf $msg, scalar @_;
 
-       return $tb->ok(0);
+        return $tb->ok(0);
     }
 
-    my($got, $expected, $name) = @_;
+    my( $got, $expected, $name ) = @_;
 
-    $tb->_unoverload_str(\$expected, \$got);
+    $tb->_unoverload_str( \$expected, \$got );
 
     my $ok;
-    if( !ref $got and !ref $expected ) {               # neither is a reference
-        $ok = $tb->is_eq($got, $expected, $name);
+    if( !ref $got and !ref $expected ) {    # neither is a reference
+        $ok = $tb->is_eq( $got, $expected, $name );
     }
-    elsif( !ref $got xor !ref $expected ) {    # one's a reference, one isn't
-        $ok = $tb->ok(0, $name);
-       $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
+    elsif( !ref $got xor !ref $expected ) {    # one's a reference, one isn't
+        $ok = $tb->ok( 0, $name );
+        $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
     }
-    else {                                     # both references
+    else {                                     # both references
         local @Data_Stack = ();
-        if( _deep_check($got, $expected) ) {
-            $ok = $tb->ok(1, $name);
+        if( _deep_check( $got, $expected ) ) {
+            $ok = $tb->ok( 1, $name );
         }
         else {
-            $ok = $tb->ok(0, $name);
-            $tb->diag(_format_stack(@Data_Stack));
+            $ok = $tb->ok( 0, $name );
+            $tb->diag( _format_stack(@Data_Stack) );
         }
     }
 
@@ -847,11 +891,11 @@ WARNING
 sub _format_stack {
     my(@Stack) = @_;
 
-    my $var = '$FOO';
+    my $var       = '$FOO';
     my $did_arrow = 0;
     foreach my $entry (@Stack) {
         my $type = $entry->{type} || '';
-        my $idx  = $entry->{'idx'};
+        my $idx = $entry->{'idx'};
         if( $type eq 'HASH' ) {
             $var .= "->" unless $did_arrow++;
             $var .= "{$idx}";
@@ -865,18 +909,19 @@ sub _format_stack {
         }
     }
 
-    my @vals = @{$Stack[-1]{vals}}[0,1];
+    my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
     my @vars = ();
-    ($vars[0] = $var) =~ s/\$FOO/     \$got/;
-    ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+    ( $vars[0] = $var ) =~ s/\$FOO/     \$got/;
+    ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
 
     my $out = "Structures begin differing at:\n";
-    foreach my $idx (0..$#vals) {
+    foreach my $idx ( 0 .. $#vals ) {
         my $val = $vals[$idx];
-        $vals[$idx] = !defined $val ? 'undef'          :
-                      _dne($val)    ? "Does not exist" :
-                      ref $val      ? "$val"           :
-                                      "'$val'";
+        $vals[$idx]
+          = !defined $val ? 'undef'
+          : _dne($val)    ? "Does not exist"
+          : ref $val      ? "$val"
+          :                 "'$val'";
     }
 
     $out .= "$vars[0] = $vals[0]\n";
@@ -886,14 +931,13 @@ sub _format_stack {
     return $out;
 }
 
-
 sub _type {
     my $thing = shift;
 
     return '' if !ref $thing;
 
     for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
-        return $type if UNIVERSAL::isa($thing, $type);
+        return $type if UNIVERSAL::isa( $thing, $type );
     }
 
     return '';
@@ -919,6 +963,8 @@ Prints a diagnostic message which is guaranteed not to interfere with
 test output.  Like C<print> @diagnostic_message is simply concatenated
 together.
 
+Returns false, so as to preserve failure.
+
 Handy for this sort of thing:
 
     ok( grep(/foo/, @users), "There's a foo user" ) or
@@ -938,14 +984,49 @@ B<NOTE> The exact formatting of the diagnostic output is still
 changing, but it is guaranteed that whatever you throw at it it won't
 interfere with the test.
 
+=item B<note>
+
+  note(@diagnostic_message);
+
+Like diag(), except the message will not be seen when the test is run
+in a harness.  It will only be visible in the verbose TAP stream.
+
+Handy for putting in notes which might be useful for debugging, but
+don't indicate a problem.
+
+    note("Tempfile is $tempfile");
+
 =cut
 
 sub diag {
-    my $tb = Test::More->builder;
+    return Test::More->builder->diag(@_);
+}
 
-    $tb->diag(@_);
+sub note {
+    return Test::More->builder->note(@_);
 }
 
+=item B<explain>
+
+  my @dump = explain @diagnostic_message;
+
+Will dump the contents of any references in a human readable format.
+Usually you want to pass this into C<note> or C<dump>.
+
+Handy for things like...
+
+    is_deeply($have, $want) || diag explain $have;
+
+or
+
+    note explain \%args;
+    Some::Class->method(%args);
+
+=cut
+
+sub explain {
+    return Test::More->builder->explain(@_);
+}
 
 =back
 
@@ -1009,9 +1090,9 @@ use TODO.  Read on.
 
 =cut
 
-#'#
+## no critic (Subroutines::RequireFinalReturn)
 sub skip {
-    my($why, $how_many) = @_;
+    my( $why, $how_many ) = @_;
     my $tb = Test::More->builder;
 
     unless( defined $how_many ) {
@@ -1022,19 +1103,19 @@ sub skip {
     }
 
     if( defined $how_many and $how_many =~ /\D/ ) {
-        _carp "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
+        _carp
+          "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
         $how_many = 1;
     }
 
-    for( 1..$how_many ) {
+    for( 1 .. $how_many ) {
         $tb->skip($why);
     }
 
-    local $^W = 0;
+    no warnings 'exiting';
     last SKIP;
 }
 
-
 =item B<TODO: BLOCK>
 
     TODO: {
@@ -1097,7 +1178,7 @@ interpret them as passing.
 =cut
 
 sub todo_skip {
-    my($why, $how_many) = @_;
+    my( $why, $how_many ) = @_;
     my $tb = Test::More->builder;
 
     unless( defined $how_many ) {
@@ -1107,11 +1188,11 @@ sub todo_skip {
         $how_many = 1;
     }
 
-    for( 1..$how_many ) {
+    for( 1 .. $how_many ) {
         $tb->todo_skip($why);
     }
 
-    local $^W = 0;
+    no warnings 'exiting';
     last TODO;
 }
 
@@ -1151,7 +1232,7 @@ The test will exit with 255.
 
 sub BAIL_OUT {
     my $reason = shift;
-    my $tb = Test::More->builder;
+    my $tb     = Test::More->builder;
 
     $tb->BAIL_OUT($reason);
 }
@@ -1190,14 +1271,14 @@ multi-level structures are handled correctly.
 
 #'#
 sub eq_array {
-    local @Data_Stack;
+    local @Data_Stack = ();
     _deep_check(@_);
 }
 
-sub _eq_array  {
-    my($a1, $a2) = @_;
+sub _eq_array {
+    my( $a1, $a2 ) = @_;
 
-    if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
+    if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
         warn "eq_array passed a non-array ref";
         return 0;
     }
@@ -1206,12 +1287,12 @@ sub _eq_array  {
 
     my $ok = 1;
     my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
-    for (0..$max) {
+    for( 0 .. $max ) {
         my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
         my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
 
-        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
-        $ok = _deep_check($e1,$e2);
+        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
+        $ok = _deep_check( $e1, $e2 );
         pop @Data_Stack if $ok;
 
         last unless $ok;
@@ -1221,7 +1302,7 @@ sub _eq_array  {
 }
 
 sub _deep_check {
-    my($e1, $e2) = @_;
+    my( $e1, $e2 ) = @_;
     my $tb = Test::More->builder;
 
     my $ok = 0;
@@ -1233,27 +1314,27 @@ sub _deep_check {
 
     {
         # Quiet uninitialized value warnings when comparing undefs.
-        local $^W = 0; 
+        no warnings 'uninitialized';
 
-        $tb->_unoverload_str(\$e1, \$e2);
+        $tb->_unoverload_str( \$e1, \$e2 );
 
         # Either they're both references or both not.
-        my $same_ref = !(!ref $e1 xor !ref $e2);
-       my $not_ref  = (!ref $e1 and !ref $e2);
+        my $same_ref = !( !ref $e1 xor !ref $e2 );
+        my $not_ref = ( !ref $e1 and !ref $e2 );
 
         if( defined $e1 xor defined $e2 ) {
             $ok = 0;
         }
-        elsif ( _dne($e1) xor _dne($e2) ) {
+        elsif( _dne($e1) xor _dne($e2) ) {
             $ok = 0;
         }
-        elsif ( $same_ref and ($e1 eq $e2) ) {
+        elsif( $same_ref and( $e1 eq $e2 ) ) {
             $ok = 1;
         }
-       elsif ( $not_ref ) {
-           push @Data_Stack, { type => '', vals => [$e1, $e2] };
-           $ok = 0;
-       }
+        elsif($not_ref) {
+            push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
+            $ok = 0;
+        }
         else {
             if( $Refs_Seen{$e1} ) {
                 return $Refs_Seen{$e1} eq $e2;
@@ -1266,50 +1347,48 @@ sub _deep_check {
             $type = 'DIFFERENT' unless _type($e2) eq $type;
 
             if( $type eq 'DIFFERENT' ) {
-                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
+                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
                 $ok = 0;
             }
             elsif( $type eq 'ARRAY' ) {
-                $ok = _eq_array($e1, $e2);
+                $ok = _eq_array( $e1, $e2 );
             }
             elsif( $type eq 'HASH' ) {
-                $ok = _eq_hash($e1, $e2);
+                $ok = _eq_hash( $e1, $e2 );
             }
             elsif( $type eq 'REF' ) {
-                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
-                $ok = _deep_check($$e1, $$e2);
+                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
+                $ok = _deep_check( $$e1, $$e2 );
                 pop @Data_Stack if $ok;
             }
             elsif( $type eq 'SCALAR' ) {
-                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
-                $ok = _deep_check($$e1, $$e2);
+                push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
+                $ok = _deep_check( $$e1, $$e2 );
                 pop @Data_Stack if $ok;
             }
-            elsif( $type ) {
-                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
+            elsif($type) {
+                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
                 $ok = 0;
             }
-           else {
-               _whoa(1, "No type in _deep_check");
-           }
+            else {
+                _whoa( 1, "No type in _deep_check" );
+            }
         }
     }
 
     return $ok;
 }
 
-
 sub _whoa {
-    my($check, $desc) = @_;
-    if( $check ) {
-        die <<WHOA;
+    my( $check, $desc ) = @_;
+    if($check) {
+        die <<"WHOA";
 WHOA!  $desc
 This should never happen!  Please contact the author immediately!
 WHOA
     }
 }
 
-
 =item B<eq_hash>
 
   my $is_eq = eq_hash(\%got, \%expected);
@@ -1320,14 +1399,14 @@ is a deep check.
 =cut
 
 sub eq_hash {
-    local @Data_Stack;
+    local @Data_Stack = ();
     return _deep_check(@_);
 }
 
 sub _eq_hash {
-    my($a1, $a2) = @_;
+    my( $a1, $a2 ) = @_;
 
-    if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+    if( grep _type($_) ne 'HASH', $a1, $a2 ) {
         warn "eq_hash passed a non-hash ref";
         return 0;
     }
@@ -1336,12 +1415,12 @@ sub _eq_hash {
 
     my $ok = 1;
     my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
-    foreach my $k (keys %$bigger) {
+    foreach my $k ( keys %$bigger ) {
         my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
         my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
 
-        push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
-        $ok = _deep_check($e1, $e2);
+        push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
+        $ok = _deep_check( $e1, $e2 );
         pop @Data_Stack if $ok;
 
         last unless $ok;
@@ -1376,14 +1455,13 @@ Test::Deep contains much better set comparison functions.
 
 =cut
 
-sub eq_set  {
-    my($a1, $a2) = @_;
+sub eq_set {
+    my( $a1, $a2 ) = @_;
     return 0 unless @$a1 == @$a2;
 
-    # There's faster ways to do this, but this is easiest.
-    local $^W = 0;
+    no warnings 'uninitialized';
 
-    # It really doesn't matter how we sort them, as long as both arrays are 
+    # It really doesn't matter how we sort them, as long as both arrays are
     # sorted with the same algorithm.
     #
     # Ensure that references are not accidentally treated the same as a
@@ -1395,8 +1473,8 @@ sub eq_set  {
     # I don't know how references would be sorted so we just don't sort
     # them.  This means eq_set doesn't really work with refs.
     return eq_array(
-           [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
-           [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
+        [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
+        [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
     );
 }
 
@@ -1522,21 +1600,21 @@ L<Test::Simple> if all this confuses you and you just want to write
 some tests.  You can upgrade to Test::More later (it's forward
 compatible).
 
-L<Test> is the old testing module.  Its main benefit is that it has
-been distributed with Perl since 5.004_05.
+L<Test::Harness> is the test runner and output interpreter for Perl.
+It's the thing that powers C<make test> and where the C<prove> utility
+comes from.
 
-L<Test::Harness> for details on how your test results are interpreted
-by Perl.
+L<Test::Legacy> tests written with Test.pm, the original testing
+module, do not play well with other testing libraries.  Test::Legacy
+emulates the Test.pm interface and does play well with others.
 
 L<Test::Differences> for more ways to test complex data structures.
 And it plays well with Test::More.
 
-L<Test::Class> is like XUnit but more perlish.
+L<Test::Class> is like xUnit but more perlish.
 
 L<Test::Deep> gives you more powerful complex data structure testing.
 
-L<Test::Unit> is XUnit style testing.
-
 L<Test::Inline> shows the idea of embedded testing.
 
 L<Bundle::Test> installs a whole bunch of useful test modules.
@@ -1557,7 +1635,7 @@ See F<http://rt.cpan.org> to report and view bugs.
 
 =head1 COPYRIGHT
 
-Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 
 This program is free software; you can redistribute it and/or
 modify it under the same terms as Perl itself.
index e4799ca..606d7fb 100644 (file)
@@ -1,19 +1,19 @@
 package Test::Simple;
+# $Id: /mirror/googlecode/test-more-trunk/lib/Test/Simple.pm 67223 2008-10-15T03:08:18.888155Z schwern  $
 
 use 5.004;
 
-use strict 'vars';
-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.80';
-$VERSION = eval $VERSION;    # make the alpha version come out as a number
+use strict;
+
+our $VERSION = '0.82';
+$VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
 use Test::Builder::Module;
-@ISA    = qw(Test::Builder::Module);
-@EXPORT = qw(ok);
+our @ISA    = qw(Test::Builder::Module);
+our @EXPORT = qw(ok);
 
 my $CLASS = __PACKAGE__;
 
-
 =head1 NAME
 
 Test::Simple - Basic utilities for writing tests.
@@ -77,11 +77,10 @@ will do what you mean (fail if stuff is empty)
 
 =cut
 
-sub ok ($;$) {
-    $CLASS->builder->ok(@_);
+sub ok ($;$) {    ## no critic (Subroutines::ProhibitSubroutinePrototypes)
+    return $CLASS->builder->ok(@_);
 }
 
-
 =back
 
 Test::Simple will start by printing number of tests run in the form
@@ -191,24 +190,10 @@ Test::More.  Test::Simple is 100% forward compatible with Test::More
 (i.e. you can just use Test::More instead of Test::Simple in your
 programs and things will still work).
 
-=item L<Test>
-
-The original Perl testing module.
-
-=item L<Test::Unit>
-
-Elaborate unit testing.
-
-=item L<Test::Inline>, L<SelfTest>
-
-Embed tests in your code!
-
-=item L<Test::Harness>
-
-Interprets the output of your test program.
-
 =back
 
+Look in Test::More's SEE ALSO for more testing modules.
+
 
 =head1 AUTHORS
 
@@ -218,7 +203,7 @@ E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
 
 =head1 COPYRIGHT
 
-Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
 
 This program is free software; you can redistribute it and/or 
 modify it under the same terms as Perl itself.
index 3ff4a13..ee5c11a 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/00test_harness_check.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # A test to make sure the new Test::Harness was installed properly.
 
index 289ebc5..a06ca1b 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/BEGIN_require_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 26caaa1..d6baefe 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/BEGIN_use_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # [rt.cpan.org 28345]
 #
similarity index 86%
rename from lib/Test/Simple/t/Builder.t
rename to lib/Test/Simple/t/Builder/Builder.t
index a5bfd15..24e395c 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/Builder.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 85%
rename from lib/Test/Simple/t/carp.t
rename to lib/Test/Simple/t/Builder/carp.t
index e89eeeb..a390aa6 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Builder/carp.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 89%
rename from lib/Test/Simple/t/create.t
rename to lib/Test/Simple/t/Builder/create.t
index 5600d68..d923227 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/create.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 #!perl -w
 
similarity index 71%
rename from lib/Test/Simple/t/curr_test.t
rename to lib/Test/Simple/t/Builder/curr_test.t
index edd201c..9607db3 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/curr_test.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 # Dave Rolsky found a bug where if current_test() is used and no
 # tests are run via Test::Builder it will blow up.
similarity index 96%
rename from lib/Test/Simple/t/details.t
rename to lib/Test/Simple/t/Builder/details.t
index bd0ea9b..0f3c31d 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/details.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 78%
rename from lib/Test/Simple/t/has_plan.t
rename to lib/Test/Simple/t/Builder/has_plan.t
index d0be86a..9c8ae59 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/has_plan.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 77%
rename from lib/Test/Simple/t/has_plan2.t
rename to lib/Test/Simple/t/Builder/has_plan2.t
index e13ea4a..eaceeca 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/has_plan2.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 90%
rename from lib/Test/Simple/t/is_fh.t
rename to lib/Test/Simple/t/Builder/is_fh.t
index 0eb3ec0..ab8b887 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/is_fh.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 92%
rename from lib/Test/Simple/t/maybe_regex.t
rename to lib/Test/Simple/t/Builder/maybe_regex.t
index d1927a5..5741220 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/maybe_regex.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 59%
rename from lib/Test/Simple/t/no_diag.t
rename to lib/Test/Simple/t/Builder/no_diag.t
index 6fa538a..07cb3ba 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/no_diag.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 use Test::More 'no_diag', tests => 2;
 
similarity index 76%
rename from lib/Test/Simple/t/no_ending.t
rename to lib/Test/Simple/t/Builder/no_ending.t
index 97e968e..fe3edec 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/Builder/no_ending.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 use Test::Builder;
 
 BEGIN {
similarity index 74%
rename from lib/Test/Simple/t/no_header.t
rename to lib/Test/Simple/t/Builder/no_header.t
index 93e6bec..3992f0f 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/Builder/no_header.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
similarity index 82%
rename from lib/Test/Simple/t/ok_obj.t
rename to lib/Test/Simple/t/Builder/ok_obj.t
index 8678dbf..9dc658a 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/ok_obj.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 # Testing to make sure Test::Builder doesn't accidentally store objects
 # passed in as test arguments.
similarity index 94%
rename from lib/Test/Simple/t/output.t
rename to lib/Test/Simple/t/Builder/output.t
index 598d805..4dc0d2e 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/output.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 95%
rename from lib/Test/Simple/t/reset.t
rename to lib/Test/Simple/t/Builder/reset.t
index 5a7b07f..5284fb3 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/reset.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 # Test Test::Builder->reset;
 
similarity index 82%
rename from lib/Test/Simple/t/try.t
rename to lib/Test/Simple/t/Builder/try.t
index 6e753a4..87a903f 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/Builder/try.t 60332 2008-09-09T12:24:03.060291Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -32,4 +33,4 @@ is_deeply [$tb->_try(sub { die "Foo\n" }, undef)],
           [undef, "Foo\n"];
 
 is $@, 42;
-cmp_ok $!, '==', 23;
\ No newline at end of file
+cmp_ok $!, '==', 23;
index eabd0fa..c84bf2c 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/More.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
similarity index 84%
rename from lib/Test/Simple/t/tbt_01basic.t
rename to lib/Test/Simple/t/Tester/tbt_01basic.t
index 769a1c4..575a92b 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_01basic.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::Builder::Tester tests => 9;
 use Test::More;
@@ -22,7 +23,7 @@ ok(2,"two");
 test_test("multiple tests");
 
 test_out("not ok 1 - should fail");
-test_err("#     Failed test ($0 at line 28)");
+test_err("#     Failed test ($0 at line 29)");
 test_err("#          got: 'foo'");
 test_err("#     expected: 'bar'");
 is("foo","bar","should fail");
@@ -46,7 +47,7 @@ test_test("testing failing on the same line with the same name");
 
 
 test_out("not ok 1 - name # TODO Something");
-test_err("#     Failed (TODO) test ($0 at line 52)");
+test_err("#     Failed (TODO) test ($0 at line 53)");
 TODO: { 
     local $TODO = "Something";
     fail("name");
similarity index 91%
rename from lib/Test/Simple/t/tbt_02fhrestore.t
rename to lib/Test/Simple/t/Tester/tbt_02fhrestore.t
index e373571..398ac0e 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_02fhrestore.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::Builder::Tester tests => 4;
 use Test::More;
similarity index 68%
rename from lib/Test/Simple/t/tbt_03die.t
rename to lib/Test/Simple/t/Tester/tbt_03die.t
index b9dba80..5657f2a 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_03die.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::Builder::Tester tests => 1;
 use Test::More;
diff --git a/lib/Test/Simple/t/Tester/tbt_04line_num.t b/lib/Test/Simple/t/Tester/tbt_04line_num.t
new file mode 100644 (file)
index 0000000..1988b2d
--- /dev/null
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_04line_num.t 60331 2008-09-09T12:17:12.607612Z schwern  $
+
+use Test::More tests => 3;
+use Test::Builder::Tester;
+
+is(line_num(),7,"normal line num");
+is(line_num(-1),7,"line number minus one");
+is(line_num(+2),11,"line number plus two");
similarity index 88%
rename from lib/Test/Simple/t/tbt_05faildiag.t
rename to lib/Test/Simple/t/Tester/tbt_05faildiag.t
index 59ad721..ffeb5d5 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_05faildiag.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::Builder::Tester tests => 5;
 use Test::More;
similarity index 96%
rename from lib/Test/Simple/t/tbt_06errormess.t
rename to lib/Test/Simple/t/Tester/tbt_06errormess.t
index d8d8a0f..da3bbef 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_06errormess.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::More tests => 8;
 use Symbol;
similarity index 98%
rename from lib/Test/Simple/t/tbt_07args.t
rename to lib/Test/Simple/t/Tester/tbt_07args.t
index 1b9393b..ac5f414 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/Tester/tbt_07args.t 60331 2008-09-09T12:17:12.607612Z schwern  $
 
 use Test::More tests => 18;
 use Symbol;
index 442fee8..10207b4 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/bad_plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index d60c150..4af221b 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/bail_out.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 6039e4a..1fdc930 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl
+# $Id: /mirror/googlecode/test-more/t/buffer.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 2fd819e..4f41ae1 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/circular_data.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # Test is_deeply and friends with circular data structures [rt.cpan.org 7289]
 
index b3642ad..38d412d 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/cmp_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index b5e5876..567671e 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/diag.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
diff --git a/lib/Test/Simple/t/died.t b/lib/Test/Simple/t/died.t
new file mode 100644 (file)
index 0000000..6e4d40c
--- /dev/null
@@ -0,0 +1,46 @@
+#!perl -w
+# $Id: /mirror/googlecode/test-more/t/died.t 60310 2008-09-07T23:47:22.837229Z schwern  $
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+# Can't use Test.pm, that's a 5.005 thing.
+package My::Test;
+
+# This has to be a require or else the END block below runs before
+# Test::Builder's own and the ending diagnostics don't come out right.
+require Test::Builder;
+my $TB = Test::Builder->create;
+$TB->plan(tests => 3);
+
+
+package main;
+
+require Test::Simple;
+
+chdir 't';
+push @INC, '../t/lib/';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+local $ENV{HARNESS_ACTIVE} = 0;
+
+Test::Simple->import(tests => 1);
+exit 250;
+
+END {
+    $TB->is_eq($out->read, <<OUT);
+1..1
+OUT
+
+    $TB->is_eq($err->read, <<ERR);
+# Looks like your test exited with 250 before it could output anything.
+ERR
+
+    $TB->is_eq($?, 250, "exit code");
+
+    exit grep { !$_ } $TB->summary;
+}
index 0657a06..4c0968f 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/dont_overwrite_die_handler.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index fbdc52d..bd04f78 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/eq_set.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index e85e460..fe53cbb 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/exit.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # Can't use Test.pm, that's a 5.005 thing.
 package My::Test;
@@ -64,13 +65,13 @@ else {
     *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
 }
 
+my $Perl = File::Spec->rel2abs($^X);
+
 chdir 't';
 my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
 while( my($test_name, $exit_codes) = each %Tests ) {
     my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0];
 
-    my $Perl = $^X;
-
     if( $^O eq 'VMS' ) {
         # VMS can't use its own $^X in a system call until almost 5.8
         $Perl = "MCR $^X" if $] < 5.007003;
diff --git a/lib/Test/Simple/t/explain.t b/lib/Test/Simple/t/explain.t
new file mode 100644 (file)
index 0000000..f623ef4
--- /dev/null
@@ -0,0 +1,28 @@
+#!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/explain.t 60308 2008-09-07T22:36:18.175234Z schwern  $
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+can_ok "main", "explain";
+
+is_deeply [explain("foo")],             ["foo"];
+is_deeply [explain("foo", "bar")],      ["foo", "bar"];
+
+# Avoid future dump formatting changes from breaking tests by just eval'ing
+# the dump
+is_deeply [map { eval $_ } explain([], {})],           [[], {}];
+
+is_deeply [map { eval $_ } explain(23, [42,91], 99)],  [23, [42, 91], 99];
index 6a0082f..0fcc0ee 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/extra.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -51,7 +52,7 @@ OUT
 #   at $0 line 31.
 #   Failed test 'Sar'
 #   at $0 line 34.
-# Looks like you planned 3 tests but ran 2 extra.
+# Looks like you planned 3 tests but ran 5.
 # Looks like you failed 2 tests of 5 run.
 ERR
 
index 30830d3..211d97b 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/extra_one.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -44,7 +45,7 @@ ok 3
 OUT
 
     My::Test::is($$err, <<ERR);
-# Looks like you planned 1 test but ran 2 extra.
+# Looks like you planned 1 test but ran 3.
 ERR
 
     # Prevent Test::Simple from existing with non-zero
index dea03e8..09b82a5 100644 (file)
@@ -1,11 +1,5 @@
-# qr// was introduced in 5.004-devel.  Skip this test if we're not
-# of high enough version.
-BEGIN { 
-    if( $] < 5.005 ) {
-        print "1..0 # Skipped Test requires qr//\n";
-        exit(0);
-    }
-}
+#!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/fail-like.t 60310 2008-09-07T23:47:22.837229Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -30,7 +24,7 @@ package My::Test;
 # Test::Builder's own and the ending diagnostics don't come out right.
 require Test::Builder;
 my $TB = Test::Builder->create;
-$TB->plan(tests => 2);
+$TB->plan(tests => 4);
 
 
 require Test::Simple::Catch;
@@ -43,11 +37,10 @@ package main;
 require Test::More;
 Test::More->import(tests => 1);
 
-eval q{ like( "foo", qr/that/, 'is foo like that' ); };
-
+{
+    eval q{ like( "foo", qr/that/, 'is foo like that' ); };
 
-END {
-    $TB->is_eq($$out, <<OUT, 'failing output');
+    $TB->is_eq($out->read, <<OUT, 'failing output');
 1..1
 not ok 1 - is foo like that
 OUT
@@ -57,11 +50,26 @@ OUT
 #   at .* line 1\.
 #                   'foo'
 #     doesn't match '\\(\\?-xism:that\\)'
-# Looks like you failed 1 test of 1\\.
 ERR
 
+    $TB->like($err->read, qr/^$err_re$/, 'failing errors');
+}
 
-    $TB->like($$err, qr/^$err_re$/, 'failing errors');
+{
+    # line 60
+    like("foo", "not a regex");
+    $TB->is_eq($out->read, <<OUT);
+not ok 2
+OUT
 
-    exit(0);
+    $TB->is_eq($err->read, <<OUT);
+#   Failed test at $0 line 60.
+#     'not a regex' doesn't look much like a regex to me.
+OUT
+
+}
+
+END {
+    # Test::More thinks it failed.  Override that.
+    exit(scalar grep { !$_ } $TB->summary);
 }
index 23bfd21..95b04b4 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/fail-more.t 60310 2008-09-07T23:47:22.837229Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -24,7 +25,7 @@ package My::Test;
 # Test::Builder's own and the ending diagnostics don't come out right.
 require Test::Builder;
 my $TB = Test::Builder->create;
-$TB->plan(tests => 17);
+$TB->plan(tests => 23);
 
 sub like ($$;$) {
     $TB->like(@_);
@@ -41,11 +42,18 @@ sub main::err_ok ($) {
     return $TB->is_eq( $got, $expect );
 }
 
+sub main::err_like ($) {
+    my($expect) = @_;
+    my $got = $err->read;
+
+    return $TB->like( $got, qr/$expect/ );
+}
+
 
 package main;
 
 require Test::More;
-my $Total = 30;
+my $Total = 36;
 Test::More->import(tests => $Total);
 
 # This should all work in the presence of a __DIE__ handler.
@@ -96,19 +104,16 @@ isnt(undef, undef, 'undef isnt undef?');
 err_ok( <<ERR );
 #   Failed test 'foo isnt foo?'
 #   at $0 line 45.
-#     'foo'
-#         ne
-#     'foo'
+#          got: 'foo'
+#     expected: anything else
 #   Failed test 'foo isn\'t foo?'
 #   at $0 line 46.
-#     'foo'
-#         ne
-#     'foo'
+#          got: 'foo'
+#     expected: anything else
 #   Failed test 'undef isnt undef?'
 #   at $0 line 47.
-#     undef
-#         ne
-#     undef
+#          got: undef
+#     expected: anything else
 ERR
 
 #line 48
@@ -183,6 +188,60 @@ err_ok( <<ERR );
 #     The object isn't a 'HASH' it's a 'ARRAY'
 ERR
 
+
+#line 188
+new_ok(undef);
+err_like( <<ERR );
+#   Failed test 'new\\(\\) died'
+#   at $Filename line 188.
+#     Error was:  Can't call method "new" on an undefined value at .*
+ERR
+
+#line 211
+new_ok( "Does::Not::Exist" );
+err_like( <<ERR );
+#   Failed test 'new\\(\\) died'
+#   at $Filename line 211.
+#     Error was:  Can't locate object method "new" via package "Does::Not::Exist" .*
+ERR
+
+{ package Foo; sub new { } }
+{ package Bar; sub new { {} } }
+{ package Baz; sub new { bless {}, "Wibble" } }
+
+#line 219
+new_ok( "Foo" );
+err_ok( <<ERR );
+#   Failed test 'The object isa Foo'
+#   at $0 line 219.
+#     The object isn't defined
+ERR
+
+# line 231
+new_ok( "Bar" );
+err_ok( <<ERR );
+#   Failed test 'The object isa Bar'
+#   at $0 line 231.
+#     The object isn't a 'Bar' it's a 'HASH'
+ERR
+
+#line 239
+new_ok( "Baz" );
+err_ok( <<ERR );
+#   Failed test 'The object isa Baz'
+#   at $0 line 239.
+#     The object isn't a 'Baz' it's a 'Wibble'
+ERR
+
+#line 247
+new_ok( "Baz", [], "no args" );
+err_ok( <<ERR );
+#   Failed test 'no args isa Baz'
+#   at $0 line 247.
+#     no args isn't a 'Baz' it's a 'Wibble'
+ERR
+
+
 #line 68
 cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' );
 cmp_ok( 42.1,  '==', 23,  , '       ==' );
@@ -199,9 +258,8 @@ err_ok( <<ERR );
 #     expected: 23
 #   Failed test '       !='
 #   at $0 line 70.
-#     '42'
-#         !=
-#     '42'
+#          got: 42
+#     expected: anything else
 #   Failed test '       &&'
 #   at $0 line 71.
 #     '1'
@@ -305,6 +363,12 @@ not ok - The object isa Wibble
 not ok - My Wibble isa Wibble
 not ok - Another Wibble isa Wibble
 not ok - The object isa HASH
+not ok - new() died
+not ok - new() died
+not ok - The object isa Foo
+not ok - The object isa Bar
+not ok - The object isa Baz
+not ok - no args isa Baz
 not ok - cmp_ok eq
 not ok -        ==
 not ok -        !=
index 6be1118..70a2f50 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/fail.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 46b181d..8ce1398 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/fail_one.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index f7dad5d..9fef683 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/filehandles.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 55d7aec..d9a591f 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/fork.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 7b027a7..cbaafac 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/harness_active.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 68a3613..5d22d40 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/import.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index 56515f9..c2bff0f 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/is_deeply_dne_bug.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # test for rt.cpan.org 20768
 #
index a28b24c..e374658 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/is_deeply_fail.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index e7867a5..e03e953 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more-trunk/t/is_deeply_with_threads.t 60989 2008-09-10T03:05:54.548376Z schwern  $
 
 # Test to see if is_deeply() plays well with threads.
 
@@ -19,12 +20,12 @@ BEGIN {
     unless ( $] >= 5.008001 && $Config{'useithreads'} && 
              eval { require threads; 'threads'->import; 1; }) 
     {
-        print "1..0 # Skip: no working threads\n";
+        print "1..0 # Skip no working threads\n";
         exit 0;
     }
     
     unless ( $ENV{AUTHOR_TESTING} ) {
-        print "1..0 # Skip: many perls have broken threads.  Enable with AUTHOR_TESTING.\n";
+        print "1..0 # Skip many perls have broken threads.  Enable with AUTHOR_TESTING.\n";
         exit 0;
     }
 }
index 5e5b439..5eb9157 100644 (file)
@@ -1,5 +1,6 @@
 package Dummy;
+# $Id: /mirror/googlecode/test-more/t/lib/Dummy.pm 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 $VERSION = '0.01';
 
-1;
\ No newline at end of file
+1;
index 91632e9..07b1dbe 100644 (file)
@@ -1,11 +1,11 @@
 package Overloaded;
+# $Id: /mirror/googlecode/test-more-trunk/t/lib/MyOverload.pm 67132 2008-10-01T01:11:04.501643Z schwern  $
 
 sub new {
     my $class = shift;
     bless { string => shift, num => shift }, $class;
 }
 
-
 package Overloaded::Compare;
 use vars qw(@ISA);
 @ISA = qw(Overloaded);
@@ -13,17 +13,15 @@ use vars qw(@ISA);
 # Sometimes objects have only comparison ops overloaded and nothing else.
 # For example, DateTime objects.
 use overload
-        q{eq}   => sub { $_[0]->{string} eq $_[1] },
-        q{==}   => sub { $_[0]->{num}    == $_[1] };
-
-
+  q{eq} => sub { $_[0]->{string} eq $_[1] },
+  q{==} => sub { $_[0]->{num} == $_[1] };
 
 package Overloaded::Ify;
 use vars qw(@ISA);
 @ISA = qw(Overloaded);
 
 use overload
-        q{""}    => sub { $_[0]->{string} },
-        q{0+}    => sub { $_[0]->{num} };
+  q{""} => sub { $_[0]->{string} },
+  q{0+} => sub { $_[0]->{num} };
 
-1;
\ No newline at end of file
+1;
index 1ab5b8f..5eb2b3b 100644 (file)
@@ -1,7 +1,9 @@
 package NoExporter;
+# $Id: /mirror/googlecode/test-more-trunk/t/lib/NoExporter.pm 67132 2008-10-01T01:11:04.501643Z schwern  $
 
 $VERSION = 1.02;
-sub import { 
+
+sub import {
     shift;
     die "NoExporter exports nothing.  You asked for: @_" if @_;
 }
index 7912137..cb46aff 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/missing.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
@@ -33,19 +34,23 @@ Test::Simple->import(tests => 5);
 #line 30
 ok(1, 'Foo');
 ok(0, 'Bar');
+ok(1, '1 2 3');
 
 END {
     My::Test::is($$out, <<OUT);
 1..5
 ok 1 - Foo
 not ok 2 - Bar
+ok 3 - 1 2 3
 OUT
 
     My::Test::is($$err, <<ERR);
 #   Failed test 'Bar'
 #   at $0 line 31.
-# Looks like you planned 5 tests but only ran 2.
-# Looks like you failed 1 test of 2 run.
+#     You named your test '1 2 3'.  You shouldn't use numbers for your test names.
+#     Very confusing.
+# Looks like you planned 5 tests but ran 3.
+# Looks like you failed 1 test of 3 run.
 ERR
 
     exit 0;
diff --git a/lib/Test/Simple/t/new_ok.t b/lib/Test/Simple/t/new_ok.t
new file mode 100644 (file)
index 0000000..d53f535
--- /dev/null
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More tests => 13;
+
+{
+    package Bar;
+
+    sub new {
+        my $class = shift;
+        return bless {@_}, $class;
+    }
+
+
+    package Foo;
+    our @ISA = qw(Bar);
+}
+
+{
+    my $obj = new_ok("Foo");
+    is_deeply $obj, {};
+    isa_ok $obj, "Foo";
+
+    $obj = new_ok("Bar");
+    is_deeply $obj, {};
+    isa_ok $obj, "Bar";
+
+    $obj = new_ok("Foo", [this => 42]);
+    is_deeply $obj, { this => 42 };
+    isa_ok $obj, "Foo";
+
+    $obj = new_ok("Foo", [], "Foo");
+    is_deeply $obj, {};
+    isa_ok $obj, "Foo";
+}
+
+# And what if we give it nothing?
+eval {
+    new_ok();
+};
+is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2;
index 6eecd43..a97f65f 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/no_plan.t 60319 2008-09-08T21:16:57.125001Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -10,7 +11,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 6;
+use Test::More tests => 9;
 
 my $tb = Test::Builder->create;
 $tb->level(0);
@@ -23,6 +24,16 @@ is($@, "Got an undefined number of tests at $0 line 19.\n");
 ok !eval { $tb->plan(tests => 0) };
 is($@, "You said to run 0 tests at $0 line 23.\n");
 
-#line 27
+#line 28
 ok !eval { $tb->ok(1) };
-is( $@, "You tried to run a test without a plan at $0 line 27.\n");
+is( $@, "You tried to run a test without a plan at $0 line 28.\n");
+
+{
+    my $warning = '';
+    local $SIG{__WARN__} = sub { $warning .= join '', @_ };
+
+#line 36
+    ok $tb->plan(no_plan => 1);
+    is( $warning, "no_plan takes no arguments at $0 line 36.\n" );
+    is $tb->has_plan, 'no_plan';
+}
diff --git a/lib/Test/Simple/t/no_tests.t b/lib/Test/Simple/t/no_tests.t
new file mode 100644 (file)
index 0000000..5e6e86b
--- /dev/null
@@ -0,0 +1,45 @@
+#!perl -w
+# $Id: /mirror/googlecode/test-more/t/no_tests.t 60310 2008-09-07T23:47:22.837229Z schwern  $
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+# Can't use Test.pm, that's a 5.005 thing.
+package My::Test;
+
+# This has to be a require or else the END block below runs before
+# Test::Builder's own and the ending diagnostics don't come out right.
+require Test::Builder;
+my $TB = Test::Builder->create;
+$TB->plan(tests => 3);
+
+
+package main;
+
+require Test::Simple;
+
+chdir 't';
+push @INC, '../t/lib/';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
+local $ENV{HARNESS_ACTIVE} = 0;
+
+Test::Simple->import(tests => 1);
+
+END {
+    $TB->is_eq($out->read, <<OUT);
+1..1
+OUT
+
+    $TB->is_eq($err->read, <<ERR);
+# No tests run!
+ERR
+
+    $TB->is_eq($?, 255, "exit code");
+
+    exit grep { !$_ } $TB->summary;
+}
diff --git a/lib/Test/Simple/t/note.t b/lib/Test/Simple/t/note.t
new file mode 100644 (file)
index 0000000..2a72b5d
--- /dev/null
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/note.t 60308 2008-09-07T22:36:18.175234Z schwern  $
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use warnings;
+
+use TieOut;
+
+use Test::More tests => 2;
+
+{
+    my $test = Test::More->builder;
+
+    my $output          = tie *FAKEOUT, "TieOut";
+    my $fail_output     = tie *FAKEERR, "TieOut";
+    $test->output        (*FAKEOUT);
+    $test->failure_output(*FAKEERR);
+
+    note("foo");
+
+    $test->reset_outputs;
+
+    is $output->read,      "# foo\n";
+    is $fail_output->read, '';
+}
+
index d5e4c10..0ac5f0e 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/overload.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 8ba78c1..d02c504 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/overload_threads.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 0d3ce89..7ccca6d 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index d20797e..c93c214 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/plan_bad.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -8,7 +9,7 @@ BEGIN {
 }
 
 
-use Test::More tests => 10;
+use Test::More tests => 12;
 use Test::Builder;
 my $tb = Test::Builder->create;
 $tb->level(0);
@@ -21,6 +22,9 @@ my @foo = ($foo, 2, 3);
 ok !eval { $tb->plan( tests => @foo ) };
 is $@, sprintf "Number of tests must be a positive integer.  You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1;
 
+ok !eval { $tb->plan( tests => 9.99 ) };
+is $@, sprintf "Number of tests must be a positive integer.  You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1;
+
 #line 25
 ok !eval { $tb->plan( tests => -1 ) };
 is $@, "Number of tests must be a positive integer.  You gave it '-1' at $0 line 25.\n";
index e39cd40..d11c437 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/plan_is_noplan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index 3111592..2935b1b 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/plan_no_plan.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index b6eb064..bd320fa 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/plan_shouldnt_import.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 # plan() used to export functions by mistake [rt.cpan.org 8385]
 
index 528df5f..99ce9d7 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/plan_skip_all.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index 463a007..6d0bfd0 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/require_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 7297e9d..276924c 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/simple.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index b7ec32a..e199b11 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more/t/skip.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index 6f255e2..b0c476b 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/skipall.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index f5ad001..4908a3c 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/tbm_doesnt_set_exported_to.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -21,4 +22,4 @@ $TB->level(0);
 $TB->is_eq( Test::Builder::Module->builder->exported_to,
             undef,
             'using Test::Builder::Module does not set exported_to()'
-);
\ No newline at end of file
+);
diff --git a/lib/Test/Simple/t/tbt_04line_num.t b/lib/Test/Simple/t/tbt_04line_num.t
deleted file mode 100644 (file)
index 9e8365a..0000000
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/usr/bin/perl
-
-use Test::More tests => 3;
-use Test::Builder::Tester;
-
-is(line_num(),6,"normal line num");
-is(line_num(-1),6,"line number minus one");
-is(line_num(+2),10,"line number plus two");
index d547e6d..f3b8ad8 100644 (file)
@@ -1,5 +1,6 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/thread_taint.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 use Test::More tests => 1;
 
-ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' );
\ No newline at end of file
+ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' );
index 42ba8c2..1daec94 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/threads.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index d589c92..8a30ad1 100644 (file)
@@ -1,4 +1,5 @@
 #!perl -w
+# $Id: /mirror/googlecode/test-more-trunk/t/todo.t 62094 2008-09-19T07:21:50.720642Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -9,7 +10,7 @@ BEGIN {
 
 use Test::More;
 
-plan tests => 19;
+plan tests => 36;
 
 
 $Why = 'Just testing the todo interface.';
@@ -69,20 +70,89 @@ TODO: {
         # perl gets the line number a little wrong on the first
         # statement inside a block.
         1 == 1;
-#line 73
+#line 74
         todo_skip "Just testing todo_skip";
         fail("So very failed");
     }
     is( $warning, "todo_skip() needs to know \$how_many tests are in the ".
-                  "block at $0 line 73\n",
+                  "block at $0 line 74\n",
         'todo_skip without $how_many warning' );
 }
 
-
+my $builder = Test::More->builder;
+my $exported_to = $builder->exported_to;
 TODO: {
-    Test::More->builder->exported_to("Wibble");
+    $builder->exported_to("Wibble");
     
     local $TODO = "testing \$TODO with an incorrect exported_to()";
     
     fail("Just testing todo");
 }
+
+$builder->exported_to($exported_to);
+
+$builder->todo_start('Expected failures');
+fail('Testing todo_start()');
+ok 0, 'Testing todo_start() with more than one failure';
+$is_todo = $builder->todo;
+$builder->todo_end;
+is $is_todo, 'Expected failures',
+  'todo_start should have the correct TODO message';
+ok 1, 'todo_end() should not leak TODO behavior';
+
+my @nested_todo;
+my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' );
+TODO: {
+    local $TODO = 'Nesting TODO';
+    fail('fail 1');
+
+    $builder->todo_start($level1);
+    fail('fail 2');
+
+    push @nested_todo => $builder->todo;
+    $builder->todo_start($level2);
+    fail('fail 3');
+
+    push @nested_todo => $builder->todo;
+    $builder->todo_end;
+    fail('fail 4');
+
+    push @nested_todo => $builder->todo;
+    $builder->todo_end;
+    $is_todo = $builder->todo;
+    fail('fail 4');
+}
+is_deeply \@nested_todo, [ $level1, $level2, $level1 ],
+  'Nested TODO message should be correct';
+is $is_todo, 'Nesting TODO',
+  '... and original TODO message should be correct';
+
+{
+    $builder->todo_start;
+    fail("testing todo_start() with no message");
+    my $reason  = $builder->todo;
+    my $in_todo = $builder->in_todo;
+    $builder->todo_end;
+
+    is $reason, '', "  todo() reports no reason";
+    ok $in_todo,    "  but we're in_todo()";
+}
+
+eval {
+    $builder->todo_end;
+};
+is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2;
+
+
+{
+    my($reason, $in_todo);
+
+    TODO: {
+        local $TODO = '';
+        $reason  = $builder->todo;
+        $in_todo = $builder->in_todo;
+    }
+
+    is $reason, '';
+    ok !$in_todo, '$TODO = "" is not considered TODO';
+}
index 7afb2a6..93c77bd 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/undef.t 60310 2008-09-07T23:47:22.837229Z schwern  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -11,7 +12,7 @@ BEGIN {
 }
 
 use strict;
-use Test::More tests => 18;
+use Test::More tests => 20;
 use TieOut;
 
 BEGIN { $^W = 1; }
@@ -48,6 +49,9 @@ no_warnings;
 isnt( undef, '',            'undef isnt an empty string' );
 isnt( undef, 0,             'undef isnt zero' );
 
+Test::More->builder->is_num(undef, undef, 'is_num()');
+Test::More->builder->isnt_num(23, undef,  'isnt_num()');
+
 #line 45
 like( undef, '/.*/',        'undef is like anything' );
 warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n");
index b618acc..9781ac8 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/use_ok.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -10,7 +11,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 13;
+use Test::More tests => 15;
 
 # Using Symbol because it's core and exports lots of stuff.
 {
@@ -58,3 +59,10 @@ use Test::More tests => 13;
     };
     ::use_ok("Test::More", 0.47);
 }
+
+{
+    package Foo::eight;
+    local $SIG{__DIE__};
+    ::use_ok("SigDie");
+    ::ok(defined $SIG{__DIE__}, '  SIG{__DIE__} preserved');
+}
index c4ce507..f67ecd8 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/t/useing.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 BEGIN {
     if( $ENV{PERL_CORE} ) {
         chdir 't';
index c7e93c3..544ad1c 100644 (file)
@@ -1,4 +1,5 @@
 #!/usr/bin/perl -w
+# $Id: /mirror/googlecode/test-more/t/utf8.t 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
index b730918..4de4a90 100644 (file)
@@ -1,3 +1,4 @@
+# $Id: /mirror/googlecode/test-more/lib/Test/Tutorial.pod 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51  $
 =head1 NAME
 
 Test::Tutorial - A tutorial about writing really basic tests