Upgrade to Test::Simple 0.53

p4raw-id: //depot/perl@23566

1 files changed, 155 insertions, 47 deletions

diff --git a/lib/Test/More.pm b/lib/Test/More.pm
index 5ca95e67b3..8f029e6f1b 100644
--- a/lib/Test/More.pm
+++ b/lib/Test/More.pm
@@ -18,7 +18,9 @@ sub _carp {
 
 require Exporter;
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.50';
+$VERSION = '0.53';
+$VERSION = eval $VERSION;    # make the alpha version come out as a number
+
 @ISA    = qw(Exporter);
 @EXPORT = qw(ok use_ok require_ok
              is isnt like unlike is_deeply
@@ -177,36 +179,51 @@ or for deciding between running the tests at all:
 sub plan {
     my(@plan) = @_;
 
-    my $caller = caller;
-
-    $Test->exported_to($caller);
-
-    my @cleaned_plan;
-    my @imports = ();
     my $idx = 0;
+    my @cleaned_plan;
     while( $idx <= $#plan ) {
-        if( $plan[$idx] eq 'import' ) {
-            @imports = @{$plan[$idx+1]};
-            $idx += 2;
-        }
-        elsif( $plan[$idx] eq 'no_diag' ) {
+        my $item = $plan[$idx];
+
+        if( $item eq 'no_diag' ) {
             $Show_Diag = 0;
-            $idx++;
         }
         else {
-            push @cleaned_plan, $plan[$idx];
-            $idx++;
+            push @cleaned_plan, $item;
         }
+
+        $idx++;
     }
 
     $Test->plan(@cleaned_plan);
-
-    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
 }
 
 sub import {
     my($class) = shift;
-    goto &plan;
+
+    my $caller = caller;
+
+    $Test->exported_to($caller);
+
+    my $idx = 0;
+    my @plan;
+    my @imports;
+    while( $idx <= $#_ ) {
+        my $item = $_[$idx];
+
+        if( $item eq 'import' ) {
+            push @imports, @{$_[$idx+1]};
+            $idx++;
+        }
+        else {
+            push @plan, $item;
+        }
+
+        $idx++;
+    }
+
+    plan(@plan);
+
+    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
 }
 
 
@@ -618,7 +635,10 @@ messages which are safer than just C<print STDERR>.
   diag(@diagnostic_message);
 
 Prints a diagnostic message which is guaranteed not to interfere with
-test output.  Handy for this sort of thing:
+test output.  Like C<print> @diagnostic_message is simply concatinated
+together.
+
+Handy for this sort of thing:
 
     ok( grep(/foo/, @users), "There's a foo user" ) or
         diag("Since there's no foo, check that /etc/bar is set up right");
@@ -742,8 +762,9 @@ DIAGNOSTIC
 =item B<require_ok>
 
    require_ok($module);
+   require_ok($file);
 
-Like use_ok(), except it requires the $module.
+Like use_ok(), except it requires the $module or $file.
 
 =cut
 
@@ -752,6 +773,10 @@ sub require_ok ($) {
 
     my $pack = caller;
 
+    # Try to deterine if we've been given a module name or file.
+    # Module names must be barewords, files not.
+    $module = qq['$module'] unless _is_module_name($module);
+
     local($!, $@); # eval sometimes interferes with $!
     eval <<REQUIRE;
 package $pack;
@@ -772,6 +797,17 @@ DIAGNOSTIC
     return $ok;
 }
 
+
+sub _is_module_name {
+    my $module = shift;
+
+    # Module names start with a letter.
+    # End with an alphanumeric.
+    # The rest is an alphanumeric or ::
+    $module =~ s/\b::\b//g;
+    $module =~ /^[a-zA-Z]\w+$/;
+}
+
 =back
 
 =head2 Conditional tests
@@ -950,8 +986,7 @@ Not everything is a simple eq check or regex.  There are times you
 need to see if two arrays are equivalent, for instance.  For these
 instances, Test::More provides a handful of useful functions.
 
-B<NOTE> These are NOT well-tested on circular references.  Nor am I
-quite sure what will happen with filehandles.
+B<NOTE> I'm not quite sure what will happen with filehandles.
 
 =over 4
 
@@ -969,7 +1004,7 @@ along these lines.
 
 =cut
 
-use vars qw(@Data_Stack);
+use vars qw(@Data_Stack %Refs_Seen);
 my $DNE = bless [], 'Does::Not::Exist';
 sub is_deeply {
     unless( @_ == 2 or @_ == 3 ) {
@@ -986,11 +1021,15 @@ WARNING
     my($this, $that, $name) = @_;
 
     my $ok;
-    if( !ref $this || !ref $that ) {
+    if( !ref $this xor !ref $that ) {  # one's a reference, one isn't
+        $ok = 0;
+    }
+    if( !ref $this and !ref $that ) {
         $ok = $Test->is_eq($this, $that, $name);
     }
     else {
         local @Data_Stack = ();
+        local %Refs_Seen  = ();
         if( _deep_check($this, $that) ) {
             $ok = $Test->ok(1, $name);
         }
@@ -1055,10 +1094,29 @@ multi-level structures are handled correctly.
 =cut
 
 #'#
-sub eq_array  {
+sub eq_array {
+    local @Data_Stack;
+    local %Refs_Seen;
+    _eq_array(@_);
+}
+
+sub _eq_array  {
     my($a1, $a2) = @_;
+
+    if( grep !UNIVERSAL::isa($_, 'ARRAY'), $a1, $a2 ) {
+        warn "eq_array passed a non-array ref";
+        return 0;
+    }
+
     return 1 if $a1 eq $a2;
 
+    if($Refs_Seen{$a1}) {
+        return $Refs_Seen{$a1} eq $a2;
+    }
+    else {
+        $Refs_Seen{$a1} = "$a2";
+    }
+
     my $ok = 1;
     my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
     for (0..$max) {
@@ -1071,6 +1129,7 @@ sub eq_array  {
 
         last unless $ok;
     }
+
     return $ok;
 }
 
@@ -1078,24 +1137,34 @@ sub _deep_check {
     my($e1, $e2) = @_;
     my $ok = 0;
 
-    my $eq;
     {
         # Quiet uninitialized value warnings when comparing undefs.
         local $^W = 0; 
 
-        if( $e1 eq $e2 ) {
+        $Test->_unoverload(\$e1, \$e2);
+
+        # Either they're both references or both not.
+        my $same_ref = !(!ref $e1 xor !ref $e2);
+
+        if( defined $e1 xor defined $e2 ) {
+            $ok = 0;
+        }
+        elsif ( $e1 == $DNE xor $e2 == $DNE ) {
+            $ok = 0;
+        }
+        elsif ( $same_ref and ($e1 eq $e2) ) {
             $ok = 1;
         }
         else {
             if( UNIVERSAL::isa($e1, 'ARRAY') and
                 UNIVERSAL::isa($e2, 'ARRAY') )
             {
-                $ok = eq_array($e1, $e2);
+                $ok = _eq_array($e1, $e2);
             }
             elsif( UNIVERSAL::isa($e1, 'HASH') and
                    UNIVERSAL::isa($e2, 'HASH') )
             {
-                $ok = eq_hash($e1, $e2);
+                $ok = _eq_hash($e1, $e2);
             }
             elsif( UNIVERSAL::isa($e1, 'REF') and
                    UNIVERSAL::isa($e2, 'REF') )
@@ -1109,6 +1178,7 @@ sub _deep_check {
             {
                 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
                 $ok = _deep_check($$e1, $$e2);
+                pop @Data_Stack if $ok;
             }
             else {
                 push @Data_Stack, { vals => [$e1, $e2] };
@@ -1131,9 +1201,28 @@ is a deep check.
 =cut
 
 sub eq_hash {
+    local @Data_Stack;
+    local %Refs_Seen;
+    return _eq_hash(@_);
+}
+
+sub _eq_hash {
     my($a1, $a2) = @_;
+
+    if( grep !UNIVERSAL::isa($_, 'HASH'), $a1, $a2 ) {
+        warn "eq_hash passed a non-hash ref";
+        return 0;
+    }
+
     return 1 if $a1 eq $a2;
 
+    if( $Refs_Seen{$a1} ) {
+        return $Refs_Seen{$a1} eq $a2;
+    }
+    else {
+        $Refs_Seen{$a1} = "$a2";
+    }
+
     my $ok = 1;
     my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
     foreach my $k (keys %$bigger) {
@@ -1163,17 +1252,22 @@ While the order of elements does not matter, duplicate elements do.
 
 =cut
 
-# We must make sure that references are treated neutrally.  It really
-# doesn't matter how we sort them, as long as both arrays are sorted
-# with the same algorithm.
-sub _bogus_sort { local $^W = 0;  ref $a ? -1 : ref $b ? 1 : $a cmp $b }
-
 sub eq_set  {
     my($a1, $a2) = @_;
     return 0 unless @$a1 == @$a2;
 
     # There's faster ways to do this, but this is easiest.
-    return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+    local $^W = 0;
+
+    # We must make sure that references are treated neutrally.  It really
+    # doesn't matter how we sort them, as long as both arrays are sorted
+    # with the same algorithm.
+    # Have to inline the sort routine due to a threading/sort bug.
+    # See [rt.cpan.org 6782]
+    return eq_array(
+           [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1],
+           [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2]
+    );
 }
 
 =back
@@ -1227,13 +1321,27 @@ So the exit codes are...
 If you fail more than 254 tests, it will be reported as 254.
 
 
-=head1 NOTES
+=head1 CAVEATS and NOTES
 
-Test::More is B<explicitly> tested all the way back to perl 5.004.
+=over 4
 
-=head1 BUGS and CAVEATS
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.004_05.
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings>.  This prevents
+Test::More from piercing an object's interface allowing better blackbox
+testing.  So if a function starts returning overloaded objects instead of
+bare strings your tests won't notice the difference.  This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects.  In this case I would
+suggest Test::Deep which contains more flexible testing functions for
+complex data structures.
 
-=over 4
 
 =item Threads
 
@@ -1248,12 +1356,6 @@ This may cause problems:
     use Test::More
     use threads;
 
-=item Making your own ok()
-
-If you are trying to extend Test::More, don't.  Use Test::Builder
-instead.
-
-=item The eq_* family has some caveats.
 
 =item Test::Harness upgrade
 
@@ -1313,12 +1415,18 @@ L<Bundle::Test> installs a whole bunch of useful test modules.
 
 Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
 from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, blackstar.co.uk, chromatic and the perl-qa gang.
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
 
 
 =head1 COPYRIGHT
 
-Copyright 2001, 2002 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001, 2002, 2004 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.