File Coverage

blib/lib/Test/Subroutines.pm

Criterion	Covered	Total	%
statement	28	83	33.7
branch	1	20	5.0
condition	0	8	0.0
subroutine	9	14	64.2
pod	0	4	0.0
total	38	129	29.4

package Test::Subroutines;
{
  $Test::Subroutines::VERSION = '1.113350';
}

require Exporter;
@ISA       = qw(Exporter);
@EXPORT    = qw(load_subs);
@EXPORT_OK = qw(get_subref);

use strict;
use warnings FATAL => 'all';

use Devel::LexAlias qw(lexalias);
use PadWalker qw(closed_over peek_my);
use Symbol qw(qualify_to_ref);
use Devel::Symdump;
use File::Slurp;

our @used_modules;
BEGIN {
    unshift @INC, \&trace_use
        unless grep { "$_" eq \&trace_use . '' } @INC;
}

sub trace_use {
    my ($code, $module) = @_;
    (my $mod_name = $module) =~ s{/}{::};
    $mod_name =~ s/\.pm$//;

    push @used_modules, $mod_name;
    return undef;
}

sub load_subs {
    my $text = read_file( shift );
    $text =~ s/\n__DATA__\n.*//s;
    $text =~ s/\n__END__\n.*//s;

    # optional args
    my $pkg = scalar caller (0);
    my $opts = {};
    while (my $thing = shift) {
        if (ref $thing eq ref {}) {
            $opts = $thing;
            next;
        }
        if (ref $thing eq ref '') {
            die "custom namespace must not be nested (i.e. must not include ::)"
                if $thing =~ m/::/;
            $pkg = $thing;
            next;
        }
    }

    my $callpkg = scalar caller(0);
    my $key = 'jei8ohNe';

    $opts->{exit}   ||= sub { $_[0] ||= 0; die "caught exit($_[0])\n" };
    $opts->{system} ||= sub { system @_ };

    my $subs = 'use subs qw('. (join ' ', keys %$opts) .')';
    my @used;

    {
        local @used_modules = ();
        eval "package $pkg; $subs; sub $key { no warnings 'closure'; $text; }; 1;"
            or die $@;
        @used = @used_modules;
    }

    *{qualify_to_ref($_,$pkg)} = $opts->{$_} for (keys %$opts);
    my %globals = %{ [peek_my(1)]->[0] };

    foreach my $qsub ( Devel::Symdump->functions($pkg) ) {
        (my $sub = $qsub) =~ s/^${pkg}:://;
        next if $sub eq $key;

        my $subref = get_subref($sub, $pkg);
        my @vars = keys %{ [closed_over $subref]->[0] };

        foreach my $v (@vars) {
            if (not_external($pkg, $sub, @used)) {
                if (exists $globals{$v}) {
                    lexalias($subref, $v, $globals{$v});
                }
                else {
                    die qq(Missing lexical for "$v" required by "$sub");
                }
            }
        }
    }
}

sub not_external {
    my ($p, $s, @used) = @_;

    foreach my $pack (@used) {
        next unless scalar grep {$_ eq "${pack}::$s"}
                                (Devel::Symdump->functions($pack));
        return 0 if
            get_subref($s, $pack) eq get_subref($s, $p);
            # subref in used package equal to subref in hack package
    }
    return 1;
}

sub get_subref {
    my $sub = shift;
    my $pkg = shift || scalar caller(0);

    my $symtbl = \%{main::};
    foreach my $part(split /::/, $pkg) {
        $symtbl = $symtbl->{"${part}::"};
    }

    return eval{ \&{ $symtbl->{$sub} } };
}

1;

# ABSTRACT: Standalone execution of Perl program subroutines


__END__