UNIVERSAL-isa-1.03/000075500000000000000000000000001126646004600135625ustar00rootroot00000000000000UNIVERSAL-isa-1.03/Build.PL000064400000000000000000000006021126646004600150540ustar00rootroot00000000000000#! perl BEGIN { require 5.006002 } use strict; use warnings; use Module::Build; Module::Build->new( module_name => 'UNIVERSAL::isa', license => 'perl', requires => { 'perl' => '5.6.2', 'Scalar::Util' => 0, }, config_requires => { 'perl' => '5.6.2', 'Module::Build' => '0.33', } )->create_build_script; UNIVERSAL-isa-1.03/Changes000064400000000000000000000016171126646004600150620ustar00rootroot00000000000000Changes for UNIVERSAL::isa -------------------------- 1.03 Mon Jun 22 20:42:36 UTC 2009 - improved packaging (Module::Build is now a config_requires dependency) 1.01 Aug 22 05:29:44 UTC 2008 - minor packaging housekeeping - report only CURRENT ACTUAL BUGS THAT WILL BREAK YOUR CODE AS IT EXISTS RIGHT NOW SO FIX THEM PLEASE rather than latent bugs that will break your code in the future, at least by default - added the verbose flag to fix you about all bugs regarding the use of isa() as a function 0.06 Fri Feb 24 06:47:14 UTC 2006 - allowed for overridden can() - allowed backwards-compatible use of isa() to check reftype - added Changes and README files - revised internal code for readability - improved documentation slightly 0.05 Nov 07 2005 0.04 Sep 11 2005 0.03 Sep 05 2005 0.02 Jul 03 2005 0.01 Jun 30 2005 - initial release UNIVERSAL-isa-1.03/MANIFEST000064400000000000000000000001751126646004600147160ustar00rootroot00000000000000Build.PL Changes lib/UNIVERSAL/isa.pm MANIFEST This list of files META.yml t/basic.t t/bugs.t t/warnings.t README UNIVERSAL-isa-1.03/META.yml000064400000000000000000000010651126646004600150350ustar00rootroot00000000000000--- name: UNIVERSAL-isa version: 1.03 author: - 'Audrey Tang ' - 'chromatic ' - 'Yuval Kogman ' abstract: |- Attempt to recover from people calling UNIVERSAL::isa as a function license: perl resources: license: http://dev.perl.org/licenses/ requires: Scalar::Util: 0 perl: 5.6.2 provides: UNIVERSAL::isa: file: lib/UNIVERSAL/isa.pm version: 1.03 generated_by: Module::Build version 0.33 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 UNIVERSAL-isa-1.03/README000064400000000000000000000022331126646004600144420ustar00rootroot00000000000000UNIVERSAL::isa -------------- Version 1.03 - Mon Jun 22 20:34:08 UTC 2009 Attempt to recover from people calling UNIVERSAL::isa as a function # from the shell echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile # within your program use UNIVERSAL::isa; # verbose reporting use UNIVERSAL::isa 'verbose'; INSTALLATION $ perl Build.PL $ perl ./Build $ perl ./Build test $ sudo perl ./Build install APOLOGIA Whenever you use "isa" in UNIVERSAL as a function, a kitten using Test::MockObject dies. Normally, the kittens would be helpless, but if they use UNIVERSAL::isa (the module whose docs you are reading), the kittens can live long and prosper. This module replaces "UNIVERSAL::isa" with a version that makes sure that, when called as a function on objects which override "isa", "isa" will call the appropriate method on those objects In all other cases, the real "UNIVERSAL::isa" gets called directly. AUTHORS Audrey Tang chromatic Yuval Kogman COPYRIGHT & LICENSE Artistic License 2.0, Copyright (c) chromatic 2005 - 2009. UNIVERSAL-isa-1.03/lib/000075500000000000000000000000001126646004600143305ustar00rootroot00000000000000UNIVERSAL-isa-1.03/lib/UNIVERSAL/000075500000000000000000000000001126646004600157005ustar00rootroot00000000000000UNIVERSAL-isa-1.03/lib/UNIVERSAL/isa.pm000064400000000000000000000077601126646004600170240ustar00rootroot00000000000000package UNIVERSAL::isa; use strict; use vars qw( $VERSION $recursing ); use UNIVERSAL (); use Scalar::Util 'blessed'; use warnings::register; $VERSION = '1.03'; my ( $orig, $verbose_warning ); BEGIN { $orig = \&UNIVERSAL::isa } no warnings 'redefine'; sub import { my $class = shift; no strict 'refs'; for my $arg (@_) { *{ caller() . '::isa' } = \&UNIVERSAL::isa if $arg eq 'isa'; $verbose_warning = 1 if $arg eq 'verbose'; } } 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') if $verbose_warning; return; } sub object_or_class { local $@; local $recursing = 1; if ( my $override = eval { $_[0]->can('isa') } ) { unless ( $override == \&UNIVERSAL::isa ) { report_warning(); my $obj = shift; return $obj->$override(@_); } } report_warning() if $verbose_warning; goto &$orig; } sub reference { report_warning('Did you mean to use Scalar::Util::reftype() instead?') if $verbose_warning; goto &$orig; } sub report_warning { my $extra = shift; $extra = $extra ? " ($extra)" : ''; if ( warnings::enabled() ) { my $calling_sub = ( caller(3) )[3] || ''; return if $calling_sub =~ /::isa$/; warnings::warn( "Called UNIVERSAL::isa() as a function, not a method$extra" ); } } __PACKAGE__; __END__ =pod =head1 NAME UNIVERSAL::isa - Attempt to recover from people calling UNIVERSAL::isa as a function =head1 SYNOPSIS # from the shell echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile # within your program use UNIVERSAL::isa; # enable warnings for all dodgy uses of UNIVERSAL::isa use UNIVERSAL::isa 'verbose'; =head1 DESCRIPTION Whenever you use L as a function, a kitten using L dies. Normally, the kittens would be helpless, but if they use L (the module whose docs you are reading), the kittens can live long and prosper. This module replaces C with a version that makes sure that, when called as a function on objects which override C, C will call the appropriate method on those objects In all other cases, the real C gets called directly. =head1 WARNINGS If the lexical warnings pragma is available, this module will emit a warning for each naughty invocation of C. Silence these warnings by saying: no warnings 'UNIVERSAL::isa'; in the lexical scope of the naughty code. After version 1.00, warnings only appear when naughty code calls UNIVERSAL::isa() as a function on an invocant for which there is an overridden isa(). These are really truly I bugs, and you should fix them rather than relying on this module to find them. To get warnings for all potentially dangerous uses of UNIVERSAL::isa() as a function, not a method (that is, for I uses of the method as a function, which are latent bugs, if not bugs that will break your code as it exists now), pass the C flag when using the module. This can generate many extra warnings, but they're more specific as to the actual wrong practice and they usually suggest proper fixes. =head1 SEE ALSO L for another discussion of the problem at hand. L for one example of a module that really needs to override C. Any decent explanation of OO to understand why calling methods as functions is a staggeringly bad idea. =head1 AUTHORS Audrey Tang chromatic Yuval Kogman =head1 COPYRIGHT & LICENSE Artistic Licence 2.0, (c) 2005 - 2009. =cut UNIVERSAL-isa-1.03/t/000075500000000000000000000000001126646004600140255ustar00rootroot00000000000000UNIVERSAL-isa-1.03/t/basic.t000064400000000000000000000106211126646004600152730ustar00rootroot00000000000000#! perl use strict; use warnings; use Test::More tests => 47; BEGIN { use_ok('UNIVERSAL::isa', 'isa') }; use warnings; { package Foo; sub isa { 1 } } { package Bar; } { package Gorch; sub isa { my ($self, $class) = @_; $self->SUPER::isa($class) unless $class eq 'Glab'; } } { package Baz; sub isa { my ($self, $class) = @_; UNIVERSAL::isa($self, $class) unless $class eq 'Glab'; } } my ($f, $b, $g, $x) = map { bless [], $_ } qw( Foo Bar Gorch Baz ); { my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; ok( isa( [], 'ARRAY' ), '[] is an array ref' ); is( $warning, '', 'not warning by default' ); $warning = ''; ok( isa( $b, 'Bar' ), 'bar is a Bar' ); is( $warning, '', 'not warning by default' ); $warning = ''; ok( isa( $f, 'Foo' ), 'foo is a Foo' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( !isa( $b, 'Zlap' ), 'bar is not Zlap' ); is( $warning, '', 'not warning by default' ); $warning = ''; ok( isa( $f, 'Zlap' ), 'neither is Foo' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( isa( $g, 'Gorch' ), 'Gorch is itself' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( !isa( $g, 'Zlap' ), 'gorch is not Zlap' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( isa( $g, 'Glab' ), '... it is dung' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( isa( $x, 'Baz' ), 'Baz is itself' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( !isa( $x, 'Zlap' ), 'baz is not Zlap' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); $warning = ''; ok( isa( $x, 'Glab' ), 'it is dung' ); like( $warning, qr/as a function.+basic.t/, '... warning by default' ); } { use warnings 'UNIVERSAL::isa'; my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; $warning = ''; ok( isa( {}, 'HASH' ), 'hash reference isa HASH' ); is( $warning, '', '... and no warning by default' ); $warning = ''; ok( isa( [], 'ARRAY' ), 'array reference isa ARRAY' ); is( $warning, '', '... and no warning by default' ); $warning = ''; ok( isa( sub {}, 'CODE' ), 'code reference isa CODE' ); is( $warning, '', '... and no warning by default' ); $warning = ''; ok( isa( \my $a, 'SCALAR' ), 'scalar reference isa SCALAR' ); is( $warning, '', '... and no warning by default' ); $warning = ''; ok( isa( qr//, 'Regexp' ), 'regexp reference isa Regexp' ); is( $warning, '', '... and no warning by default' ); $warning = ''; ok( isa( \local *FOO, 'GLOB' ), 'glob reference isa GLOB' ); is( $warning, '', '... and no warning by default' ); } { use warnings 'UNIVERSAL::isa'; UNIVERSAL::isa::->import( 'verbose' ); my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; ok( isa( {}, 'HASH' ), 'hash reference isa HASH' ); like( $warning, qr/Called.+as a function.+reftyp.+basic.t/, '... warning in verbose mode' ); $warning = ''; ok( isa( [], 'ARRAY' ), 'array reference isa ARRAY' ); like( $warning, qr/Called.+as a function.+reftyp.+basic.t/, '... warning in verbose mode' ); $warning = ''; ok( isa( sub {}, 'CODE' ), 'code reference isa CODE' ); like( $warning, qr/Called.+as a function.+reftyp.+basic.t/, '... warning in verbose mode' ); $warning = ''; ok( isa( \my $a, 'SCALAR' ), 'scalar reference isa SCALAR' ); like( $warning, qr/Called.+as a function.+reftyp.+basic.t/, '... warning in verbose mode' ); $warning = ''; ok( isa( qr//, 'Regexp' ), 'regexp reference isa Regexp' ); like( $warning, qr/Called.+as a functio.+basic.t/, '... warning in verbose mode' ); $warning = ''; ok( isa( \local *FOO, 'GLOB' ), 'glob reference isa GLOB' ); like( $warning, qr/Called.+as a function.+reftyp.+basic.t/, '... warning in verbose mode' ); } UNIVERSAL-isa-1.03/t/bugs.t000064400000000000000000000052711126646004600151570ustar00rootroot00000000000000#! perl use strict; use warnings; use Test::More tests => 12; BEGIN { use_ok('UNIVERSAL::isa', 'isa') }; no warnings 'UNIVERSAL::isa'; # class method { package Foo; sub new { bless \(my $self), shift; } sub isa { 1 } } # delegates calls to Foo { package Bar; sub isa { return 1 if $_[1] eq 'Foo'; } } # 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( @_ ); } sub isa { my $self = shift; $$self->can( 'isa' )->( @_ ); } } # wraps a Foo object { package Quux; use vars '$AUTOLOAD'; sub isa; sub new { my $class = shift; my $foo = Foo->new(); bless \$foo, $class; } sub can { my $self = shift; return $$self->can( @_ ); } sub AUTOLOAD { my $self = shift; my ($method) = $AUTOLOAD =~ /::(\w+)$/; $$self->$method( @_ ); } sub DESTROY {} } my $quux = Quux->new(); ok( isa( 'Bar', 'Foo' ), 'isa() should work on class methods too' ); ok( ! isa( 'Baz', 'Foo' ), '... but not for non-existant classes' ); ok( isa( $quux, 'Foo' ), '... and should work on delegated wrappers' ); is( scalar(isa(undef, 'Foo')), undef, 'isa on undef returns undef'); SKIP: { eval { require CGI }; skip( 'CGI not installed; RT #19671', 1 ) if $@; isa_ok( CGI->new(''), 'CGI' ); } # overloaded objects { package Qibble; use overload '""' => sub { die }; no warnings 'once'; *new = \&Foo::new; } my $qibble = Qibble->new(); ok( isa( $qibble, 'Qibble' ), '... can test ISA on landmines'); my $proxy = FooProxy->new(); isa_ok( $proxy, 'Foo' ); # valid use of isa() as static method on undefined class TODO: { my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= shift }; use warnings 'UNIVERSAL::isa'; local $TODO = 'Apparently broken in 5.6.x' if $] < 5.007; ok( ! UnloadedClass->isa( 'UNIVERSAL' ), 'unloaded class should not inherit from UNIVERSAL' ); is( $warnings, '', '... and should not warn' ); } # on an unloaded class { my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= shift }; use warnings 'UNIVERSAL::isa'; UNIVERSAL::isa("Foo", "Bar"); like( $warnings, qr/Called UNIVERSAL::isa/, 'warning on unloaded class given class (RT #24822)' ); UNIVERSAL::isa(bless({}, "Foo"), "Bar"); like( $warnings, qr/Called UNIVERSAL::isa/, 'warning on unloaded class given object (RT #24882)' ); } UNIVERSAL-isa-1.03/t/warnings.t000064400000000000000000000034341126646004600160460ustar00rootroot00000000000000#! perl use strict; use warnings; use Test::More tests => 9; BEGIN { use_ok('UNIVERSAL::isa', 'isa') }; use warnings 'UNIVERSAL::isa'; { package Foo; sub isa { 1 } } { package Bar; } my $foo = bless {}, 'Foo'; my $bar = bless {}, 'bar'; { my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; UNIVERSAL::isa( $foo, 'Foo' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, 'U::i should warn by default when redirecting to overridden method' ); $warning = ''; UNIVERSAL::isa( $foo, 'Bar' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, '... even if isa() would return false' ); $warning = ''; UNIVERSAL::isa( $bar, 'Foo' ); is( $warning, '', '... but not by default on default isa()' ); $warning = ''; UNIVERSAL::isa( $bar, 'Bar' ); is( $warning, '', '... even when it would return false' ); } { UNIVERSAL::isa::->import( 'verbose' ); my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; UNIVERSAL::isa( $foo, 'Foo' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, 'U::i should warn when verbose when redirecting to overridden method' ); $warning = ''; UNIVERSAL::isa( $foo, 'Bar' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, '... even if isa() would return false' ); $warning = ''; UNIVERSAL::isa( $bar, 'Foo' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, '... and on default isa()' ); $warning = ''; UNIVERSAL::isa( $bar, 'Bar' ); like( $warning, qr/Called UNIVERSAL::isa\(\) as a function.+warnings.t/, '... even when it would return false' ); }