#! perl

use strict;
use warnings;

use Test::More tests => 12;

BEGIN { use_ok('UNIVERSAL::isa', 'isa') };

no warnings 'UNIVERSAL::isa';

# class method

{
    package Foo;

    sub new
    {
        bless \(my $self), shift;
    }

    sub isa { 1 }
}

# delegates calls to Foo
{
    package Bar;

    sub isa
    {
        return 1 if $_[1] eq 'Foo';
    }
}

# really delegates calls to Foo
{
    package FooProxy;

    sub new
    {
        my $class = shift;
        my $foo   = Foo->new( @_ );
        bless \$foo, $class;
    }

    sub can
    {
        my $self = shift;
        return $$self->can( @_ );
    }

    sub isa
    {
        my $self = shift;
        $$self->can( 'isa' )->( @_ );
    }
}

# wraps a Foo object
{
    package Quux;

    use vars '$AUTOLOAD';
    sub isa;

    sub new
    {
        my $class = shift;
        my $foo   = Foo->new();
        bless \$foo, $class;
    }

    sub can
    {
        my $self = shift;
        return $$self->can( @_ );
    }

    sub AUTOLOAD
    {
        my $self     = shift;
        my ($method) = $AUTOLOAD =~ /::(\w+)$/;
        $$self->$method( @_ );
    }

    sub DESTROY {}
}

my $quux = Quux->new();

ok(   isa( 'Bar', 'Foo' ), 'isa() should work on class methods too'    );
ok( ! isa( 'Baz', 'Foo' ), '... but not for non-existant classes'      );
ok(   isa( $quux, 'Foo' ), '... and should work on delegated wrappers' );

is( scalar(isa(undef, 'Foo')), undef, 'isa on undef returns undef');

SKIP: {
    eval { require CGI };
    skip( 'CGI not installed; RT #19671', 1 ) if $@;

    isa_ok( CGI->new(''), 'CGI' );
}

# overloaded objects
{
    package Qibble;
    use overload '""' => sub { die };
    no warnings 'once';
    *new = \&Foo::new;
}

my $qibble = Qibble->new();

ok(   isa( $qibble, 'Qibble' ), '... can test ISA on landmines');

my $proxy = FooProxy->new();
isa_ok( $proxy, 'Foo' );

# valid use of isa() as static method on undefined class
TODO: {
    my $warnings         = '';
    local $SIG{__WARN__} = sub { $warnings .= shift };
    use warnings 'UNIVERSAL::isa';

    local $TODO = 'Apparently broken in 5.6.x' if $] < 5.007;

    ok( ! UnloadedClass->isa( 'UNIVERSAL' ),
        'unloaded class should not inherit from UNIVERSAL' );
    is( $warnings, '', '... and should not warn' );
}

# on an unloaded class
{
    my $warnings         = '';
    local $SIG{__WARN__} = sub { $warnings .= shift };
    use warnings 'UNIVERSAL::isa';

    UNIVERSAL::isa("Foo", "Bar");
    like( $warnings, qr/Called UNIVERSAL::isa/,
        'warning on unloaded class given class (RT #24822)' );

    UNIVERSAL::isa(bless({}, "Foo"), "Bar");
    like( $warnings, qr/Called UNIVERSAL::isa/,
        'warning on unloaded class given object (RT #24882)' );
}