File Coverage

blib/lib/Test/MonkeyMock.pm

Criterion	Covered	Total	%
statement	136	138	98.5
branch	51	62	82.2
condition	26	30	86.6
subroutine	18	19	94.7
pod	8	8	100.0
total	239	257	93.0

package Test::MonkeyMock;

use strict;
use warnings;

require Carp;

our $VERSION = '0.12';

my $registry      = {};
my $magic_counter = 0;

sub new {
    my $class = shift;
    $class = ref $class if ref $class;
    my ($instance) = @_;

    my $new_package;

    if ($instance) {
        $new_package =
            __PACKAGE__ . '::'
          . ref($instance)
          . '::__instance__'
          . ($magic_counter++);

        no strict 'refs';
        @{$new_package . '::ISA'} = (ref($instance));
    }
    else {
        $instance = {};
        $new_package = __PACKAGE__ . '::' . ($magic_counter++);

        no strict 'refs';
        @{$new_package . '::ISA'} = __PACKAGE__;
    }

    no strict 'refs';
    for my $method (
        qw/
        mock
        mocked_called
        mocked_call_args
        mocked_call_stack
        mocked_return_args
        mocked_return_stack
        /
      )
    {
        *{$new_package . '::' . $method} = sub { goto &$method };
    }

    bless $instance, $new_package;

    return $instance;
}

sub mock {
    my $self = shift;
    my ($method, $code, %options) = @_;

    if (ref($self) =~ m/__instance__/) {
        Carp::croak("Unknown method '$method'")
          unless my $orig_method = $self->can($method);

        if (exists $registry->{ref($self)}->{'mocks'}->{$method}) {
            push @{$registry->{ref($self)}->{'mocks'}->{$method}},
              {code => $code, orig_code => $orig_method};
            return $self;
        }

        my $ref_self = ref($self);
        my $package  = __PACKAGE__;
        $ref_self =~ s/^${package}::(.*)::__instance__\d+/$1/;

        my $new_package =
          __PACKAGE__ . '::' . $ref_self . '::__instance__' . $magic_counter++;

        $registry->{$new_package} = $registry->{ref($self)};

        my $mocks = $registry->{$new_package}->{'mocks'} ||= {};
        $mocks->{$method} =
          [{code => $code, orig_code => $orig_method, options => \%options}];

        no strict 'refs';
        @{$new_package . '::ISA'} = ref($self);
        *{$new_package . '::' . $method} = sub {
            _dispatch($new_package, $method, @_);
        };

        bless $self, $new_package;
    }
    else {
        my $mocks = $registry->{ref($self)}->{'mocks'} ||= {};
        push @{$mocks->{$method}},
          {
            code    => $code,
            options => \%options
          };
    }

    return $self;
}

sub mocked_called {
    my $self = shift;
    my ($method) = @_;

    my $mocks = $registry->{ref($self)}->{'mocks'} ||= {};
    my $calls = $registry->{ref($self)}->{'calls'} ||= {};

    if (ref($self) =~ m/__instance__/) {
        Carp::croak("Unknown method '$method'")
          unless $self->can($method);
    }
    else {
        Carp::croak("Unmocked method '$method'")
          unless exists $mocks->{$method};
    }

    return $calls->{$method}->{called} || 0;
}

sub mocked_call_args {
    my $self = shift;
    my ($method, $frame) = @_;

    $frame ||= 0;

    my $stack = $self->mocked_call_stack($method);

    Carp::croak("Unknown frame '$frame'")
      unless @$stack > $frame;

    return @{$stack->[$frame]};
}

sub mocked_call_stack {
    my $self = shift;
    my ($method) = @_;

    Carp::croak("Method is required") unless $method;

    my $calls = $registry->{ref($self)}->{'calls'} ||= {};
    my $mocks = $registry->{ref($self)}->{'mocks'} ||= {};

    if (ref($self) =~ m/__instance__/) {
        Carp::croak("Unknown method '$method'")
          unless $self->can($method);
    }
    else {
        Carp::croak("Unmocked method '$method'")
          unless exists $mocks->{$method};
    }

    Carp::croak("Method '$method' was not called")
      unless exists $calls->{$method};

    return $calls->{$method}->{stack};
}

sub mocked_return_args {
    my $self = shift;
    my ($method, $frame) = @_;

    $frame ||= 0;

    my $stack = $self->mocked_return_stack($method);

    Carp::croak("Unknown frame '$frame'")
      unless @$stack > $frame;

    return @{$stack->[$frame]};
}

sub mocked_return_stack {
    my $self = shift;
    my ($method) = @_;

    Carp::croak("Method is required") unless $method;

    my $returns = $registry->{ref($self)}->{'returns'} ||= {};
    my $mocks   = $registry->{ref($self)}->{'mocks'}   ||= {};

    if (ref($self) =~ m/__instance__/) {
        Carp::croak("Unknown method '$method'")
          unless $self->can($method);
    }
    else {
        Carp::croak("Unmocked method '$method'")
          unless exists $mocks->{$method};
    }

    Carp::croak("Method '$method' was not called")
      unless exists $returns->{$method};

    return $returns->{$method}->{stack};
}

sub can {
    my $self = shift;
    my ($method) = @_;

    if (ref($self) =~ m/__instance__/) {
        return $self->can($method);
    }
    else {
        my $mocks = $registry->{ref($self)}->{'mocks'} ||= {};
        return $mocks->{$method}->[0]->{code};
    }
}

sub DESTROY {}

our $AUTOLOAD;

sub AUTOLOAD {
    my $self = shift;

    my ($method) = (split /::/, $AUTOLOAD)[-1];

    return _dispatch(ref($self), $method, $self, @_);
}

sub _dispatch {
    my $ref_self = shift;
    my $method = shift;

    my $calls   = $registry->{$ref_self}->{'calls'}   ||= {};
    my $returns = $registry->{$ref_self}->{'returns'} ||= {};
    my $mocks   = $registry->{$ref_self}->{'mocks'}   ||= {};

    Carp::croak("Unmocked method '$method'")
      if !exists $mocks->{$method};

    foreach my $mock (@{$mocks->{$method}}) {
        if (my $options = $mock->{options}) {
            if (my $when = $options->{when}) {
                next unless $when->(@_);
            }

            if (defined(my $frame = $options->{frame})) {
                my $current_frame =
                  $returns->{$method}->{stack}
                  ? @{$returns->{$method}->{stack}}
                  : 0;
                next unless $frame == $current_frame;
            }
        }

        $calls->{$method}->{called}++;

        push @{$calls->{$method}->{stack}}, [@_[1 .. $#_]];

        my @result;

        if (my $code = $mock->{code}) {
            @result = $code->(@_);
        }
        elsif (my $orig_code = $mock->{orig_code}) {
            @result = $orig_code->(@_);
        }
        else {
            Carp::croak("Unmocked method '$method'");
        }

        push @{$returns->{$method}->{stack}}, [@result];

        return wantarray ? @result : $result[0];
    }
}

1;
__END__