File Coverage

blib/lib/ex/monkeypatched.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	16	18	88.8
condition	7	12	58.3
subroutine	11	11	100.0
pod	0	1	0.0
total	84	92	91.3

package ex::monkeypatched;

use strict;
use warnings;

use Sub::Name qw;
use Carp qw;

our $VERSION = '0.03';

sub import {
    my $invocant = shift;
    my $norequire = @_ && $_[0] && $_[0] eq '-norequire' && shift;
    if (@_) {
        my @injections = _parse_injections(@_)
            or croak "Usage: use $invocant \$class => %methods
or:    use $invocant (class => \$class, methods => \\%methods)
or:    use $invocant (method => \$name, implementations => \\%impl)";
        _require(map { $_->[0] } @injections)
            if !$norequire;
        _inject_methods(@injections);
    }
}

sub _require {
    for (@_) {
        (my $as_file = $_) =~ s{::|'}{/}g;
        require "$as_file.pm";  # dies if no such file is found
    }
}

sub _parse_injections {

    if (@_ == 1 && ref $_[0] eq 'HASH') {
        my $opt = shift;
        if (defined $opt->{class} && ref $opt->{methods} eq 'HASH') {
            return map { [$opt->{class}, $_, $opt->{methods}{$_}] }
                keys %{ $opt->{methods} };
        }
        elsif (defined $opt->{method} && ref $opt->{implementations} eq 'HASH') {
            return map { [$_, $opt->{method}, $opt->{implementations}{$_}] }
                keys %{ $opt->{implementations} };
        }
    }
    elsif (@_ % 2) {
        my @injections;
        my $target = shift;
        push @injections, [$target, splice @_, 0, 2]
            while @_;
        return @injections;
    }

    return;
}

sub inject {
    my $invocant = shift;
    my @injections = _parse_injections(@_)
        or croak "Usage: $invocant->inject(\$class, %methods)
or:    $invocant->inject({ class => \$class, methods => \\%methods })
or:    $invocant->inject({ method => \$name, implementations => \\%impl })";
    _inject_methods(@injections);
}

sub _inject_methods {
    for (@_) {
        my ($target, $name, undef) = @$_;
        croak qq[Can't monkey-patch: $target already has a method "$name"]
            if $target->can($name);
    }
    _install_subroutine(@$_) for @_;
}

sub _install_subroutine {
    my ($target, $name, $code) = @_;
    my $full_name = "$target\::$name";
    my $renamed_code = subname($full_name, $code);
    no strict qw;
    *$full_name = $renamed_code;
}

1;
__END__