File Coverage

blib/lib/JIP/Mock/Control.pm

Criterion	Covered	Total	%
statement	168	176	95.4
branch	44	46	95.6
condition	5	7	71.4
subroutine	36	38	94.7
pod	7	7	100.0
total	260	274	94.8

package JIP::Mock::Control;

use strict;
use warnings;

use Carp qw(croak);
use English qw(-no_match_vars);
use Scalar::Util qw(reftype blessed);

use JIP::Mock::Event;

our $VERSION = 'v0.0.3';

sub new {
    my ( $class, %param ) = @ARG;

    if ( my $error = $class->_validate(%param) ) {
        croak 'Cannot instantiate: ' . $error;
    }

    return $class->_instantiate(%param);
}

sub package { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ($self) = @ARG;

    return $self->{package};
}

sub want_array {
    my ($self) = @ARG;

    return $self->{want_array};
}

sub times { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ($self) = @ARG;

    return $self->{times};
}

sub events {
    my ($self) = @ARG;

    my @events = map { $self->_extract_event_state($_) } @{ $self->_events() };

    return \@events;
}

sub override {
    my ( $self, %pair ) = @ARG;

    my @pairs;
    foreach my $name ( sort keys %pair ) {
        my $new_sub = $pair{$name};

        if ( my $error = $self->_validate_overriding( $name, $new_sub ) ) {
            croak 'Cannot override: ' . $error;
        }

        push @pairs, [ $name, $new_sub ];
    }

    foreach my $pair (@pairs) {
        my ( $name, $new_sub ) = @{$pair};

        $self->_override( $name, $new_sub );
    }

    return;
} ## end sub override

sub call_original {
    my ( $self, $name, @arguments ) = @ARG;

    if ( my $error = $self->_validate_call_original($name) ) {
        croak 'Cannot call original: ' . $error;
    }

    my $want_array   = wantarray;
    my $original_sub = $self->_get_original($name);

    # void context
    if ( !defined $want_array ) {
        $original_sub->(@arguments);

        return;
    }

    # is looking for a list value
    elsif ($want_array) {
        my @results = $original_sub->(@arguments);

        return @results;
    }

    # is looking for a scalar
    else {
        my $result = $original_sub->(@arguments);

        return $result;
    }
} ## end sub call_original

sub DESTROY {
    my ($self) = @ARG;

    $self->_restore_all();

    return;
}

sub _validate {
    my ( undef, %param ) = @ARG;

    my $package = $param{package};

    return 'package name is not present!' if !length $package;

    return if _is_package_loaded($package);

    return sprintf 'package "%s" is not loaded!', $package;
}

sub _validate_overriding {
    my ( $self, $name, $new_sub ) = @ARG;

    return 'name is not present!' if !length $name;

    if ( !$self->package->can($name) ) {
        return sprintf 'cannot override non-existent sub "%s"!', $name;
    }

    if ( !$new_sub ) {
        return sprintf 'new sub of "%s" is not present!', $name;
    }

    return if _is_coderef($new_sub);

    return sprintf 'new sub of "%s" is not CODE reference!', $name;
}

sub _validate_call_original {
    my ( $self, $name ) = @ARG;

    return 'name is not present!' if !length $name;

    return if $self->_get_original($name);

    return sprintf 'cannot find sub "%s" by name!', $name;
}

sub _instantiate {
    my ( $class, %param ) = @ARG;

    return bless(
        {
            package    => $param{package},
            want_array => $param{want_array},
            originals  => {},
            times      => {},
            events     => [],
        },
        $class,
    );
}

sub _events {
    my ($self) = @ARG;

    return $self->{events};
}

sub _originals {
    my ($self) = @ARG;

    return $self->{originals};
}

sub _get_original {
    my ( $self, $name ) = @ARG;

    my $originals = $self->_originals();

    my $original_sub = $originals->{$name};

    return $original_sub;
}

sub _add_original {
    my ( $self, $name, $original_sub ) = @ARG;

    my $originals = $self->_originals();

    return if exists $originals->{$name};

    $originals->{$name} = $original_sub;

    return;
}

sub _delete_original {
    my ( $self, $name ) = @ARG;

    my $originals = $self->_originals();

    return delete $originals->{$name};
}

sub _override {
    my ( $self, $name, $new_sub ) = @_;

    $self->_collect_original($name);

    my $new_sub_wrapper = $self->_init_wrapper( $name, $new_sub );

    $self->_monkey_patch( $name, $new_sub_wrapper );

    return;
}

sub _collect_original {
    my ( $self, $name ) = @ARG;

    return if $self->_get_original($name);

    my $original_sub = $self->package->can($name);

    $self->_add_original( $name, $original_sub );

    return;
}

sub _init_wrapper {
    my ( $self, $name, $new_sub ) = @ARG;

    return sub {
        my @arguments  = @ARG;
        my $want_array = wantarray;

        if ( my $first_argument = $arguments[0] ) {
            my $package = $self->package();

            #<<< no perltidy
            my $is_class_or_object = (
                ( $first_argument eq $package )
                || ( ( blessed($first_argument) // q{} ) eq $package )
            );
            #>>>

            if ($is_class_or_object) {
                shift @arguments;
            }
        }

        my %event = (
            method    => $name,
            arguments => \@arguments,
            times     => $self->_increment_times($name),
        );

        if ( $self->want_array() ) {
            $event{want_array} = $want_array;
        }

        my $event = JIP::Mock::Event->new(%event);

        $self->_collect_event($event);

        # void context
        if ( !defined $want_array ) {
            $new_sub->($event);

            return;
        }

        # is looking for a list value
        elsif ($want_array) {
            my @results = $new_sub->($event);

            return @results;
        }

        # is looking for a scalar
        else {
            my $result = $new_sub->($event);

            return $result;
        }
    };
} ## end sub _init_wrapper

sub _monkey_patch {
    my ( $self, $name, $sub ) = @ARG;

    my $target = $self->package() . q{::} . $name;

    no strict 'refs';       ## no critic (ProhibitNoStrict)
    no warnings 'redefine'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)

    *{$target} = $sub;

    return;
}

sub _restore_all {
    my ($self) = @ARG;

    my $originals = $self->_originals();

    foreach my $name ( sort keys %{$originals} ) {
        $self->_restore($name);
    }

    return;
}

sub _restore {
    my ( $self, $name ) = @ARG;

    my $original_sub = $self->_delete_original($name);

    $self->_monkey_patch( $name, $original_sub );

    return;
}

sub _increment_times {
    my ( $self, $name ) = @ARG;

    my $times = $self->times();

    my $count = $times->{$name};

    $count //= 0;

    $count += 1;

    $times->{$name} = $count;

    return $count;
}

sub _collect_event {
    my ( $self, $event ) = @ARG;

    push @{ $self->_events() }, $event;

    return;
}

sub _extract_event_state {
    my ( $self, $event ) = @ARG;

    my %state = (
        method    => $event->method(),
        arguments => $event->arguments(),
    );

    if ( $self->want_array() ) {
        $state{want_array} = $event->want_array();
    }

    return \%state;
}

sub _is_coderef {
    my ($sub) = @ARG;

    my $reftype = reftype($sub);

    $reftype //= q{};

    return 1 if $reftype eq 'CODE';
    return 0;
}

sub _is_package_loaded {
    my ($package) = @ARG;

    $package .= q{::};

    no strict 'refs'; ## no critic (ProhibitNoStrict)

    return 1 if %{$package};
    return 0;
}

1;

__END__