File Coverage

blib/lib/Test/MethodFixtures.pm

Criterion	Covered	Total	%
statement	92	92	100.0
branch	31	36	86.1
condition	11	14	78.5
subroutine	17	17	100.0
pod	4	4	100.0
total	155	163	95.0

use strict;
use warnings;

package Test::MethodFixtures;

our $VERSION = '0.06';

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->{output};
}

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 $get_key = _get_key_sub($value);

        my $pre = sub {

            my $mode = $self_ref->mode;

            return if $mode eq 'record' or $mode eq 'passthrough';

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

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

            # add cached value into extra arg,
            # so original sub will not be called
            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 {
                $_[-1] = $retrieved;
            }
        };

        my $post = sub {
            my $mode = $self_ref->mode;

            return if $mode eq 'passthrough';

            croak "Problem retrieving data - reached store() in $mode mode"
                if $mode eq 'playback';

            my (@args) = @_;    # origin arguments method received, plus result
            my $result = pop @args;

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

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

        $self->_wrapped->{$name} = wrap $name,    #
            pre  => $pre,                         #
            post => $post;
    }

    return $self;
}

1;

__END__