r24655 - in /branches/upstream/libuniversal-isa-perl/current: Build.PL Changes MANIFEST META.yml Makefile.PL README SIGNATURE lib/UNIVERSAL/isa.pm t/basic.t t/bugs.t t/warnings.t

dmn at users.alioth.debian.org dmn at users.alioth.debian.org
Wed Aug 27 11:46:04 UTC 2008


Author: dmn
Date: Wed Aug 27 11:46:02 2008
New Revision: 24655

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=24655
Log:
[svn-upgrade] Integrating new upstream version, libuniversal-isa-perl (1.01)

Added:
    branches/upstream/libuniversal-isa-perl/current/t/warnings.t
Removed:
    branches/upstream/libuniversal-isa-perl/current/Makefile.PL
    branches/upstream/libuniversal-isa-perl/current/SIGNATURE
Modified:
    branches/upstream/libuniversal-isa-perl/current/Build.PL
    branches/upstream/libuniversal-isa-perl/current/Changes
    branches/upstream/libuniversal-isa-perl/current/MANIFEST
    branches/upstream/libuniversal-isa-perl/current/META.yml
    branches/upstream/libuniversal-isa-perl/current/README
    branches/upstream/libuniversal-isa-perl/current/lib/UNIVERSAL/isa.pm
    branches/upstream/libuniversal-isa-perl/current/t/basic.t
    branches/upstream/libuniversal-isa-perl/current/t/bugs.t

Modified: branches/upstream/libuniversal-isa-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/Build.PL?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/Build.PL (original)
+++ branches/upstream/libuniversal-isa-perl/current/Build.PL Wed Aug 27 11:46:02 2008
@@ -1,16 +1,17 @@
-#!/usr/bin/perl -w
+#! perl
+
+BEGIN { require 5.006002 }
 
 use strict;
+use warnings;
 
 use Module::Build;
 
 Module::Build->new(
-	module_name => 'UNIVERSAL::isa',
-	license => 'perl',
-	requires => {
-		'perl' => '5.006',
-		'Scalar::Util' => 0,
-	},
-	create_makefile_pl => 'traditional',
-	sign => 1,
+    module_name => 'UNIVERSAL::isa',
+    license     => 'perl',
+    requires    => {
+        'perl' => '5.6.2',
+        'Scalar::Util' => 0,
+    },
 )->create_build_script;

Modified: branches/upstream/libuniversal-isa-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/Changes?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/Changes (original)
+++ branches/upstream/libuniversal-isa-perl/current/Changes Wed Aug 27 11:46:02 2008
@@ -1,12 +1,20 @@
 Changes for UNIVERSAL::isa
 --------------------------
 
+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
+    - 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
 
@@ -17,4 +25,4 @@
 0.02  Jul 03 2005
 
 0.01  Jun 30 2005
-	- initial release
+    - initial release

Modified: branches/upstream/libuniversal-isa-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/MANIFEST?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/MANIFEST (original)
+++ branches/upstream/libuniversal-isa-perl/current/MANIFEST Wed Aug 27 11:46:02 2008
@@ -1,11 +1,9 @@
 Build.PL
 Changes
 lib/UNIVERSAL/isa.pm
-Makefile.PL
-MANIFEST			This list of files
+MANIFEST            This list of files
 META.yml
 t/basic.t
 t/bugs.t
+t/warnings.t
 README
-SIGNATURE    Added here by Module::Build
-SIGNATURE    Added here by Module::Build

Modified: branches/upstream/libuniversal-isa-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/META.yml?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/META.yml (original)
+++ branches/upstream/libuniversal-isa-perl/current/META.yml Wed Aug 27 11:46:02 2008
@@ -1,16 +1,24 @@
 ---
 name: UNIVERSAL-isa
-version: 0.06
-author: ~
+version: 1.01
+author:
+  - 'Audrey Tang <cpan at audreyt.org>'
+  - 'chromatic <chromatic at wgz.org>'
+  - 'Yuval Kogman <nothingmuch at 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.006
+  perl: 5.6.2
 provides:
   UNIVERSAL::isa:
     file: lib/UNIVERSAL/isa.pm
-    version: 0.06
-generated_by: Module::Build version 0.2611
+    version: 1.01
+generated_by: Module::Build version 0.2808
+meta-spec:
+  url: http://module-build.sourceforge.net/META-spec-v1.2.html
+  version: 1.2

Modified: branches/upstream/libuniversal-isa-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/README?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/README (original)
+++ branches/upstream/libuniversal-isa-perl/current/README Wed Aug 27 11:46:02 2008
@@ -1,42 +1,46 @@
 UNIVERSAL::isa
 --------------
 
-Version 0.06 - Fri Feb 24 06:57:52 UTC 2006
+Version 1.01 - Fri Aug 22 05:29:08 UTC 2008
 
 Attempt to recover from people calling UNIVERSAL::isa as a function
 
-	# from the shell
-	echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
+    # from the shell
+    echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
 
-	# within your program
-	use UNIVERSAL::isa;
+    # 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
+    $ 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
+    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,
+    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
-    Autrijus Tang <autrijus at autrijus.org>
+    Audrey Tang <cpan at audreyt.org>
 
     chromatic <chromatic at wgz.org>
 
     Yuval Kogman <nothingmuch at woobling.org>
 
 COPYRIGHT & LICENSE
-    Same as Perl, (c) 2005 - 2006.
+
+    Artistic License 2.0, (c) 2005 - 2008.

Modified: branches/upstream/libuniversal-isa-perl/current/lib/UNIVERSAL/isa.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/lib/UNIVERSAL/isa.pm?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/lib/UNIVERSAL/isa.pm (original)
+++ branches/upstream/libuniversal-isa-perl/current/lib/UNIVERSAL/isa.pm Wed Aug 27 11:46:02 2008
@@ -1,89 +1,95 @@
-#!/usr/bin/perl -w
-
 package UNIVERSAL::isa;
 
 use strict;
-use vars qw/$VERSION $recursing/;
+use vars qw( $VERSION $recursing );
 
 use UNIVERSAL ();
 
-use Scalar::Util qw/blessed/;
+use Scalar::Util 'blessed';
 use warnings::register;
 
-$VERSION = "0.06";
+$VERSION = '1.01';
 
-my $orig;
-BEGIN { $orig = \&UNIVERSAL::isa };
+my ( $orig, $verbose_warning );
+
+BEGIN { $orig = \&UNIVERSAL::isa }
 
 no warnings 'redefine';
 
 sub import
 {
-	no strict 'refs';
-	*{caller() . "::isa"} = \&UNIVERSAL::isa if (@_ > 1 and $_[1] eq "isa");
+    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->( @_ );
+    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;
+    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;
+    report_warning('on invalid invocant') if $verbose_warning;
+    return;
 }
 
 sub object_or_class
 {
-	report_warning();
 
-	local $@;
-	local $recursing = 1;
+    local $@;
+    local $recursing = 1;
 
-	if ( my $override = eval { $_[0]->can( 'isa' ) } )
-	{
-		unless ( $override == \&UNIVERSAL::isa )
-		{
-			my $obj = shift;
-			return $obj->$override( @_ );
-		}
-	}
+    if ( my $override = eval { $_[0]->can('isa') } )
+    {
+        unless ( $override == \&UNIVERSAL::isa )
+        {
+            report_warning();
+            my $obj = shift;
+            return $obj->$override(@_);
+        }
+    }
 
-	goto &$orig;
+    report_warning() if $verbose_warning;
+    goto &$orig;
 }
 
 sub reference
 {
-	report_warning( "Did you mean to use Scalar::Util::reftype() instead?" );
-	goto &$orig;
+    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)" : '';
+    my $extra = shift;
+    $extra = $extra ? " ($extra)" : '';
 
-	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"
-		)
-	}
+    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__;
@@ -99,11 +105,14 @@
 
 =head1 SYNOPSIS
 
-	# from the shell
-	echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
+    # from the shell
+    echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
 
-	# within your program
-	use UNIVERSAL::isa;
+    # within your program
+    use UNIVERSAL::isa;
+
+    # enable warnings for all dodgy uses of UNIVERSAL::isa
+    use UNIVERSAL::isa 'verbose';
 
 =head1 DESCRIPTION
 
@@ -124,20 +133,35 @@
 for each naughty invocation of C<UNIVERSAL::isa>. Silence these warnings by
 saying:
 
-	no warnings 'UNIVERSAL::isa';
+    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 a more mature discussion of the problem at hand.
+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
 
-Autrijus Tang <autrijus at autrijus.org>
+Audrey Tang <cpan at audreyt.org>
 
 chromatic <chromatic at wgz.org>
 
@@ -145,6 +169,6 @@
 
 =head1 COPYRIGHT & LICENSE
 
-Same as Perl, (c) 2005 - 2006.
+Artistic Licence 2.0, (c) 2005 - 2008.
 
 =cut

Modified: branches/upstream/libuniversal-isa-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/t/basic.t?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/t/basic.t (original)
+++ branches/upstream/libuniversal-isa-perl/current/t/basic.t Wed Aug 27 11:46:02 2008
@@ -1,65 +1,157 @@
-#!/usr/bin/perl -w
+#! perl
 
 use strict;
+use warnings;
 
-use Test::More tests => 18;
+use Test::More tests => 47;
 
-BEGIN { use_ok("UNIVERSAL::isa", "isa") };
+BEGIN { use_ok('UNIVERSAL::isa', 'isa') };
 
-# no warnings "UNIVERSAL::isa";
 use warnings;
 
 {
-	package Foo;
+    package Foo;
 
-	sub isa {
-		1;
-	}
+    sub isa { 1 }
 }
 
 {
-	package Bar;
+    package Bar;
 }
 
 {
-	package Gorch;
-	sub isa {
-		my $self = shift;
-		my $class = shift;
-		($class eq "Dung") || $self->SUPER::isa($class);
-	}
+    package Gorch;
+    sub isa
+    {
+        my ($self, $class) = @_;
+        $self->SUPER::isa($class) unless $class eq 'Glab';
+    }
 }
 
 {
-	package Baz;
-	sub isa {
-		my $self = shift;
-		my $class = shift;
-		($class eq "Dung") || UNIVERSAL::isa($self, $class);
-	}
+    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 ($f, $b, $g, $x) = map { bless [], $_ } qw( Foo Bar Gorch Baz );
 
-ok(isa([], "ARRAY"), "10 is a scalar");
-ok(isa($b, "Bar"), "bar is a bar");
-ok(isa($f, "Foo"), "foo is a foo");
-ok(!isa($b, "Crap"), "bar isn't full of crap");
-ok(isa($f, "Crap"), "foo is full of crap");
-ok(isa($g, "Gorch"), "gorch is itself");
-ok(!isa($g, "Crap"), "gorch isn't crap");
-ok(isa($g, "Dung"), "it's dung");
-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';
-	no warnings 'once';
 
-	ok( isa( {},     'HASH' ),      'hash reference isa HASH'     );
-	ok( isa( [],     'ARRAY' ),     'array reference isa ARRAY'   );
-	ok( isa( sub {}, 'CODE' ),      'code reference isa CODE'     );
-	ok( isa( \my $a, 'SCALAR' ),    'scalar reference isa SCALAR' );
-	ok( isa( qr//, 'Regexp' ),      'regexp reference isa Regexp' );
-	ok( isa( \local *FOO, 'GLOB' ), 'glob reference isa GLOB'     );
+    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' );
+}

Modified: branches/upstream/libuniversal-isa-perl/current/t/bugs.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/t/bugs.t?rev=24655&op=diff
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/t/bugs.t (original)
+++ branches/upstream/libuniversal-isa-perl/current/t/bugs.t Wed Aug 27 11:46:02 2008
@@ -1,8 +1,9 @@
-#!/usr/bin/perl
+#! perl
 
 use strict;
+use warnings;
 
-use Test::More tests => 8;
+use Test::More tests => 10;
 
 BEGIN { use_ok('UNIVERSAL::isa', 'isa') };
 
@@ -11,74 +12,78 @@
 # class method
 
 {
-	package Foo;
+    package Foo;
 
-	sub new
-	{
-		bless \(my $self), shift;
-	}
+    sub new
+    {
+        bless \(my $self), shift;
+    }
 
-	sub isa {
-		1;
-	}
+    sub isa { 1 }
 }
 
 # delegates calls to Foo
 {
-	package Bar;
+    package Bar;
 
-	sub isa
-	{
-		return 1 if $_[1] eq 'Foo';
-	}
+    sub isa
+    {
+        return 1 if $_[1] eq 'Foo';
+    }
 }
 
 # really delegates calls to Foo
 {
-	package FooProxy;
+    package FooProxy;
 
-	sub new
-	{
-		my $class = shift;
-		my $foo   = Foo->new( @_ );
-		bless \$foo, $class;
-	}
+    sub new
+    {
+        my $class = shift;
+        my $foo   = Foo->new( @_ );
+        bless \$foo, $class;
+    }
 
-	sub can
-	{
-		my $self = shift;
-		return $$self->can( @_ );
-	}
+    sub can
+    {
+        my $self = shift;
+        return $$self->can( @_ );
+    }
+
+    sub isa
+    {
+        my $self = shift;
+        $$self->can( 'isa' )->( @_ );
+    }
 }
 
 # wraps a Foo object
 {
-	package Quux;
+    package Quux;
 
-	use vars '$AUTOLOAD';
-	sub isa;
+    use vars '$AUTOLOAD';
+    sub isa;
 
-	sub new
-	{
-		my $class = shift;
-		my $foo   = Foo->new();
-		bless \$foo, $class;
-	}
+    sub new
+    {
+        my $class = shift;
+        my $foo   = Foo->new();
+        bless \$foo, $class;
+    }
 
-	sub can
-	{
-		my $self = shift;
-		return $$self->can( @_ );
-	}
+    sub can
+    {
+        my $self = shift;
+        return $$self->can( @_ );
+    }
 
-	sub AUTOLOAD
-	{
-		my $self     = shift;
-		my ($method) = $AUTOLOAD =~ /::(\w+)$/;
-		$$self->$method( @_ );
-	}
+    sub AUTOLOAD
+    {
+        my $self     = shift;
+        my ($method) = $AUTOLOAD =~ /::(\w+)$/;
+        $$self->$method( @_ );
+    }
 
-	sub DESTROY {}
+    sub DESTROY {}
 }
 
 my $quux = Quux->new();
@@ -91,16 +96,14 @@
 
 eval { require CGI };
 
-unless ($@) {
-	isa_ok(CGI->new(''), "CGI");
-}
+isa_ok( CGI->new(''), 'CGI' ) unless $@;
 
 # overloaded objects
 {
-	package Qibble;
-	use overload '""' => sub { die };
-	no warnings 'once';
-	*new = \&Foo::new;
+    package Qibble;
+    use overload '""' => sub { die };
+    no warnings 'once';
+    *new = \&Foo::new;
 }
 
 my $qibble = Qibble->new();
@@ -109,3 +112,14 @@
 
 my $proxy = FooProxy->new();
 isa_ok( $proxy, 'Foo' );
+
+# valid use of isa() as static method on undefined class
+{
+    my $warnings         = '';
+    local $SIG{__WARN__} = sub { $warnings .= shift };
+    use warnings 'UNIVERSAL::isa';
+
+    ok( ! UnloadedClass->isa( 'UNIVERSAL' ),
+        'unloaded class should not inherit from UNIVERSAL' );
+    is( $warnings, '', '... and should not warn' );
+}

Added: branches/upstream/libuniversal-isa-perl/current/t/warnings.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libuniversal-isa-perl/current/t/warnings.t?rev=24655&op=file
==============================================================================
--- branches/upstream/libuniversal-isa-perl/current/t/warnings.t (added)
+++ branches/upstream/libuniversal-isa-perl/current/t/warnings.t Wed Aug 27 11:46:02 2008
@@ -1,0 +1,71 @@
+#! 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' );
+}




More information about the Pkg-perl-cvs-commits mailing list