File Coverage

blib/lib/Call/From.pm

Criterion	Covered	Total	%
statement	37	38	97.3
branch	19	20	95.0
condition	19	27	70.3
subroutine	9	9	100.0
pod	2	2	100.0
total	86	96	89.5

use 5.006;
use strict;
use warnings;

package Call::From;

our $VERSION   = '0.001000';
our $AUTHORITY = 'cpan:KENTNL';

use Exporter qw();
*import = \&Exporter::import;

our @EXPORT_OK = qw( call_method_from call_function_from $_call_from );

our $_call_from = sub {
    $_[0]->${ \call_method_from( [ _to_caller( $_[1] ) ] ) }( @_[ 2 .. $#_ ] );
};

sub _to_caller {
    my ( $ctx, $offset ) = @_;

    # +1 because this function is internal, and we dont
    # want Call::From
    $offset = 1 unless defined $offset;

    # Numeric special case first because caller is different
    if ( defined $ctx and not ref $ctx and $ctx =~ /^-?\d+$/ ) {

        my (@call) = caller( $ctx + $offset );
        return @call[ 0 .. 2 ];
    }

    my (@call) = caller($offset);

    # _to_caller() returns the calling context of call_method_from
    return @call[ 0 .. 2 ] if not defined $ctx;

    # _to_caller($name) as with (), but with  replaced.
    return ( $ctx, $call[1], $call[2] ) if not ref $ctx;

    # _to_caller([ pkg, (file,( line)) ]) fills the fields that are missing
    return (
        $ctx->[0] || $call[0],    # pkg
        $ctx->[1] || $call[1],    # file
        $ctx->[2] || $call[2],    # line
    );

}

sub _to_fun {
    return $_[0] if 'CODE' eq ref $_[0];

    if ( defined $_[0]
        and my ( $package, $function ) = $_[0] =~ /\A(.*?)::([^:]+)\z/ )
    {
        # q[::Foo]->can() is invalid before 5.18
        # so map it to q[main::Foo]
        $package = 'main' if not defined $package or not length $package;
        if ( my $sub = "$package"->can($function) ) {
            return $sub;
        }
        die "Can't resolve function <$function> in package <$package>";
    }
    my $arg = defined $_[0] ? qq["$_[0]"] : q[undef];
    die "Can't automatically determine package and function from $arg";
}

sub _gen_sub {
    my ( $package, $file, $line, $code ) = @_;
    my $sub_code =
        qq[package $package;\n]
      . qq[#line $line "$file"\n] . 'sub {'
      . $code . '};';
    local $@ = undef;
    my $sub = eval $sub_code;
    $@ or return $sub;
    die "Can't compile trampoline for $package: $@\n code => $sub_code";
}

my $method_trampoline_cache   = {};
my $function_trampoline_cache = {};

sub call_method_from {
    my @caller = _to_caller( $_[0] );
    return ( $method_trampoline_cache->{ join qq[\0], @caller } ||=
          _gen_sub( @caller, q[ $_[0]->${\$_[1]}( @_[2..$#_ ] ) ] ) );
}

sub call_function_from {
    my @caller = _to_caller( $_[0] );
    return (
        $function_trampoline_cache->{ join qq[\0], @caller } ||= _gen_sub(
            @caller, __PACKAGE__ . q[::_to_fun($_[0])->( @_[1..$#_ ] ) ],
        )
    );
}

1;

__END__