Patch t/test.pl so isa_ok() works with objects.

This mirrors can_ok() and Test::More.

Also add some tests for isa_ok() and can_ok().

diff --git a/t/test.pl b/t/test.pl
index 2fbde93..c24846d 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -1099,20 +1099,29 @@ sub isa_ok ($$;$) {
     if( !defined $object ) {
         $diag = "$obj_name isn't defined";
     }
-    elsif( !ref $object ) {
-        $diag = "$obj_name isn't a reference";
-    }
     else {
+        my $whatami = ref $object ? 'object' : 'class';
+
         # We can't use UNIVERSAL::isa because we want to honor isa() overrides
         local($@, $!);  # eval sometimes resets $!
         my $rslt = eval { $object->isa($class) };
-        if( $@ ) {
-            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+        my $error = $@;  # in case something else blows away $@
+
+        if( $error ) {
+            if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+                # It's an unblessed reference
+                $obj_name = 'The reference' unless defined $obj_name;
                 if( !UNIVERSAL::isa($object, $class) ) {
                     my $ref = ref $object;
                     $diag = "$obj_name isn't a '$class' it's a '$ref'";
                 }
-            } else {
+            }
+            elsif( $error =~ /Can't call method "isa" without a package/ ) {
+                # It's something that can't even be a class
+                $obj_name = 'The thing' unless defined $obj_name;
+                $diag = "$obj_name isn't a class or reference";
+            }
+            else {
                 die <<WHOA;
 WHOA! I tried to call ->isa on your object and got some weird error.
 This should never happen.  Please contact the author immediately.
@@ -1122,6 +1131,7 @@ WHOA
             }
         }
         elsif( !$rslt ) {
+            $obj_name = "The $whatami" unless defined $obj_name;
             my $ref = ref $object;
             $diag = "$obj_name isn't a '$class' it's a '$ref'";
         }

diff --git a/t/test_pl/can_isa_ok.t b/t/test_pl/can_isa_ok.t
new file mode 100644 (file)
index 0000000..bb24f56
--- /dev/null
+++ b/t/test_pl/can_isa_ok.t
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl -w
+
+# Test isa_ok() and can_ok() in test.pl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl"; }
+
+require Test::More;
+
+can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
+                        pass fail eq_array eq_hash eq_set));
+can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip 
+                                   can_ok pass fail eq_array eq_hash eq_set));
+
+
+isa_ok(bless([], "Foo"), "Foo");
+isa_ok([], 'ARRAY');
+isa_ok(\42, 'SCALAR');
+{
+    local %Bar::;
+    local @Foo::ISA = 'Bar';
+    isa_ok( "Foo", "Bar" );
+}
+
+
+# can_ok() & isa_ok should call can() & isa() on the given object, not 
+# just class, in case of custom can()
+{
+       local *Foo::can;
+       local *Foo::isa;
+       *Foo::can = sub { $_[0]->[0] };
+       *Foo::isa = sub { $_[0]->[0] };
+       my $foo = bless([0], 'Foo');
+       ok( ! $foo->can('bar') );
+       ok( ! $foo->isa('bar') );
+       $foo->[0] = 1;
+       can_ok( $foo, 'blah');
+       isa_ok( $foo, 'blah');
+}
+
+
+done_testing;