#!/usr/bin/perl -w

package UNIVERSAL::isa;

use strict;
use vars qw/$VERSION $recursing/;

use UNIVERSAL ();

use Scalar::Util qw/blessed/;
use warnings::register;

$VERSION = "0.05";

my $orig;
BEGIN { $orig = \&UNIVERSAL::isa };

no warnings 'redefine';

sub import {
	no strict 'refs';
	*{caller() . "::isa"} = \&UNIVERSAL::isa if (@_ > 1 and $_[1] eq "isa");
}

sub UNIVERSAL::isa {
	# not an object or a class name, we can skip
	unless ( blessed($_[0]) )
	{
		if (not defined $_[0] or length $_[0] == 0) {
			# it's not a class, either... Retain orig behavior
			# for garbage as first arg
			goto &$orig;
		} else {
			# it's a string, which means it can be a class
			my $symtable = \%::;
			my $found    = 1;

			for my $symbol (split( '::', $_[0] )) {
				$symbol .= '::';
				unless (exists $symtable->{$symbol}) {
					$found = 0;
					last;
				}
				$symtable = $symtable->{$symbol};
			}

			# if it's not a class then it doesn't have it's own dispatch,
			# so we retain the original behavior
			goto &$orig unless $found;
		}
	}

	# if the object will *really* run a different 'isa' when we invoke it we
	# need to invoke it. On the other hand if it's not overridden, we just use
	# the original behavior
	goto &$orig if (UNIVERSAL::can($_[0], "isa") == \&UNIVERSAL::isa);

	# if we've been called from an overridden isa that we arranged to call, we
	# are either SUPER:: or explicitly called. in both cases the original ISA
	# behavior is expected.
	goto &$orig if $recursing;

	# the last possible case is that 'isa' is overridden
	local $recursing = 1;
	my $obj = shift;

	if (warnings::enabled()) {
		my $calling_sub  = ( caller( 1 ) )[3] || '';
		warnings::warn( "Called UNIVERSAL::isa() as a function, not a method" )
			if $calling_sub !~ /::isa$/;
	}

	return $obj->isa(@_);
}

__PACKAGE__;

__END__

=pod

=head1 NAME

UNIVERSAL::isa - Hack around stupid module authors using UNIVERSAL::isa as a
function when they shouldn't.

=head1 SYNOPSIS

	echo 'export PERL5OPT=-MUNIVERSAL::isa' >> /etc/profile

=head1 DESCRIPTION

Whenever you use L<UNIVERSAL/isa> as a function, a kitten using
L<Test::MockObject> dies. Normally, the kittens would be helpless, but if they
use L<UNIVERSAL::isa> (the module whose docs you are reading), the kittens can
live long and prosper.

This module replaces C<UNIVERSAL::isa> with a version that makes sure that if
it's called as a function on objects which override C<isa>, C<isa> will be
called on those objects as a method.

In all other cases the real C<UNIVERSAL::isa> is just called directly.

=head1 WARNINGS

If the lexical warnings pragma is available, a warning will be emitted for each
naughty invocation of C<UNIVERSAL::isa>. These warnings can be silenced by
saying:

	no warnings 'UNIVERSAL::isa';

in the lexical scope of the naughty code.

=head1 SEE ALSO

L<UNIVERSAL::can> for a more mature discussion of the problem at hand.

=head1 AUTHORS

Autrijus Tang <autrijus@autrijus.org>

chromatic <chromatic@wgz.org>

Yuval Kogman <nothingmuch@woobling.org>

=head1 COPYRIGHT & LICENSE

Same as perl, blah blah blah, (c) 2005

=cut