local-lib5/lib/perl5/UNIVERSAL/isa.pm

   1 package UNIVERSAL::isa;
   2
   3 use strict;
   4 use vars qw( $VERSION $recursing );
   5
   6 use UNIVERSAL ();
   7
   8 use Scalar::Util 'blessed';
   9 use warnings::register;
  10
  11 $VERSION = '1.03';
  12
  13 my ( $orig, $verbose_warning );
  14
  15 BEGIN { $orig = \&UNIVERSAL::isa }
  16
  17 no warnings 'redefine';
  18
  19 sub import
  20 {
  21     my $class = shift;
  22     no strict 'refs';
  23
  24     for my $arg (@_)
  25     {
  26         *{ caller() . '::isa' } = \&UNIVERSAL::isa if $arg eq 'isa';
  27         $verbose_warning = 1 if $arg eq 'verbose';
  28     }
  29 }
  30
  31 sub UNIVERSAL::isa
  32 {
  33     goto &$orig if $recursing;
  34     my $type = invocant_type(@_);
  35     $type->(@_);
  36 }
  37
  38 sub invocant_type
  39 {
  40     my $invocant = shift;
  41     return \&nonsense unless defined($invocant);
  42     return \&object_or_class if blessed($invocant);
  43     return \&reference       if ref($invocant);
  44     return \&nonsense unless $invocant;
  45     return \&object_or_class;
  46 }
  47
  48 sub nonsense
  49 {
  50     report_warning('on invalid invocant') if $verbose_warning;
  51     return;
  52 }
  53
  54 sub object_or_class
  55 {
  56
  57     local $@;
  58     local $recursing = 1;
  59
  60     if ( my $override = eval { $_[0]->can('isa') } )
  61     {
  62         unless ( $override == \&UNIVERSAL::isa )
  63         {
  64             report_warning();
  65             my $obj = shift;
  66             return $obj->$override(@_);
  67         }
  68     }
  69
  70     report_warning() if $verbose_warning;
  71     goto &$orig;
  72 }
  73
  74 sub reference
  75 {
  76     report_warning('Did you mean to use Scalar::Util::reftype() instead?')
  77         if $verbose_warning;
  78     goto &$orig;
  79 }
  80
  81 sub report_warning
  82 {
  83     my $extra = shift;
  84     $extra = $extra ? " ($extra)" : '';
  85
  86     if ( warnings::enabled() )
  87     {
  88         my $calling_sub = ( caller(3) )[3] || '';
  89         return if $calling_sub =~ /::isa$/;
  90         warnings::warn(
  91             "Called UNIVERSAL::isa() as a function, not a method$extra" );
  92     }
  93 }
  94
  95 __PACKAGE__;
  96
  97 __END__
  98
  99 =pod
 100
 101 =head1 NAME
 102
 103 UNIVERSAL::isa - Attempt to recover from people calling UNIVERSAL::isa as a
 104 function
 105
 106 =head1 SYNOPSIS
 107
 108     # from the shell
 109     echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
 110
 111     # within your program
 112     use UNIVERSAL::isa;
 113
 114     # enable warnings for all dodgy uses of UNIVERSAL::isa
 115     use UNIVERSAL::isa 'verbose';
 116
 117 =head1 DESCRIPTION
 118
 119 Whenever you use L<UNIVERSAL/isa> as a function, a kitten using
 120 L<Test::MockObject> dies. Normally, the kittens would be helpless, but if they
 121 use L<UNIVERSAL::isa> (the module whose docs you are reading), the kittens can
 122 live long and prosper.
 123
 124 This module replaces C<UNIVERSAL::isa> with a version that makes sure that,
 125 when called as a function on objects which override C<isa>, C<isa> will call
 126 the appropriate method on those objects
 127
 128 In all other cases, the real C<UNIVERSAL::isa> gets called directly.
 129
 130 =head1 WARNINGS
 131
 132 If the lexical warnings pragma is available, this module will emit a warning
 133 for each naughty invocation of C<UNIVERSAL::isa>. Silence these warnings by
 134 saying:
 135
 136     no warnings 'UNIVERSAL::isa';
 137
 138 in the lexical scope of the naughty code.
 139
 140 After version 1.00, warnings only appear when naughty code calls
 141 UNIVERSAL::isa() as a function on an invocant for which there is an overridden
 142 isa().  These are really truly I<active> bugs, and you should fix them rather
 143 than relying on this module to find them.
 144
 145 To get warnings for all potentially dangerous uses of UNIVERSAL::isa() as a
 146 function, not a method (that is, for I<all> uses of the method as a function,
 147 which are latent bugs, if not bugs that will break your code as it exists now),
 148 pass the C<verbose> flag when using the module.  This can generate many extra
 149 warnings, but they're more specific as to the actual wrong practice and they
 150 usually suggest proper fixes.
 151
 152 =head1 SEE ALSO
 153
 154 L<UNIVERSAL::can> for another discussion of the problem at hand.
 155
 156 L<Test::MockObject> for one example of a module that really needs to override
 157 C<isa()>.
 158
 159 Any decent explanation of OO to understand why calling methods as functions is
 160 a staggeringly bad idea.
 161
 162 =head1 AUTHORS
 163
 164 Audrey Tang <cpan@audreyt.org>
 165
 166 chromatic <chromatic@wgz.org>
 167
 168 Yuval Kogman <nothingmuch@woobling.org>
 169
 170 =head1 COPYRIGHT & LICENSE
 171
 172 Artistic Licence 2.0, (c) 2005 - 2009.
 173
 174 =cut