Главная   Изменения   Спек   Патчи   Исходники   Загрузить   Gear   Bugs and FR  Repocop 

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 <cpan@audreyt.org>'
  - 'chromatic <chromatic@wgz.org>'
  - 'Yuval Kogman <nothingmuch@woobling.org>'
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 <cpan@audreyt.org>

    chromatic <chromatic@wgz.org>

    Yuval Kogman <nothingmuch@woobling.org>

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<UNIVERSAL/isa> as a function, a kitten using
L<Test::MockObject> dies. Normally, the kittens would be helpless, but if they
use L<UNIVERSAL::isa> (the module whose docs you are reading), the kittens can
live long and prosper.

This module replaces C<UNIVERSAL::isa> with a version that makes sure that,
when called as a function on objects which override C<isa>, C<isa> will call
the appropriate method on those objects

In all other cases, the real C<UNIVERSAL::isa> gets called directly.

=head1 WARNINGS

If the lexical warnings pragma is available, this module will emit a warning
for each naughty invocation of C<UNIVERSAL::isa>. 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<active> 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<all> 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<verbose> 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<UNIVERSAL::can> for another discussion of the problem at hand.

L<Test::MockObject> for one example of a module that really needs to override
C<isa()>.

Any decent explanation of OO to understand why calling methods as functions is
a staggeringly bad idea.

=head1 AUTHORS

Audrey Tang <cpan@audreyt.org>

chromatic <chromatic@wgz.org>

Yuval Kogman <nothingmuch@woobling.org>

=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' );
}