File Coverage

blib/lib/Test2/Mock.pm

Criterion	Covered	Total	%
statement	261	262	99.6
branch	83	92	90.2
condition	62	75	82.6
subroutine	46	46	100.0
pod	22	22	100.0
total	474	497	95.3

package Test2::Mock;
use strict;
use warnings;

our $VERSION = '0.000153';

use Carp qw/croak confess/;
our @CARP_NOT = (__PACKAGE__);

use Scalar::Util qw/weaken reftype blessed/;
use Test2::Util qw/pkg_to_file/;
use Test2::Util::Stash qw/parse_symbol slot_to_sig get_symbol get_stash purge_symbol/;
use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/;

sub new; # Prevent hashbase from giving us 'new';
use Test2::Util::HashBase qw/class parent child _purge_on_destroy _blocked_load _symbols _track sub_tracking call_tracking/;

sub new {
    my $class = shift;

    croak "Called new() on a blessed instance, did you mean to call \$control->class->new()?"
        if blessed($class);

    my $self = bless({}, $class);

    $self->{+SUB_TRACKING}  ||= {};
    $self->{+CALL_TRACKING} ||= [];

    my @sets;
    while (my $arg = shift @_) {
        my $val = shift @_;

        if ($class->can(uc($arg))) {
            $self->{$arg} = $val;
            next;
        }

        push @sets => [$arg, $val];
    }

    croak "The 'class' field is required"
        unless $self->{+CLASS};

    for my $set (@sets) {
        my ($meth, $val) = @$set;
        my $type = reftype($val);

        confess "'$meth' is not a valid constructor argument for $class"
            unless $self->can($meth);

        if (!$type) {
            $self->$meth($val);
        }
        elsif($type eq 'HASH') {
            $self->$meth(%$val);
        }
        elsif($type eq 'ARRAY') {
            $self->$meth(@$val);
        }
        else {
            croak "'$val' is not a valid argument for '$meth'"
        }
    }

    return $self;
}

sub _check {
    return unless $_[0]->{+CHILD};
    croak "There is an active child controller, cannot proceed";
}

sub purge_on_destroy {
    my $self = shift;
    ($self->{+_PURGE_ON_DESTROY}) = @_ if @_;
    return $self->{+_PURGE_ON_DESTROY};
}

sub stash {
    my $self = shift;
    get_stash($self->{+CLASS});
}

sub file {
    my $self = shift;
    my $file = $self->class;
    return pkg_to_file($self->class);
}

sub block_load {
    my $self = shift;
    $self->_check();

    my $file = $self->file;

    croak "Cannot block the loading of module '" . $self->class . "', already loaded in file $INC{$file}"
        if $INC{$file};

    $INC{$file} = __FILE__;

    $self->{+_BLOCKED_LOAD} = 1;
}

my %NEW = (
    hash => sub {
        my ($class, %params) = @_;
        return bless \%params, $class;
    },
    array => sub {
        my ($class, @params) = @_;
        return bless \@params, $class;
    },
    ref => sub {
        my ($class, $params) = @_;
        return bless $params, $class;
    },
    ref_copy => sub {
        my ($class, $params) = @_;
        my $type = reftype($params);

        return bless {%$params}, $class
            if $type eq 'HASH';

        return bless [@$params], $class
            if $type eq 'ARRAY';

        croak "Not sure how to construct an '$class' from '$params'";
    },
);

sub override_constructor {
    my $self = shift;
    my ($name, $type) = @_;
    $self->_check();

    my $sub = $NEW{$type}
        || croak "'$type' is not a known constructor type";

    $self->override($name => $sub);
}

sub add_constructor {
    my $self = shift;
    my ($name, $type) = @_;
    $self->_check();

    my $sub = $NEW{$type}
        || croak "'$type' is not a known constructor type";

    $self->add($name => $sub);
}

sub autoload {
    my $self = shift;
    $self->_check();
    my $class = $self->class;
    my $stash = $self->stash;

    croak "Class '$class' already has an AUTOLOAD"
        if $stash->{AUTOLOAD} && *{$stash->{AUTOLOAD}}{CODE};
    croak "Class '$class' already has an can"
        if $stash->{can} && *{$stash->{can}}{CODE};

    # Weaken this reference so that AUTOLOAD does not prevent its own
    # destruction.
    weaken(my $c = $self);

    my ($file, $line) = (__FILE__, __LINE__ + 3);
    my $autoload = eval <
package $class;
#line $line "$file (Generated AUTOLOAD)"
our \$AUTOLOAD;
    sub {
        my (\$self) = \@_;
        my (\$pkg, \$name) = (\$AUTOLOAD =~ m/^(.*)::([^:]+)\$/g);
        \$AUTOLOAD = undef;

        return if \$name eq 'DESTROY';
        my \$sub = sub {
            my \$self = shift;
            (\$self->{\$name}) = \@_ if \@_;
            return \$self->{\$name};
        };

        \$c->add(\$name => \$sub);

        if (\$c->{_track}) {
            my \$call = {sub_name => \$name, sub_ref => \$sub, args => [\@_]};
            push \@{\$c->{sub_tracking}->{\$name}} => \$call;
            push \@{\$c->{call_tracking}} => \$call;
        }

        goto &\$sub;
    }
EOT

    $line = __LINE__ + 3;
    my $can = eval <
package $class;
#line $line "$file (Generated can)"
use Scalar::Util 'reftype';
    sub {
        my (\$self, \$meth) = \@_;
        if (\$self->SUPER::can(\$meth)) {
            return \$self->SUPER::can(\$meth);
        }
        elsif (ref \$self && reftype \$self eq 'HASH' && exists \$self->{\$meth}) {
            return sub { shift->\$meth(\@_) };
        }
        return undef;
    }
EOT

    {
        local $self->{+_TRACK} = 0;
        $self->add(AUTOLOAD => $autoload);
        $self->add(can => $can);
    }
}

sub before {
    my $self = shift;
    my ($name, $sub) = @_;
    $self->_check();
    my $orig = $self->current($name);
    $self->_inject({}, $name => sub { $sub->(@_); $orig->(@_) });
}

sub after {
    my $self = shift;
    my ($name, $sub) = @_;
    $self->_check();
    my $orig = $self->current($name);
    $self->_inject({}, $name => sub {
        my @out;

        my $want = wantarray;

        if ($want) {
            @out = $orig->(@_);
        }
        elsif(defined $want) {
            $out[0] = $orig->(@_);
        }
        else {
            $orig->(@_);
        }

        $sub->(@_);

        return @out    if $want;
        return $out[0] if defined $want;
        return;
    });
}

sub around {
    my $self = shift;
    my ($name, $sub) = @_;
    $self->_check();
    my $orig = $self->current($name);
    $self->_inject({}, $name => sub { $sub->($orig, @_) });
}

sub add {
    my $self = shift;
    $self->_check();
    $self->_inject({add => 1}, @_);
}

sub override {
    my $self = shift;
    $self->_check();
    $self->_inject({}, @_);
}

sub set {
    my $self = shift;
    $self->_check();
    $self->_inject({set => 1}, @_);
}

sub current {
    my $self = shift;
    my ($sym) = @_;

    return get_symbol($sym, $self->{+CLASS});
}

sub orig {
    my $self = shift;
    my ($sym) = @_;

    $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;

    my $syms = $self->{+_SYMBOLS}
        or croak "No symbols have been mocked yet";

    my $ref = $syms->{$sym};

    croak "Symbol '$sym' is not mocked"
        unless $ref && @$ref;

    my ($orig) = @$ref;

    return $orig;
}

sub track {
    my $self = shift;

    ($self->{+_TRACK}) = @_ if @_;

    return $self->{+_TRACK};
}

sub clear_call_tracking { @{shift->{+CALL_TRACKING}} = () }

sub clear_sub_tracking {
    my $self = shift;

    unless (@_) {
        %{$self->{+SUB_TRACKING}} = ();
        return;
    }

    for my $item (@_) {
        delete $self->{+SUB_TRACKING}->{$item};
    }

    return;
}

sub _parse_inject {
    my $self = shift;
    my ($param, $arg) = @_;

    if ($param =~ m/^-(.*)$/) {
        my $sym = $1;
        my $sig = slot_to_sig(reftype($arg));
        my $ref = $arg;
        return ($sig, $sym, $ref);
    }

    return ('&', $param, $arg)
        if ref($arg) && reftype($arg) eq 'CODE';

    my ($is, $field, $val);

    if(defined($arg) && !ref($arg) && $arg =~ m/^(rw|ro|wo)$/) {
        $is    = $arg;
        $field = $param;
    }
    elsif (!ref($arg)) {
        $val = $arg;
        $is  = 'val';
    }
    elsif (reftype($arg) eq 'HASH') {
        $field = delete $arg->{field} || $param;

        $val = delete $arg->{val};
        $is  = delete $arg->{is};

        croak "Cannot specify 'is' and 'val' together" if $val && $is;

        $is ||= $val ? 'val' : 'rw';

        croak "The following keys are not valid when defining a mocked sub with a hashref: " . join(", " => keys %$arg)
            if keys %$arg;
    }
    else {
        confess "'$arg' is not a valid argument when defining a mocked sub";
    }

    my $sub;
    if ($is eq 'rw') {
        $sub = gen_accessor($field);
    }
    elsif ($is eq 'ro') {
        $sub = gen_reader($field);
    }
    elsif ($is eq 'wo') {
        $sub = gen_writer($field);
    }
    else { # val
        $sub = sub { $val };
    }

    return ('&', $param, $sub);
}

sub _inject {
    my $self = shift;
    my ($params, @pairs) = @_;

    my $add = $params->{add};
    my $set = $params->{set};

    my $class = $self->{+CLASS};

    $self->{+_SYMBOLS} ||= {};
    my $syms = $self->{+_SYMBOLS};

    while (my $param = shift @pairs) {
        my $arg = shift @pairs;
        my ($sig, $sym, $ref) = $self->_parse_inject($param, $arg);
        my $orig = $self->current("$sig$sym");

        croak "Cannot override '$sig$class\::$sym', symbol is not already defined"
            unless $orig || $add || $set || ($sig eq '&' && $class->can($sym));

        # Cannot be too sure about scalars in globs
        croak "Cannot add '$sig$class\::$sym', symbol is already defined"
            if $add && $orig
            && (reftype($orig) ne 'SCALAR' || defined($$orig));

        $syms->{"$sig$sym"} ||= [];
        push @{$syms->{"$sig$sym"}} => $orig; # Might be undef, thats expected

        if ($self->{+_TRACK} && $sig eq '&') {
            my $sub_tracker  = $self->{+SUB_TRACKING};
            my $call_tracker = $self->{+CALL_TRACKING};
            my $sub = $ref;
            $ref = sub {
                my $call = {sub_name => $sym, sub_ref => $sub, args => [@_]};
                push @{$sub_tracker->{$param}} => $call;
                push @$call_tracker => $call;
                goto &$sub;
            };
        }

        no strict 'refs';
        no warnings 'redefine';
        *{"$class\::$sym"} = $ref;
    }

    return;
}

sub _set_or_unset {
    my $self = shift;
    my ($symbol, $set) = @_;

    my $class = $self->{+CLASS};

    return purge_symbol($symbol, $class)
        unless $set;

    my $sym = parse_symbol($symbol, $class);
    no strict 'refs';
    no warnings 'redefine';
    *{"$class\::$sym->{name}"} = $set;
}

sub restore {
    my $self = shift;
    my ($sym) = @_;
    $self->_check();

    $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;

    my $syms = $self->{+_SYMBOLS}
        or croak "No symbols are mocked";

    my $ref = $syms->{$sym};

    croak "Symbol '$sym' is not mocked"
        unless $ref && @$ref;

    my $old = pop @$ref;
    delete $syms->{$sym} unless @$ref;

    return $self->_set_or_unset($sym, $old);
}

sub reset {
    my $self = shift;
    my ($sym) = @_;
    $self->_check();

    $sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;

    my $syms = $self->{+_SYMBOLS}
        or croak "No symbols are mocked";

    my $ref = delete $syms->{$sym};

    croak "Symbol '$sym' is not mocked"
        unless $ref && @$ref;

    my ($old) = @$ref;

    return $self->_set_or_unset($sym, $old);
}

sub reset_all {
    my $self = shift;
    $self->_check();

    my $syms = $self->{+_SYMBOLS} || return;

    $self->reset($_) for keys %$syms;

    delete $self->{+_SYMBOLS};
}

sub _purge {
    my $self = shift;
    my $stash = $self->stash;
    delete $stash->{$_} for keys %$stash;
}

sub DESTROY {
    my $self = shift;

    delete $self->{+CHILD};
    $self->reset_all if $self->{+_SYMBOLS};

    delete $INC{$self->file} if $self->{+_BLOCKED_LOAD};

    $self->_purge if $self->{+_PURGE_ON_DESTROY};
}

1;

__END__