File Coverage

blib/lib/Test/MethodFixtures.pm

Criterion	Covered	Total	%
statement	88	90	97.7
branch	27	36	75.0
condition	9	11	81.8
subroutine	16	17	94.1
pod	4	4	100.0
total	144	158	91.1

use strict;
use warnings;

package Test::MethodFixtures;

our $VERSION = '0.05';

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, version => $VERSION } );

    return $self;
}

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

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

    _compare_versions( $self, $stored->{version} )
        if exists $stored->{version};
    _compare_versions( $self->storage, $stored->{storage_version} )
        if exists $stored->{storage_version};

    return $stored->{output};
}

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

    carp "Data saved with a more recent version ($version) of "
        . ref($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
            eval {
                my $retrieved = $self_ref->retrieve(
                    {   method => $name,
                        key    => $key,
                        input  => \@args,
                    }
                );

                if ( defined $retrieved ) {
                    $_[-1] = $retrieved;
                } else {
                    die "Nothing stored for $name"
                        unless $mode eq 'auto';
                }
            };
            if ($@) {
                croak "Unable to retrieve $name - in $mode mode: $@";
            }
        };

        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__