r4486@windhund: schwern | 2005-04-26 20:44:39 -0700

- is_deeply() diagnostics now disambiguate between stringified references and references. Also using a second Test::Builder object for testing rather than home rolled functions. Overloaded references display incorrectly, last test fails.
Test-More · Apr 27, 2005 · dcc3aae · dcc3aae
1 parent bfc638f
commit dcc3aae
Show file tree

Hide file tree

Showing 3 changed files with 99 additions and 58 deletions.
diff --git a/Changes b/Changes
@@ -12,6 +12,8 @@
       [rt.cpan.org 11623]
     - Loading Test::Builder but not using it would interfere with the
       exit code if the code exited. [rt.cpan.org 12310]
+    - is_deeply() diagnostics now disambiguate between stringified references
+      and references. [rt.cpan.org 8865]
 
 0.54  Wed Dec 15 04:18:43 EST 2004
     * $how_many is optional for skip() and todo_skip().  Thanks to 

diff --git a/lib/Test/More.pm b/lib/Test/More.pm
@@ -1070,9 +1070,10 @@ sub _format_stack {
     my $out = "Structures begin differing at:\n";
     foreach my $idx (0..$#vals) {
         my $val = $vals[$idx];
-        $vals[$idx] = !defined $val ? 'undef' : 
-                      $val eq $DNE  ? "Does not exist"
-                                    : "'$val'";
+        $vals[$idx] = !defined $val ? 'undef'          :
+                      $val eq $DNE  ? "Does not exist" :
+	              ref $val      ? "$val"           :
+                                      "'$val'";
     }
 
     $out .= "$vars[0] = $vals[0]\n";
@@ -1173,6 +1174,7 @@ sub _deep_check {
 
         # Either they're both references or both not.
         my $same_ref = !(!ref $e1 xor !ref $e2);
+	my $not_ref  = (!ref $e1 and !ref $e2);
 
         if( defined $e1 xor defined $e2 ) {
             $ok = 0;
@@ -1183,6 +1185,10 @@ sub _deep_check {
         elsif ( $same_ref and ($e1 eq $e2) ) {
             $ok = 1;
         }
+	elsif ( $not_ref ) {
+	    push @Data_Stack, { type => '', vals => [$e1, $e2] };
+	    $ok = 0;
+	}
         else {
             if( $Refs_Seen{$e1} ) {
                 return $Refs_Seen{$e1} eq $e2;
@@ -1192,10 +1198,10 @@ sub _deep_check {
             }
 
             my $type = _type($e1);
-            $type = '' unless _type($e2) eq $type;
+            $type = 'DIFFERENT' unless _type($e2) eq $type;
 
-            if( !$type ) {
-                push @Data_Stack, { vals => [$e1, $e2] };
+            if( $type eq 'DIFFERENT' ) {
+                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
                 $ok = 0;
             }
             elsif( $type eq 'ARRAY' ) {
@@ -1205,7 +1211,7 @@ sub _deep_check {
                 $ok = _eq_hash($e1, $e2);
             }
             elsif( $type eq 'REF' ) {
-                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
                 $ok = _deep_check($$e1, $$e2);
                 pop @Data_Stack if $ok;
             }
@@ -1214,13 +1220,27 @@ sub _deep_check {
                 $ok = _deep_check($$e1, $$e2);
                 pop @Data_Stack if $ok;
             }
+	    else {
+		_whoa(1, "No type in _deep_check");
+	    }
         }
     }
 
     return $ok;
 }
 
 
+sub _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(\%this, \%that);

diff --git a/t/is_deeply_fail.t b/t/is_deeply_fail.t
@@ -23,67 +23,34 @@ local $ENV{HARNESS_ACTIVE} = 0;
 # Can't use Test.pm, that's a 5.005 thing.
 package main;
 
-print "1..58\n";
 
-my $test_num = 1;
+my $TB = Test::Builder->create;
+$TB->plan(tests => 58);
+
 # Utility testing functions.
 sub ok ($;$) {
-    my($test, $name) = @_;
-    my $ok = '';
-    $ok .= "not " unless $test;
-    $ok .= "ok $test_num";
-    $ok .= " - $name" if defined $name;
-    $ok .= "\n";
-    print $ok;
-    $test_num++;
-
-    return $test;
+    return $TB->ok(@_);
 }
 
 sub is ($$;$) {
     my($this, $that, $name) = @_;
-    my $test = $$this eq $that;
-    my $ok = '';
-    $ok .= "not " unless $test;
-    $ok .= "ok $test_num";
-    $ok .= " - $name" if defined $name;
-    $ok .= "\n";
-    print $ok;
-
-    unless( $test ) {
-        print "# got      \n$$this";
-        print "# expected \n$that";
-    }
-    $test_num++;
+
+    my $ok = $TB->is_eq($$this, $that, $name);
 
     $$this = '';
 
-    return $test;
+    return $ok;
 }
 
 sub like ($$;$) {
     my($this, $regex, $name) = @_;
-
     $regex = qr/$regex/ unless ref $regex;
-    my $test = $$this =~ $regex;
-
-    my $ok = '';
-    $ok .= "not " unless $test;
-    $ok .= "ok $test_num";
-    $ok .= " - $name" if defined $name;
-    $ok .= "\n";
-    print $ok;
-
-    unless( $test ) {
-        print "# got      \n$$this";
-        print "# expected \n$regex";
-    }
-    $test_num++;
 
-    $$this = '';
+    my $ok = $TB->like($$this, $regex, $name);
 
+    $$this = '';
 
-    return $test;
+    return $ok;
 }
 
 
@@ -108,8 +75,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
@@ -182,8 +149,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
 
 
@@ -289,7 +256,7 @@ is( $err, <<ERR,        '  right diagnostic');
 #     Failed test ($0 at line 286)
 #     Structures begin differing at:
 #          \$got = '23'
-#     \$expected = '$ref'
+#     \$expected = $ref
 ERR
 
 #line 296
@@ -298,16 +265,68 @@ is( $out, "not ok 22\n", 'ref vs scalar' );
 is( $err, <<ERR,        '  right diagnostic');
 #     Failed test ($0 at line 296)
 #     Structures begin differing at:
-#          \$got = '$ref'
+#          \$got = $ref
 #     \$expected = '23'
 ERR
 
 #line 306
 ok !is_deeply( undef, [] );
 is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' );
 like( $err, <<ERR,	 '  right diagnostic' );
-#     Failed test \\($0 at line 306\\)
+#     Failed test \\($Filename at line 306\\)
 #     Structures begin differing at:
 #          \\\$got = undef
-#     \\\$expected = 'ARRAY\\(0x[0-9a-f]+\\)'
+#     \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
+ERR
+
+
+# rt.cpan.org 8865
+{
+    my $array = [];
+    my $hash  = {};
+
+#line 321
+    ok !is_deeply( $array, $hash );
+    is( $out, "not ok 24\n", 'is_deeply and different reference types' );
+    is( $err, <<ERR, 	     '  right diagnostic' );
+#     Failed test ($0 at line 321)
+#     Structures begin differing at:
+#          \$got = $array
+#     \$expected = $hash
+ERR
+
+#line 332
+    ok !is_deeply( [$array], [$hash] );
+    is( $out, "not ok 25\n", 'nested different ref types' );
+    is( $err, <<ERR,	     '  right diagnostic' );
+#     Failed test ($0 at line 332)
+#     Structures begin differing at:
+#          \$got->[0] = $array
+#     \$expected->[0] = $hash
 ERR
+
+
+    if( eval { require overload } ) {
+	my $foo = bless [], "Foo";
+	my $bar = bless {}, "Bar";
+
+	{
+	    package Bar;
+	    overload->import(q[""] => sub { "wibble" });
+	}
+
+#line 353
+	ok !is_deeply( [$foo], [$bar] );
+	is( $out, "not ok 26\n", 'different string overloaded ref types' );
+	is( $err, <<ERR,	     '  right diagnostic' );
+#     Failed test ($0 at line 353)
+#     Structures begin differing at:
+#          \$got->[0] = $foo
+#     \$expected->[0] = $bar
+ERR
+
+    }
+    else {
+	$TB->skip("Needs overload.pm") for 1..3;
+    }
+}