New Features

* cmp_ok() now displays the error if the comparison throws one. For example, broken overloaded objects. Bug Fixes * cmp_ok() no longer stringifies or numifies its arguments before comparing. This makes cmp_ok() properly test overloaded ops. [rt.cpan.org 24186] [code.google.com 16] * diag() properly escapes blank lines. Don't bother checking if objects are dualvars. They can't be and it avoids tripping on weirdly overloaded objects.
leto · Oct 23, 2008 · de9a857 · de9a857
1 parent fc9eb4b
commit de9a857
Show file tree

Hide file tree

Showing 5 changed files with 72 additions and 25 deletions.
diff --git a/Changes b/Changes
@@ -1,3 +1,15 @@
+0.85_01
+    New Features
+    * cmp_ok() now displays the error if the comparison throws one.
+      For example, broken overloaded objects.
+
+    Bug Fixes
+    * cmp_ok() no longer stringifies or numifies its arguments before comparing.
+      This makes cmp_ok() properly test overloaded ops.
+      [rt.cpan.org 24186] [code.google.com 16]
+    * diag() properly escapes blank lines.
+
+
 0.84  Wed Oct 15 09:06:12 EDT 2008
     Other
     * 0.82 accidentally shipped with experimental Mouse dependency.

diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm
@@ -499,6 +499,9 @@ sub _unoverload_num {
 sub _is_dualvar {
     my( $self, $val ) = @_;
 
+    # Objects are not dualvars.
+    return 0 if ref $val;
+
     no warnings 'numeric';
     my $numval = $val + 0;
     return $numval != 0 and $numval ne $val ? 1 : 0;
@@ -697,16 +700,8 @@ my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" )
 sub cmp_ok {
     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 $test;
+    my $error;
     {
         ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -719,12 +714,28 @@ sub cmp_ok {
         # Don't ask me, man, I just work here.
         $test = eval "
 $code" . "\$got $type \$expect;";
-
+        $error = $@;
     }
     local $Level = $Level + 1;
     my $ok = $self->ok( $test, $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->diag(<<"END") if $error;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+END
+
     unless($ok) {
+        $self->$unoverload( \$got, \$expect );
+
         if( $type =~ /^(eq|==)$/ ) {
             $self->_is_diag( $got, $type, $expect );
         }
@@ -1326,10 +1337,10 @@ sub _print_to_fh {
 
     # Escape each line after the first with a # so we don't
     # confuse Test::Harness.
-    $msg =~ s/\n(.)/\n# $1/sg;
+    $msg =~ s{\n(?!\z)}{\n# }sg;
 
     # Stick a newline on the end if it needs it.
-    $msg .= "\n" unless $msg =~ /\n\Z/;
+    $msg .= "\n" unless $msg =~ /\n\z/;
 
     return print $fh $msg;
 }

diff --git a/t/cmp_ok.t b/t/cmp_ok.t
@@ -30,19 +30,19 @@ sub try_cmp_ok {
     $expect{error} =~ s/ at .*\n?//;
 
     local $Test::Builder::Level = $Test::Builder::Level + 1;
-    my $ok = cmp_ok($left, $cmp, $right);
-    $TB->is_num(!!$ok, !!$expect{ok});
+    my $ok = cmp_ok($left, $cmp, $right, "cmp_ok");
+    $TB->is_num(!!$ok, !!$expect{ok}, "  right return");
 
     my $diag = $err->read;
     if( !$ok and $expect{error} ) {
         $diag =~ s/^# //mg;
-        $TB->like( $diag, "/\Q$expect{error}\E/" );
+        $TB->like( $diag, qr/\Q$expect{error}\E/, "  expected error" );
     }
     elsif( $ok ) {
-        $TB->is_eq( $diag, '' );
+        $TB->is_eq( $diag, '', "  passed without diagnostic" );
     }
     else {
-        $TB->ok(1);
+        $TB->ok(1, "  failed without diagnostic");
     }
 }
 
@@ -60,8 +60,7 @@ my @Tests = (
 );
 
 # These don't work yet.
-if( 0 ) {
-#if( eval { require overload } ) {
+if( eval { require overload } ) {
     require MyOverload;
 
     my $cmp = Overloaded::Compare->new("foo", 42);

diff --git a/t/diag.t b/t/diag.t
@@ -25,7 +25,7 @@ BEGIN {
 
 use strict;
 
-use Test::More tests => 5;
+use Test::More tests => 7;
 
 my $test = Test::Builder->create;
 
@@ -61,8 +61,23 @@ $test->reset_outputs();
 $test->failure_output(\*FAKEOUT);
 {
     $test->diag("# foo");
-
     is( $output->read, "# # foo\n", "diag() adds # even if there's one already" );
+
+    $test->diag("foo\n\nbar");
+    is( $output->read, <<'DIAG', "  blank lines get escaped" );
+# foo
+# 
+# bar
+DIAG
+
+
+    $test->diag("foo\n\nbar\n\n");
+    is( $output->read, <<'DIAG', "  even at the end" );
+# foo
+# 
+# bar
+# 
+DIAG
 }
 
 

diff --git a/t/overload.t b/t/overload.t
@@ -19,20 +19,28 @@ BEGIN {
         plan skip_all => "needs overload.pm";
     }
     else {
-        plan tests => 13;
+        plan tests => 15;
     }
 }
 
 
 package Overloaded;
 
 use overload
-        q{""}    => sub { $_[0]->{string} },
-        q{0+}    => sub { $_[0]->{num} };
+  q{eq}    => sub { $_[0]->{string} },
+  q{==}    => sub { $_[0]->{num} },
+  q{""}    => sub { $_[0]->{stringfy}++; $_[0]->{string} },
+  q{0+}    => sub { $_[0]->{numify}++;   $_[0]->{num}    }
+;
 
 sub new {
     my $class = shift;
-    bless { string => shift, num => shift }, $class;
+    bless {
+        string  => shift,
+        num     => shift,
+        stringify       => 0,
+        numify          => 0,
+    }, $class;
 }
 
 
@@ -49,7 +57,9 @@ isa_ok $obj, 'Overloaded';
 
 is $obj, 'foo',            'is() with string overloading';
 cmp_ok $obj, 'eq', 'foo',  'cmp_ok() ...';
+is $obj->{stringify}, 0, 'cmp_ok() eq does not stringify';
 cmp_ok $obj, '==', 42,     'cmp_ok() with number overloading';
+is $obj->{numify}, 0,    'cmp_ok() == does not numify';
 
 is_deeply [$obj], ['foo'],                 'is_deeply with string overloading';
 ok eq_array([$obj], ['foo']),              'eq_array ...';