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

   1 package UNIVERSAL::can;
   2
   3 use strict;
   4 use warnings;
   5
   6 use vars qw( $VERSION $recursing );
   7 $VERSION = '1.15';
   8
   9 use Scalar::Util 'blessed';
  10 use warnings::register;
  11
  12 my $orig;
  13 use vars '$always_warn';
  14
  15 BEGIN
  16 {
  17     $orig = \&UNIVERSAL::can;
  18
  19     no warnings 'redefine';
  20     *UNIVERSAL::can = \&can;
  21 }
  22
  23 sub import
  24 {
  25     my $class = shift;
  26     for my $import (@_)
  27     {
  28         $always_warn = 1 if $import eq '-always_warn';
  29         no strict 'refs';
  30         *{ caller() . '::can' } = \&can if $import eq 'can';
  31     }
  32 }
  33
  34 sub can
  35 {
  36     my $caller = caller();
  37     local $@;
  38
  39     # don't get into a loop here
  40     goto &$orig if $recursing
  41                 || (   defined $caller
  42                    &&  defined $_[0]
  43                    &&  eval { $caller->isa( $_[0] ); } );
  44
  45     # call an overridden can() if it exists
  46     my $can = eval { $_[0]->$orig('can') || 0 };
  47
  48     # but only if it's a real class
  49     goto &$orig unless $can;
  50
  51     # but not if it inherited this one
  52     goto &$orig if     $can == \&UNIVERSAL::can;
  53
  54     # redirect to an overridden can, making sure not to recurse and warning
  55     local $recursing = 1;
  56     my    $invocant  = shift;
  57
  58     _report_warning();
  59     return $invocant->can(@_);
  60 }
  61
  62 sub _report_warning
  63 {
  64     if ( $always_warn || warnings::enabled() )
  65     {
  66         my $calling_sub = ( caller(2) )[3] || '';
  67         warnings::warn("Called UNIVERSAL::can() as a function, not a method")
  68             if $calling_sub !~ /::can$/;
  69     }
  70
  71     return;
  72 }
  73
  74 1;
  75 __END__
  76
  77 =head1 NAME
  78
  79 UNIVERSAL::can - Hack around people calling UNIVERSAL::can() as a function
  80
  81 =head1 VERSION
  82
  83 Version 1.14
  84
  85 =head1 SYNOPSIS
  86
  87 To use this module, simply:
  88
  89   use UNIVERSAL::can;
  90
  91 =head1 DESCRIPTION
  92
  93 The UNIVERSAL class provides a few default methods so that all objects can use
  94 them.  Object orientation allows programmers to override these methods in
  95 subclasses to provide more specific and appropriate behavior.
  96
  97 Some authors call methods in the UNIVERSAL class on potential invocants as
  98 functions, bypassing any possible overriding.  This is wrong and you should not
  99 do it.  Unfortunately, not everyone heeds this warning and their bad code can
 100 break your good code.
 101
 102 This module replaces C<UNIVERSAL::can()> with a method that checks to see if
 103 the first argument is a valid invocant has its own C<can()> method.  If so, it
 104 gives a warning and calls the overridden method, working around buggy code.
 105 Otherwise, everything works as you might expect.
 106
 107 Some people argue that you must call C<UNIVERSAL::can()> as a function because
 108 you don't know if your proposed invocant is a valid invocant.  That's silly.
 109 Use C<blessed()> from L<Scalar::Util> if you want to check that the potential
 110 invocant is an object or call the method anyway in an C<eval> block and check
 111 for failure (though check the exception I<returned>, as a poorly-written
 112 C<can()> method could break Liskov and throw an exception other than "You can't
 113 call a method on this type of invocant").
 114
 115 Just don't break working code.
 116
 117 =head1 AUTHOR
 118
 119 chromatic, C<< <chromatic@wgz.org> >>
 120
 121 =head1 BUGS
 122
 123 Please report any bugs or feature requests to C<bug-universal-can@rt.cpan.org>,
 124 or through the web interface at
 125 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=UNIVERSAL-can>.  This will
 126 contact me, hold onto patches so I don't drop them, and will notify you of
 127 progress on your request as I make changes.
 128
 129 =head1 ACKNOWLEDGEMENTS
 130
 131 Inspired by L<UNIVERSAL::isa> by Yuval Kogman, Autrijus Tang, and myself.
 132
 133 Adam Kennedy has tirelessly made me tired by reporting potential bugs and
 134 suggesting ideas that found actual bugs.
 135
 136 Mark Clements helped to track down an invalid invocant bug.
 137
 138 Curtis "Ovid" Poe finally provided the inspiration I needed to clean up the
 139 interface.
 140
 141 Peter du Marchie van Voorthuysen identified and fixed a problem with calling
 142 C<SUPER::can>.
 143
 144 The Perl QA list had a huge... discussion... which inspired my realization that
 145 this module needed to do what it does now.
 146
 147 =head1 COPYRIGHT & LICENSE
 148
 149 Artistic License 2.0, copyright (c) 2005 - 2009 chromatic. Some rights
 150 reserved.
 151
 152 =cut