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.
}
}
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'";
}
--- /dev/null
+#!/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;