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__ |