4 bugs in Test::More

Message-Id: <200303211057.31879.fergal@esatclear.ie>

p4raw-id: //depot/perl@20465

diff --git a/lib/Test/More.pm b/lib/Test/More.pm
index d82f81d..adbac38 100644 (file)
--- a/lib/Test/More.pm
+++ b/lib/Test/More.pm
@@ -25,7 +25,7 @@ $VERSION = '0.47';
              cmp_ok
              skip todo todo_skip
              pass fail
-             eq_array eq_hash eq_set
+             eq_array eq_hash eq_set eq_deeply
              $TODO
              plan
              can_ok  isa_ok
@@ -937,7 +937,7 @@ sub is_deeply {
     my($this, $that, $name) = @_;
 
     my $ok;
-    if( !ref $this || !ref $that ) {
+    if( !ref $this && !ref $that ) {
         $ok = $Test->is_eq($this, $that, $name);
     }
     else {
@@ -984,8 +984,9 @@ sub _format_stack {
     foreach my $idx (0..$#vals) {
         my $val = $vals[$idx];
         $vals[$idx] = !defined $val ? 'undef' : 
-                      $val eq $DNE  ? "Does not exist"
-                                    : "'$val'";
+                                    ref $val ? $val eq $DNE  ? "Does not exist"
+                                                             : $val
+                                             : "'$val'"
     }
 
     $out .= "$vars[0] = $vals[0]\n";
@@ -995,6 +996,12 @@ sub _format_stack {
     return $out;
 }
 
+sub eq_deeply {
+    my ($a1, $a2) = @_;
+
+    local @Data_Stack = ();
+    return _deep_check($a1, $a2);
+}
 
 =item B<eq_array>
 
@@ -1006,7 +1013,14 @@ multi-level structures are handled correctly.
 =cut
 
 #'#
-sub eq_array  {
+
+sub eq_array {
+    my ($a1, $a2) = @_;
+
+    return UNIVERSAL::isa($a2, "ARRAY") ? eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_array  {
     my($a1, $a2) = @_;
     return 1 if $a1 eq $a2;
 
@@ -1034,19 +1048,24 @@ sub _deep_check {
         # Quiet uninitialized value warnings when comparing undefs.
         local $^W = 0; 
 
-        if( $e1 eq $e2 ) {
+        if( ! (ref $e1 xor ref $e2) and $e1 eq $e2 ) {
             $ok = 1;
         }
         else {
-            if( UNIVERSAL::isa($e1, 'ARRAY') and
+            if ( (ref $e1 and $e1 eq $DNE) or
+               (ref $e2 and $e2 eq $DNE) )
+            {
+               $ok = 0;
+            }
+            elsif( 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') )
@@ -1060,6 +1079,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] };
@@ -1082,6 +1102,12 @@ is a deep check.
 =cut
 
 sub eq_hash {
+    my ($a1, $a2) = @_;
+
+    return UNIVERSAL::isa($a2, "HASH") ? eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_hash {
     my($a1, $a2) = @_;
     return 1 if $a1 eq $a2;
 

diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t
index df8c5fe..abd1e80 100644 (file)
--- a/lib/Test/Simple/t/More.t
+++ b/lib/Test/Simple/t/More.t
@@ -7,7 +7,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 41;
+use Test::More tests => 42;
 
 # Make sure we don't mess with $@ or $!.  Test at bottom.
 my $Err   = "this should not be touched";
@@ -69,6 +69,9 @@ ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}),
 ok( eq_set([qw(this that whatever)], [qw(that whatever this)]),
     'eq_set with simple sets' );
 
+eq_array([[]], [{}]);
+is(scalar @Test::More::Data_Stack, 0, "data stack empty");
+
 my @complex_array1 = (
                       [qw(this that whatever)],
                       {foo => 23, bar => 42},

diff --git a/lib/Test/Simple/t/is_deeply.t b/lib/Test/Simple/t/is_deeply.t
index 5291fb8..a7fbcd0 100644 (file)
--- a/lib/Test/Simple/t/is_deeply.t
+++ b/lib/Test/Simple/t/is_deeply.t
@@ -92,8 +92,8 @@ is( $out, "not ok 2 - different types\n",   'different types' );
 like( $err, <<ERR,                          '   right diagnostic' );
 #     Failed test \\($Filename at line 78\\)
 #     Structures begin differing at:
-#          \\\$got = 'HASH\\(0x[0-9a-f]+\\)'
-#     \\\$expected = 'ARRAY\\(0x[0-9a-f]+\\)'
+#          \\\$got = HASH\\(0x[0-9a-f]+\\)
+#     \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
 ERR
 
 #line 88
@@ -166,8 +166,8 @@ is( $out, "not ok 9 - mixed scalar and array refs\n",
 like( $err, <<ERR,                      '    right diagnostic' );
 #     Failed test \\($Filename at line 151\\)
 #     Structures begin differing at:
-#          \\\$got = 'ARRAY\\(0x[0-9a-f]+\\)'
-#     \\\$expected = 'SCALAR\\(0x[0-9a-f]+\\)'
+#          \\\$got = ARRAY\\(0x[0-9a-f]+\\)
+#     \\\$expected = SCALAR\\(0x[0-9a-f]+\\)
 ERR
 
 
@@ -213,3 +213,35 @@ is( $err, <<ERR,                            '    right diagnostic' );
 #          \$got->{that}{foo} = Does not exist
 #     \$expected->{that}{foo} = '42'
 ERR
+
+#line 217
+is_deeply([(\"a"), "b"], [(\"a"), "c"], "scalar refs diag");
+is( $out, "not ok 12 - scalar refs diag\n",  'scalar refs diag' );
+is( $err, <<ERR,                            '    right diagnostic' );
+#     Failed test ($0 at line 217)
+#     Structures begin differing at:
+#          \$got->[1] = 'b'
+#     \$expected->[1] = 'c'
+ERR
+
+#line 228
+my $a = [];
+is_deeply($a, $a."", "mixed ref and stringified ref");
+is( $out, "not ok 13 - mixed ref and stringified ref\n",  'mixed ref and stringified ref' );
+is( $err, <<ERR,                            '    right diagnostic' );
+#     Failed test ($0 at line 229)
+#     Structures begin differing at:
+#          \$got = $a
+#     \$expected = '$a'
+ERR
+
+#line 238
+my $b = [];
+is_deeply({}, {key => $b}, "Does Not Exist");
+is( $out, "not ok 14 - Does Not Exist\n",  'Does Not Exist' );
+is( $err, <<ERR,                            '    right diagnostic' );
+#     Failed test ($0 at line 239)
+#     Structures begin differing at:
+#          \$got->{key} = Does not exist
+#     \$expected->{key} = $b
+ERR