File Coverage

blib/lib/Test/MethodFixtures.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	33	40	82.5
condition	13	17	76.4
subroutine	16	16	100.0
pod	4	4	100.0
total	162	173	93.6

use strict;
use warnings;

package Test::MethodFixtures;

our $VERSION = '0.07';

use Carp;
use Hook::LexWrap qw( wrap );
use Scalar::Util qw( weaken blessed );
use version;

use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors(qw( mode storage _wrapped ));

our $DEFAULT_STORAGE = 'File';
our ( $MODE, $STORAGE );
my %VALID_MODES = (
    playback    => 1,    # default mode
    record      => 1,
    auto        => 1,
    passthrough => 1,
);

sub import {
    my ( $class, %args ) = @_;

    $MODE    = $args{'-mode'};
    $STORAGE = $args{'-storage'};
}

sub new {
    my $class = shift;
    my %args  = %{ shift() || {} };

    my $mode    = delete $args{mode}    || $MODE    || 'playback';
    my $storage = delete $args{storage} || $STORAGE || $DEFAULT_STORAGE;

    # testing mode
    $mode = $ENV{TEST_MF_MODE} || $mode;

    croak "Invalid mode '$MODE'" unless $VALID_MODES{$mode};

    # storage mechanism
    $storage = { $storage => {} } unless ref $storage;

    if ( !blessed $storage ) {

        my ( $storage_class, $storage_args ) = %{$storage};

        $storage_class = __PACKAGE__ . "::Storage::" . $storage_class
            unless $storage_class =~ s/^\++//;

        eval "require $storage_class";
        croak "Unable to load '$storage_class': $@" if $@;

        $storage = $storage_class->new(
            {   %{ $storage_args || {} },
                %args,    # pass in any remaining arguments
            }
        );
    }

    return $class->SUPER::new(
        {   mode     => $mode,
            storage  => $storage,
            _wrapped => {},
        }
    );
}

sub store {
    my $self = shift;

    my %args = %{ shift() };

    $args{ ref $self } = $self->VERSION;
    $args{ ref $self->storage } = $self->storage->VERSION;

    $self->storage->store( \%args );

    return $self;
}

sub retrieve {
    my ( $self, $args ) = @_;

    my $stored = $self->storage->retrieve($args);

    my $self_class    = ref $self;
    my $storage_class = ref $self->storage;

    _compare_versions( $self_class, $stored->{$self_class} )
        if exists $stored->{$self_class};

    _compare_versions( $storage_class, $stored->{$storage_class} )
        if exists $stored->{$storage_class};

    unless ( defined $stored->{output} || $stored->{no_output} ) {
        die "Nothing stored for " . $args->{method};
    }

    return $stored;
}

sub _compare_versions {
    my ( $class, $version ) = @_;

    carp "Data saved with a more recent version ($version) of $class!"
        if version->parse( $class->VERSION ) < version->parse($version);
}

# pass in optional coderef to return list of values to use
# (for example to stringify objects)
sub _get_key_sub {
    my $value = shift;

    return sub {
        my ( $config, @args ) = @_;
        if ($value) {
            my @replace = $value->(@args);
            splice( @args, 0, scalar(@replace), @replace );
        }
        return [ $config, @args ];
    };
}

sub mock {
    my $self = shift;

    my $self_ref = $self;
    weaken $self_ref;    # otherwise reference to $self within wrapped methods

    while ( my ( $name, $value ) = splice @_, 0, 2 ) {

        my $original_fn = \&{$name};

        my $key_sub = _get_key_sub($value);

        $self->_wrapped->{$name} = wrap $name, pre => sub {

            my $mode = $self_ref->mode;

            return if $mode eq 'passthrough';

            my @args = @_;    # original arguments that method received
            pop @args;        # currently undef, will be the return value

            my $key = $key_sub->( { wantarray => wantarray() }, @args );

            if ( $mode eq 'playback' or $mode eq 'auto' ) {

                my $retrieved = eval {
                    $self_ref->retrieve(
                        {   method => $name,
                            key    => $key,
                            input  => \@args,
                        }
                    );
                };
                if ($@) {
                    croak "Unable to retrieve $name - in $mode mode: $@"
                        unless $mode eq 'auto';
                } else {

                    # add cached value into extra arg,
                    # so original sub will not be called
                    $_[-1] = $retrieved->{output};
                    return;
                }
            }

            if ( $mode eq 'record' or $mode eq 'auto' ) {

                my $result;
                if (wantarray) {
                    $result = [ $original_fn->(@args) ];
                } elsif ( defined wantarray ) {
                    $result = $original_fn->(@args);
                } else {
                    $original_fn->(@args);
                }

                $self_ref->store(
                    {   method => $name,
                        key    => $key,
                        input  => \@args,
                        defined wantarray()
                        ? ( output => $result )
                        : ( no_output => 1 ),
                    }
                );

                $_[-1] = $result;
                return;
            }
        };
    }

    return $self;
}

1;

__END__