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


line stmt bran cond sub pod time code
1             package Test::Subroutines;
2             {
3             $Test::Subroutines::VERSION = '1.113350';
4             }
5              
6             require Exporter;
7             @ISA = qw(Exporter);
8             @EXPORT = qw(load_subs);
9             @EXPORT_OK = qw(get_subref);
10              
11 1     1   23859 use strict;
  1         2  
  1         41  
12 1     1   6 use warnings FATAL => 'all';
  1         2  
  1         45  
13              
14 1     1   2823 use Devel::LexAlias qw(lexalias);
  1         20899  
  1         101  
15 1     1   12 use PadWalker qw(closed_over peek_my);
  1         1  
  1         77  
16 1     1   1059 use Symbol qw(qualify_to_ref);
  1         1156  
  1         64  
17 1     1   7 use Devel::Symdump;
  1         2  
  1         23  
18 1     1   1869 use File::Slurp;
  1         25857  
  1         145  
19              
20             our @used_modules;
21             BEGIN {
22 10         1020 unshift @INC, \&trace_use
23 1 50   1   4 unless grep { "$_" eq \&trace_use . '' } @INC;
24             }
25              
26             sub trace_use {
27 5     5 0 179757 my ($code, $module) = @_;
28 5         20 (my $mod_name = $module) =~ s{/}{::};
29 5         24 $mod_name =~ s/\.pm$//;
30              
31 5         15 push @used_modules, $mod_name;
32 5         5288 return undef;
33             }
34              
35             sub load_subs {
36 0     0 0   my $text = read_file( shift );
37 0           $text =~ s/\n__DATA__\n.*//s;
38 0           $text =~ s/\n__END__\n.*//s;
39              
40             # optional args
41 0           my $pkg = scalar caller (0);
42 0           my $opts = {};
43 0           while (my $thing = shift) {
44 0 0         if (ref $thing eq ref {}) {
45 0           $opts = $thing;
46 0           next;
47             }
48 0 0         if (ref $thing eq ref '') {
49 0 0         die "custom namespace must not be nested (i.e. must not include ::)"
50             if $thing =~ m/::/;
51 0           $pkg = $thing;
52 0           next;
53             }
54             }
55              
56 0           my $callpkg = scalar caller(0);
57 0           my $key = 'jei8ohNe';
58              
59 0   0 0     $opts->{exit} ||= sub { $_[0] ||= 0; die "caught exit($_[0])\n" };
  0   0        
  0            
60 0   0 0     $opts->{system} ||= sub { system @_ };
  0            
61              
62 0           my $subs = 'use subs qw('. (join ' ', keys %$opts) .')';
63 0           my @used;
64              
65             {
66 0           local @used_modules = ();
  0            
67 0 0         eval "package $pkg; $subs; sub $key { no warnings 'closure'; $text; }; 1;"
68             or die $@;
69 0           @used = @used_modules;
70             }
71              
72 0           *{qualify_to_ref($_,$pkg)} = $opts->{$_} for (keys %$opts);
  0            
73 0           my %globals = %{ [peek_my(1)]->[0] };
  0            
74              
75 0           foreach my $qsub ( Devel::Symdump->functions($pkg) ) {
76 0           (my $sub = $qsub) =~ s/^${pkg}:://;
77 0 0         next if $sub eq $key;
78              
79 0           my $subref = get_subref($sub, $pkg);
80 0           my @vars = keys %{ [closed_over $subref]->[0] };
  0            
81              
82 0           foreach my $v (@vars) {
83 0 0         if (not_external($pkg, $sub, @used)) {
84 0 0         if (exists $globals{$v}) {
85 0           lexalias($subref, $v, $globals{$v});
86             }
87             else {
88 0           die qq(Missing lexical for "$v" required by "$sub");
89             }
90             }
91             }
92             }
93             }
94              
95             sub not_external {
96 0     0 0   my ($p, $s, @used) = @_;
97              
98 0           foreach my $pack (@used) {
99 0 0         next unless scalar grep {$_ eq "${pack}::$s"}
  0            
100             (Devel::Symdump->functions($pack));
101 0 0         return 0 if
102             get_subref($s, $pack) eq get_subref($s, $p);
103             # subref in used package equal to subref in hack package
104             }
105 0           return 1;
106             }
107              
108             sub get_subref {
109 0     0 0   my $sub = shift;
110 0   0       my $pkg = shift || scalar caller(0);
111              
112 0           my $symtbl = \%{main::};
113 0           foreach my $part(split /::/, $pkg) {
114 0           $symtbl = $symtbl->{"${part}::"};
115             }
116              
117 0           return eval{ \&{ $symtbl->{$sub} } };
  0            
  0            
118             }
119              
120             1;
121              
122             # ABSTRACT: Standalone execution of Perl program subroutines
123              
124              
125             __END__