File Coverage

blib/lib/Test/Mock/One.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	42	42	100.0
condition	8	9	88.8
subroutine	11	12	91.6
pod	3	3	100.0
total	133	135	98.5

package Test::Mock::One;
use warnings;
use strict;

# ABSTRACT: Mock the world with one object

our $VERSION = '0.011';

our $AUTOLOAD;

use overload '""' => '__x_mock_str';

use List::Util 1.33 qw(any);

sub new {
    my $class = shift;
    return bless({@_}, ref($class) || $class);
}

sub can {
    my ($self, $can) = @_;
    if (!exists $self->{$can} && $self->{"X-Mock-Strict"}) {
        return 0;
    }
    return 1;
}

sub AUTOLOAD {
    my $self = shift;

    my ($call) = $AUTOLOAD =~ /([^:]+)$/;

    if ($self->{'X-Mock-Called'}) {
        my @caller = caller(1);
        push(@{ $self->{'X-Mock-Called-By'}{$call}{$caller[3]}}, [ @_ ]);
    }

    if (exists $self->{$call}) {
        my $ref = ref $self->{$call};
        if ($ref eq 'HASH') {
            return $self->new( __x_mock_copy_x($self), %{ $self->{$call} });
        }
        elsif ($ref eq 'ARRAY') {
            return $self->new(__x_mock_copy_x($self), map { $_ => $self } @{ $self->{$call} });
        }
        elsif ($ref eq 'CODE') {
            if ($self->{'X-Mock-SelfArg'}) {
                return $self->{$call}->($self, @_);
            }
            return $self->{$call}->(@_);
        }
        elsif ($ref eq 'REF') {
            return ${ $self->{$call} };
        }
        return $self->{$call};
    }
    elsif ($self->{"X-Mock-Strict"}) {
        die sprintf("Using %s in strict mode, called undefined function '%s'",
          __PACKAGE__, $call);
    }
    return $self;
}

sub isa {
    my ($self, $class) = @_;

    if (my $isas = $self->{"X-Mock-ISA"}) {
        my $ref = ref $isas;
        if (!$ref && $isas eq $class) {
            return 1;
        }
        elsif ($ref eq 'ARRAY') {
            return 1 if any { $_ eq $class } @$isas;
        }
        elsif ($ref eq 'CODE') {
            if ($self->{'X-Mock-SelfArg'}) {
                return $isas->($self, $class);
            }
            return $isas->($class);
        }
        elsif ($ref eq "Regexp") {
            return $class =~ /$isas/;
        }
        return 0;
    }
    elsif (exists $self->{"X-Mock-ISA"}) {
        return 0;
    }
    return 1;
}

# Just an empty method to prevent weird AUTOLOAD loops
sub DESTROY { }

my @__xattr = qw(Strict ISA Stringify SelfArg);

sub __x_mock_copy_x {
    my ($orig) = @_;
    my %copy;
    foreach (@__xattr) {
        my $attr = "X-Mock-$_";
        if (exists $orig->{$attr}) {
            $copy{$attr} = $orig->{$attr};
        }
    }
    return %copy;
}

sub __x_mock_str {
    my ($self) = @_;
    if (my $stringify = $self->{'X-Mock-Stringify'}) {
        if (ref $stringify eq 'CODE') {
            if ($self->{'X-Mock-SelfArg'}) {
                return $stringify->($self);
            }
            return $stringify->();
        }
        return $stringify;
    }
    return __PACKAGE__ . " stringified";
}

1;

__END__