view release on metacpan or  search on metacpan

lib/Test/Subroutines.pm  view on Meta::CPAN

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) ) {