| Subject: | UNIVERSAL::isa ignores overloaded can() |
UNIVERSAL::isa calls UNIVERSAL::can() as a function, not a method,
disallowing the use of a proxy object that implements its own can(), for
example. The test patch adds a test for this as well as the standard
behavior promised by the UNIVERSAL documentation of checking for
hashiness of a reference. Though that's not as nice as using
Scalar::Util::reftype(), this module should be transparent.
The other patch refactors the implementation of the module to be clearer
about what's happening as well as to fix both bugs.
| Subject: | isa.patch |
diff -ur lib/UNIVERSAL/isa.pm~ UNIVERSAL-isa/lib/UNIVERSAL/isa.pm
--- lib/UNIVERSAL/isa.pm~ 2005-11-07 00:17:31.000000000 -0800
+++ lib/UNIVERSAL/isa.pm 2006-01-14 01:03:54.000000000 -0800
@@ -22,55 +22,67 @@
*{caller() . "::isa"} = \&UNIVERSAL::isa if (@_ > 1 and $_[1] eq "isa");
}
-sub UNIVERSAL::isa {
- # not an object or a class name, we can skip
- unless ( blessed($_[0]) )
+sub UNIVERSAL::isa
+{
+ goto &$orig if $recursing;
+ my $type = invocant_type( @_ );
+ $type->( @_ );
+}
+
+sub invocant_type
+{
+ my $invocant = shift;
+ return \&nonsense unless defined( $invocant );
+ return \&object_or_class if blessed( $invocant );
+ return \&reference if ref( $invocant );
+ return \&nonsense unless $invocant;
+ return \&object_or_class;
+}
+
+sub nonsense
+{
+ report_warning( 'on invalid invocant' );
+ return;
+}
+
+sub object_or_class
+{
+ report_warning();
+
+ local $@;
+ local $recursing = 1;
+
+ if ( my $override = eval { $_[0]->can( 'isa' ) } )
{
- if (not defined $_[0] or length $_[0] == 0) {
- # it's not a class, either... Retain orig behavior
- # for garbage as first arg
- goto &$orig;
- } else {
- # it's a string, which means it can be a class
- my $symtable = \%::;
- my $found = 1;
-
- for my $symbol (split( '::', $_[0] )) {
- $symbol .= '::';
- unless (exists $symtable->{$symbol}) {
- $found = 0;
- last;
- }
- $symtable = $symtable->{$symbol};
- }
-
- # if it's not a class then it doesn't have it's own dispatch,
- # so we retain the original behavior
- goto &$orig unless $found;
+ unless ( $override == \&UNIVERSAL::isa )
+ {
+ my $obj = shift;
+ return $obj->$override( @_ );
}
}
- # if the object will *really* run a different 'isa' when we invoke it we
- # need to invoke it. On the other hand if it's not overridden, we just use
- # the original behavior
- goto &$orig if (UNIVERSAL::can($_[0], "isa") == \&UNIVERSAL::isa);
-
- # if we've been called from an overridden isa that we arranged to call, we
- # are either SUPER:: or explicitly called. in both cases the original ISA
- # behavior is expected.
- goto &$orig if $recursing;
+ goto &$orig;
+}
- # the last possible case is that 'isa' is overridden
- local $recursing = 1;
- my $obj = shift;
+sub reference
+{
+ report_warning( "Did you mean to use Scalar::Util::reftype() instead?" );
+ goto &$orig;
+}
- if (warnings::enabled()) {
- my $calling_sub = ( caller( 1 ) )[3] || '';
- warnings::warn( "Called UNIVERSAL::isa() as a function, not a method" )
- if $calling_sub !~ /::isa$/;
- }
+sub report_warning
+{
+ my $extra = shift;
+ $extra = $extra ? " ($extra)" : '';
- return $obj->isa(@_);
+ if (warnings::enabled())
+ {
+ my $calling_sub = ( caller( 2 ) )[3] || '';
+ return if $calling_sub =~ /::isa$/;
+ warnings::warn(
+ "Called UNIVERSAL::isa() as a function, not a method$extra"
+ )
+ }
}
__PACKAGE__;
@@ -125,8 +137,6 @@
=head1 COPYRIGHT & LICENSE
-Same as perl, blah blah blah, (c) 2005
+Same as perl, blah blah blah, (c) 2005 - 2006.
=cut
-
-
| Subject: | universal_tests.patch |
diff -ur t/basic.t~ UNIVERSAL-isa/t/basic.t
--- t/basic.t~ 2005-11-07 00:17:31.000000000 -0800
+++ t/basic.t 2006-01-14 01:04:59.000000000 -0800
@@ -2,11 +2,12 @@
use strict;
-use Test::More tests => 12;
+use Test::More tests => 13;
BEGIN { use_ok("UNIVERSAL::isa", "isa") };
-no warnings "UNIVERSAL::isa";
+# no warnings "UNIVERSAL::isa";
+use warnings;
{
package Foo;
@@ -51,4 +52,7 @@
ok(isa($x, "Baz"), "baz is itself");
ok(!isa($x, "Crap"), "baz isn't crap");
ok(isa($x, "Dung"), "it's dung");
-
+{
+ use warnings 'UNIVERSAL::isa';
+ ok( isa( {}, 'HASH' ), "hash reference isa HASH" );
+}
diff -ur t/bugs.t~ UNIVERSAL-isa/t/bugs.t
--- t/bugs.t~ 2005-11-07 00:17:31.000000000 -0800
+++ t/bugs.t 2006-01-14 01:02:27.000000000 -0800
@@ -1,8 +1,8 @@
-#!/usr/bin/perl -w
+#!/usr/bin/perl
use strict;
-use Test::More tests => 7;
+use Test::More tests => 8;
BEGIN { use_ok('UNIVERSAL::isa', 'isa') };
@@ -33,6 +33,24 @@
}
}
+# really delegates calls to Foo
+{
+ package FooProxy;
+
+ sub new
+ {
+ my $class = shift;
+ my $foo = Foo->new( @_ );
+ bless \$foo, $class;
+ }
+
+ sub can
+ {
+ my $self = shift;
+ return $$self->can( @_ );
+ }
+}
+
# wraps a Foo object
{
package Quux;
@@ -88,3 +106,5 @@
ok( isa( $qibble, 'Qibble' ), '... can test ISA on landmines');
+my $proxy = FooProxy->new();
+isa_ok( $proxy, 'Foo' );