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