File Coverage

blib/lib/Evo/Test/Mock.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	22	30	73.3
condition	3	3	100.0
subroutine	15	15	100.0
pod	0	4	0.0
total	110	122	90.1

package Evo::Test::Mock;
use Evo '-Class *; -Export; Carp croak; -Lib eval_want strict_opts; /::Call';
use Hash::Util::FieldHash 'fieldhash';

fieldhash my %REG;

has 'original_sub';
has 'original_name';
has 'calls';
has 'sub';

our $ORIGINAL;

sub get_original() : prototype() : Export {
  $ORIGINAL or die "Not in mocked subroutine";
}

sub call_original : Export { get_original->(@_); }

sub create_mock ($me, $name, @args) {
  my %args;
  %args = @args == 1 ? (patch => $args[0]) : @args;
  my ($patch, $rethrow) = strict_opts \%args, [qw(patch rethrow)], 2;

  no strict 'refs';    ## no critic
  my $orig = *{$name}{CODE} or die "No sub $name";
  croak "$name was already mocked" if $REG{$orig};

  my $mock_sub = ref $patch eq 'CODE' ? $patch : $patch ? sub { call_original(@_) } : sub { };

  my $calls = [];
  my $sub   = sub {
    local $ORIGINAL = $orig;
    my $rfn  = eval_want wantarray, @_, $mock_sub;
    my $err  = $@;
    my $call = Evo::Test::Call->new(args => \@_, exception => $err, result_fn => $rfn);
    push $calls->@*, $call;
    croak $err if !$rfn && $rethrow;
    return unless $rfn;
    $rfn->();
  };

  my $mock = $me->new(original_sub => $orig, original_name => $name, sub => $sub, calls => $calls);

  no warnings 'redefine';
  $REG{$sub}++;
  *{$name} = $sub;
  $mock;
}

sub get_call ($self, $n) {
  return unless exists $self->calls->[$n];
  $self->calls->[$n];
}

sub DESTROY($self) {
  ## no critic;
  no strict 'refs';
  no warnings 'redefine';
  *{${\$self->original_name}} = $self->original_sub;
}


1;

__END__