1use strict;
2use warnings;
3package UNIVERSAL::isa; # git description: 1.20150614-11-gdfa589a
4# ABSTRACT: Attempt to recover from people calling UNIVERSAL::isa as a function
5
6our $VERSION = '1.20171012';
7
8use 5.006002;
9
10use Scalar::Util ();
11use warnings::register; # creates a warnings category for this module
12
13my ( $orig, $verbose_warning );
14
15BEGIN { $orig = \&UNIVERSAL::isa }
16
17sub original_isa { goto $orig }
18
19sub 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
31our $_recursing;
32
33no warnings 'redefine';
34sub UNIVERSAL::isa
35{
36    goto &original_isa if $_recursing;
37    my $type = _invocant_type(@_);
38    $type->(@_);
39}
40use warnings;
41
42sub _invocant_type
43{
44    my $invocant = shift;
45    return \&_nonsense unless defined($invocant);
46    return \&_object_or_class if Scalar::Util::blessed($invocant);
47    return \&_reference       if ref($invocant);
48    return \&_nonsense unless $invocant;
49    return \&_object_or_class;
50}
51
52sub _nonsense
53{
54    _report_warning('on invalid invocant') if $verbose_warning;
55    return;
56}
57
58sub _object_or_class
59{
60    local $@;
61    local $_recursing = 1;
62
63    if ( my $override = eval { $_[0]->can('isa') } )
64    {
65        unless ( $override == \&UNIVERSAL::isa )
66        {
67            _report_warning();
68            my $obj = shift;
69            return $obj->$override(@_);
70        }
71    }
72
73    _report_warning() if $verbose_warning;
74    goto &original_isa;
75}
76
77sub _reference
78{
79    _report_warning('Did you mean to use Scalar::Util::reftype() instead?')
80        if $verbose_warning;
81    goto &original_isa;
82}
83
84sub _report_warning
85{
86    my $extra = shift;
87    $extra = $extra ? " ($extra)" : '';
88
89    if ( warnings::enabled() )
90    {
91        # check calling sub
92        return if (( caller(3) )[3] || '') =~ /::isa$/;
93        # check calling package - exempt Test::Builder??
94        return if (( caller(3) )[0] || '') =~ /^Test::Builder/;
95        return if (( caller(2) )[0] || '') =~ /^Test::Stream/;
96
97        warnings::warn(
98            "Called UNIVERSAL::isa() as a function, not a method$extra" );
99    }
100}
101
102__PACKAGE__;
103
104__END__
105
106=pod
107
108=encoding UTF-8
109
110=head1 NAME
111
112UNIVERSAL::isa - Attempt to recover from people calling UNIVERSAL::isa as a function
113
114=head1 VERSION
115
116version 1.20171012
117
118=head1 SYNOPSIS
119
120    # from the shell
121    echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile
122
123    # within your program
124    use UNIVERSAL::isa;
125
126    # enable warnings for all dodgy uses of UNIVERSAL::isa
127    use UNIVERSAL::isa 'verbose';
128
129=head1 DESCRIPTION
130
131Whenever you use L<UNIVERSAL/isa> as a function, a kitten using
132L<Test::MockObject> dies. Normally, the kittens would be helpless, but if they
133use L<UNIVERSAL::isa> (the module whose docs you are reading), the kittens can
134live long and prosper.
135
136This module replaces C<UNIVERSAL::isa> with a version that makes sure that,
137when called as a function on objects which override C<isa>, C<isa> will call
138the appropriate method on those objects
139
140In all other cases, the real C<UNIVERSAL::isa> gets called directly.
141
142B<NOTE:> You should use this module only for debugging purposes. It does not
143belong as a dependency in running code.
144
145=head1 FUNCTIONS
146
147=head2 original_isa
148
149This sub contains the definition of the I<original> C<UNIVERSAL::isa>
150definition, in case you need it.
151
152=head1 WARNINGS
153
154If the lexical warnings pragma is available, this module will emit a warning
155for each naughty invocation of C<UNIVERSAL::isa>. Silence these warnings by
156saying:
157
158    no warnings 'UNIVERSAL::isa';
159
160in the lexical scope of the naughty code.
161
162After version 1.00, warnings only appear when naughty code calls
163UNIVERSAL::isa() as a function on an invocant for which there is an overridden
164isa().  These are really truly I<active> bugs, and you should fix them rather
165than relying on this module to find them.
166
167To get warnings for all potentially dangerous uses of UNIVERSAL::isa() as a
168function, not a method (that is, for I<all> uses of the method as a function,
169which are latent bugs, if not bugs that will break your code as it exists now),
170pass the C<verbose> flag when using the module.  This can generate many extra
171warnings, but they're more specific as to the actual wrong practice and they
172usually suggest proper fixes.
173
174=head1 SEE ALSO
175
176L<Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa>
177
178L<UNIVERSAL::can> for another discussion of the problem at hand.
179
180L<Test::MockObject> for one example of a module that really needs to override
181C<isa()>.
182
183Any decent explanation of OO to understand why calling methods as functions is
184a staggeringly bad idea.
185
186=head1 SUPPORT
187
188Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=UNIVERSAL-isa>
189(or L<bug-UNIVERSAL-isa@rt.cpan.org|mailto:bug-UNIVERSAL-isa@rt.cpan.org>).
190
191=head1 AUTHORS
192
193=over 4
194
195=item *
196
197Audrey Tang <cpan@audreyt.org>
198
199=item *
200
201chromatic <chromatic@wgz.org>
202
203=item *
204
205יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
206
207=back
208
209=head1 CONTRIBUTORS
210
211=for stopwords Karen Etheridge Graham Knop Ricardo Signes
212
213=over 4
214
215=item *
216
217Karen Etheridge <ether@cpan.org>
218
219=item *
220
221Graham Knop <haarg@haarg.org>
222
223=item *
224
225Ricardo Signes <rjbs@cpan.org>
226
227=back
228
229=head1 COPYRIGHT AND LICENCE
230
231This software is copyright (c) 2011 by chromatic@wgz.org.
232
233This is free software; you can redistribute it and/or modify it under
234the same terms as the Perl 5 programming language system itself.
235
236=cut
237