File Coverage

blib/lib/Test/MockObject/Extends.pm

Criterion	Covered	Total	%
statement	121	127	95.2
branch	20	24	83.3
condition	2	3	66.6
subroutine	27	28	96.4
pod	10	10	100.0
total	180	192	93.7

package Test::MockObject::Extends;
$Test::MockObject::Extends::VERSION = '1.20161202';
use strict;
use warnings;

use Test::MockObject;

# Alias our 'import' to T:MO::import to handle this:
#    use Test::MockObject::Extends '-debug';
*import = \&Test::MockObject::import;

use Devel::Peek  'CvGV';
use Scalar::Util 'blessed';

use constant PERL_5_9 => $^V gt v5.9.0;

sub new
{
    my ($class, $fake_class) = @_;

    return Test::MockObject->new() unless defined $fake_class;

    my $parent_class = $class->get_class( $fake_class );
    $class->check_class_loaded( $parent_class );
    my $self         = blessed( $fake_class ) ? $fake_class : {};

    # Fields now locks the hash as of 5.9.0 - #84535
    if (PERL_5_9 && blessed( $fake_class ) && do {
            no strict 'refs';
            exists ${$parent_class . '::'}{FIELDS} # uses fields
    }) {
        # bypass prototypes
        &Hash::Util::unlock_hash(\%$fake_class);
        bless $self, $class->gen_package( $parent_class );
        &Hash::Util::lock_keys(\%$fake_class,
            fields::_accessible_keys($parent_class));
    }
    else
    {
        bless $self, $class->gen_package( $parent_class );
    }

    return $self;
}

sub check_class_loaded
{
    my ($self, $parent_class) = @_;
    my $result                = Test::MockObject->check_class_loaded(
        $parent_class
    );
    return $result if $result;

    (my $load_class  = $parent_class) =~ s/::/\//g;
    require $load_class . '.pm';
}

sub get_class
{
    my ($self, $invocant) = @_;

    return $invocant unless blessed $invocant;
    return ref $invocant;
}

my $packname = 'a';

sub gen_package
{
    my ($class, $parent)         = @_;
    my $package                  = 'T::MO::E::' . $packname++;

    no strict 'refs';
    *{ $package . '::mock'          } = \&mock;
    *{ $package . '::unmock'        } = \&unmock;
    @{ $package . '::ISA'           } = ( $parent );
    *{ $package . '::can'           } = $class->gen_can( $parent );
    *{ $package . '::isa'           } = $class->gen_isa( $parent );
    *{ $package . '::AUTOLOAD'      } = $class->gen_autoload( $parent );
    *{ $package . '::__get_parents' } = $class->gen_get_parents( $parent );

    return $package;
}

sub gen_get_parents
{
    my ($self, $parent) = @_;
    return sub
    {
        no strict 'refs';
        return @{ $parent . '::ISA' };
    };
}

sub gen_isa
{
    my ($class, $parent)    = @_;

    sub
    {
        local *__ANON__    = 'isa';
        my ($self, $class) = @_;
        return 1 if $class eq $parent;
        my $isa = $parent->can( 'isa' );
        return $isa->( $self, $class );
    };
}

sub gen_can
{
    my ($class, $parent) = @_;

    sub
    {
        local *__ANON__     = 'can';
        my ($self, $method) = @_;
        my $parent_method   = $self->SUPER::can( $method );
        return $parent_method if $parent_method;
        return Test::MockObject->can( $method );
    };
}

sub gen_autoload
{
    my ($class, $parent) = @_;

    sub
    {
        our $AUTOLOAD;

        my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, ':' ) +1 );
        return if $method eq 'DESTROY';

        my $self   = shift;

        if (my $parent_method  = $parent->can( $method ))
        {
            return $self->$parent_method( @_ );
        }
        elsif (my $mock_method = Test::MockObject->can( $method ))
        {
            return $self->$mock_method( @_ );
        }
        elsif (my $parent_al = $parent->can( 'AUTOLOAD' ))
        {
            my ($parent_pack) = CvGV( $parent_al ) =~ /\*(.*)::AUTOLOAD/;
            {
                no strict 'refs';
                ${ "${parent_pack}::AUTOLOAD" } = "${parent}::${method}";
            }
            unshift @_, $self;
            goto &$parent_al;
        }
        else
        {
            die "Undefined method $method at ", join( ' ', caller() ), "\n";
        }
    };
}

sub mock
{
    my ($self, $name, $sub) = @_;

    Test::MockObject::_set_log( $self, $name, ( $name =~ s/^-// ? 0 : 1 ) );

    my $mock_sub = sub
    {
        my ($self) = @_;
        $self->log_call( $name, @_ );
        $sub->( @_ );
    };

    {
        no strict 'refs';
        no warnings 'redefine';
        *{ ref( $self ) . '::' . $name } = $mock_sub;
    }

    return $self;
}

sub unmock
{
    my ($self, $name) = @_;

    Test::MockObject::_set_log( $self, $name, 0 );
    no strict 'refs';
    my $glob = *{ ref( $self ) . '::' };
    delete $glob->{ $name };
    return $self;
}

1;
__END__