File Coverage

blib/lib/Sub/Implant.pm

Criterion	Covered	Total	%
statement	80	86	93.0
branch	26	34	76.4
condition	13	16	81.2
subroutine	18	19	94.7
pod	2	2	100.0
total	139	157	88.5

package Sub::Implant;

use 5.010;
use strict;
use warnings;

=head1 NAME

Sub::Implant - Make a named sub out of a subref

=head1 VERSION

Version 2.02

=cut (remainder of POD after __END__)

our $VERSION = '2.02';

use Carp;

sub import {
    my $class = shift;
    $class->_import_into(scalar caller, @_);
}

sub _import_into {
    my $class = shift;
    my ($client, @arg) = @_;
    unshift @arg, qw(implant) unless @arg; # default export
    my %export = (
        implant => \ &implant,
        infuse  => \ &infuse,
    );

    while ( @arg ) {
        my $export = shift @arg;
        my $code = $export{$export} or croak(
            "$export is not exported by the $class module"
        );
        my %opt  = %{ shift @arg } if ref $arg[0] eq 'HASH';
        my $name = $opt{as} // $export;
        implant($client, $name, $code);
    }
}

sub infuse {
    my ($package, $what, %opt) = @_;
    for my $name ( keys %$what ) {
        my $code = $what->{$name};
        implant($package, $name, $code, %opt)
    }
}

sub implant {
    my ($name, $sub, %opt) = _get_args(scalar caller, @_);
    _do_define($name, $sub, %opt);
    _do_name($name, $sub, %opt) if $opt{name};
    $sub
}

use Scalar::Util qw(reftype);

sub _get_args {
    # pick up caller
    my $caller = shift;

    # unwrap original arguments
    croak "Name and subref must be given" if @_ < 2;
    $_ //= '' for @_;

    if ( (reftype $_[1] // '') eq 'CODE' ) {
        unshift @_, ''; # dummy package
    } elsif ( (reftype $_[2] // '') ne 'CODE' ) {
        croak "No subref given";
    }
    my ($package, $name, $sub, %opt) = @_;
    $opt{redef} //= 0;
    $opt{name} //= 1;

    # build full name
    if ( $name =~ /::/ ) {
        croak "Can't specify package and qualified name" if $package;
    } else {
        $package ||= $caller;
        $name = join '::', $package, $name;
    }

# all checked and set
    ($name, $sub, %opt)
}

sub _do_define {
    my ($name, $sub, %opt) = @_;
    if ( defined &$name ) {
        carp "Subroutine $name redefined" unless $opt{redef};
    }
    no warnings 'redefine';
    no strict 'refs';
    *$name = $sub;
}

sub _do_name_off {
    my ($name, $sub, %opt) = @_;
    my $old_name = _get_subname($sub);
    return if $old_name;
    _check_match($name, $sub, $old_name) unless $opt{lie}; # option 'lie' unused
    _subname($name, $sub);
    return;
}

use Sub::Identify qw(sub_name);
use Sub::Name qw(subname);

sub _do_name {
    my ($name, $sub, %opt) = @_;
    my $old_name = sub_name($sub);
    return if $old_name ne '__ANON__';
    _check_match($name, $sub, $old_name) unless $opt{lie}; # option 'lie' unused
    subname($name, $sub);
    return;
}

sub _check_match {
    # see if a name points to a given subref
    my ($name, $sub, $old_name) = @_;
    my $reached = do {
        no strict 'refs';
        *$name{CODE}
    };
    croak(
        "Won't rename $old_name to undefined $name'"
    ) unless $reached;
    croak(
        "Won't rename $old_name to non-matching $name"
    ) unless $reached == $sub;
}

1 # End of Sub::Implant
__END__