line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perlmazing::Engine;
|
2
|
50
|
|
|
50
|
|
16764
|
use Perlmazing::Feature;
|
|
50
|
|
|
|
|
127
|
|
|
50
|
|
|
|
|
274
|
|
3
|
50
|
|
|
50
|
|
23096
|
use Submodules;
|
|
50
|
|
|
|
|
235718
|
|
|
50
|
|
|
|
|
277
|
|
4
|
50
|
|
|
50
|
|
1655
|
use Carp;
|
|
50
|
|
|
|
|
102
|
|
|
50
|
|
|
|
|
3074
|
|
5
|
50
|
|
|
50
|
|
310
|
use Scalar::Util qw(set_prototype);
|
|
50
|
|
|
|
|
81
|
|
|
50
|
|
|
|
|
2309
|
|
6
|
50
|
|
|
50
|
|
23481
|
use Taint::Util 'untaint';
|
|
50
|
|
|
|
|
23705
|
|
|
50
|
|
|
|
|
292
|
|
7
|
50
|
|
|
50
|
|
25963
|
use Data::Dump 'dump';
|
|
50
|
|
|
|
|
252197
|
|
|
50
|
|
|
|
|
36728
|
|
8
|
|
|
|
|
|
|
our $VERSION = '1.2812';
|
9
|
|
|
|
|
|
|
my $found_symbols;
|
10
|
|
|
|
|
|
|
my $loaded_symbols;
|
11
|
|
|
|
|
|
|
my $precompile_symbols;
|
12
|
|
|
|
|
|
|
my $parameters;
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub found_symbols {
|
15
|
50
|
|
|
50
|
1
|
146
|
my $self = shift;
|
16
|
50
|
|
33
|
|
|
483
|
my $package = (shift or caller);
|
17
|
50
|
50
|
|
|
|
256
|
return unless exists $found_symbols->{$package};
|
18
|
50
|
|
|
|
|
104
|
sort keys %{$found_symbols->{$package}};
|
|
50
|
|
|
|
|
3536
|
|
19
|
|
|
|
|
|
|
}
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub loaded_symbols {
|
22
|
0
|
|
|
0
|
1
|
0
|
my $self = shift;
|
23
|
0
|
|
0
|
|
|
0
|
my $package = (shift or caller);
|
24
|
0
|
0
|
|
|
|
0
|
return unless exists $loaded_symbols->{$package};
|
25
|
0
|
|
|
|
|
0
|
keys %{$loaded_symbols->{$package}};
|
|
0
|
|
|
|
|
0
|
|
26
|
|
|
|
|
|
|
}
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub preload {
|
29
|
50
|
|
|
50
|
1
|
133
|
my $self = shift;
|
30
|
50
|
|
|
|
|
143
|
my $package = caller;
|
31
|
50
|
|
|
|
|
185
|
for my $i (@_) {
|
32
|
0
|
|
|
|
|
0
|
_debug("Preloading symbol $i", $package);
|
33
|
0
|
|
|
|
|
0
|
_load_symbol($package, $i);
|
34
|
|
|
|
|
|
|
}
|
35
|
|
|
|
|
|
|
}
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub import {
|
38
|
50
|
|
|
50
|
|
118
|
my $self = shift;
|
39
|
50
|
50
|
|
|
|
382
|
carp "If passing arguments to this module, it most be using named arguments" if @_ % 2;
|
40
|
50
|
|
|
|
|
121
|
my $package = caller;
|
41
|
50
|
|
|
|
|
109
|
my $p = {@_};
|
42
|
50
|
50
|
|
|
|
240
|
$parameters->{$package} = {} unless $parameters->{$package};
|
43
|
50
|
|
|
|
|
92
|
$parameters->{$package} = {%{$parameters->{$package}}, %$p};
|
|
50
|
|
|
|
|
163
|
|
44
|
50
|
50
|
|
|
|
208
|
return if exists $found_symbols->{$package};
|
45
|
50
|
|
|
|
|
498
|
$found_symbols->{$package} = {};
|
46
|
50
|
|
|
|
|
225
|
_debug("Importing $self");
|
47
|
50
|
|
|
|
|
167
|
$self->_find_symbols($package);
|
48
|
|
|
|
|
|
|
}
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub _is_compile_phase {
|
51
|
2100
|
|
|
2100
|
|
2744
|
my $code = q[
|
52
|
|
|
|
|
|
|
BEGIN {
|
53
|
|
|
|
|
|
|
use warnings 'FATAL' => 'all';
|
54
|
|
|
|
|
|
|
eval 'INIT{} 1' or die;
|
55
|
|
|
|
|
|
|
}
|
56
|
|
|
|
|
|
|
];
|
57
|
50
|
50
|
|
50
|
|
373
|
eval $code;
|
|
50
|
50
|
|
50
|
|
100
|
|
|
50
|
50
|
|
50
|
|
2859
|
|
|
50
|
50
|
|
50
|
|
4742
|
|
|
50
|
50
|
|
50
|
|
337
|
|
|
50
|
50
|
|
50
|
|
100
|
|
|
50
|
50
|
|
50
|
|
2348
|
|
|
50
|
50
|
|
50
|
|
4635
|
|
|
50
|
50
|
|
50
|
|
380
|
|
|
50
|
50
|
|
50
|
|
124
|
|
|
50
|
50
|
|
50
|
|
2765
|
|
|
50
|
50
|
|
50
|
|
5007
|
|
|
50
|
50
|
|
50
|
|
342
|
|
|
50
|
50
|
|
50
|
|
101
|
|
|
50
|
50
|
|
50
|
|
3136
|
|
|
50
|
50
|
|
50
|
|
5286
|
|
|
50
|
50
|
|
50
|
|
377
|
|
|
50
|
50
|
|
50
|
|
131
|
|
|
50
|
50
|
|
50
|
|
2984
|
|
|
50
|
50
|
|
50
|
|
4736
|
|
|
50
|
50
|
|
50
|
|
373
|
|
|
50
|
50
|
|
50
|
|
130
|
|
|
50
|
50
|
|
50
|
|
2979
|
|
|
50
|
50
|
|
50
|
|
5104
|
|
|
50
|
50
|
|
50
|
|
368
|
|
|
50
|
50
|
|
50
|
|
113
|
|
|
50
|
50
|
|
50
|
|
2708
|
|
|
50
|
50
|
|
50
|
|
4909
|
|
|
50
|
50
|
|
50
|
|
373
|
|
|
50
|
50
|
|
50
|
|
152
|
|
|
50
|
50
|
|
50
|
|
3005
|
|
|
50
|
50
|
|
50
|
|
5581
|
|
|
50
|
50
|
|
50
|
|
387
|
|
|
50
|
50
|
|
50
|
|
125
|
|
|
50
|
50
|
|
50
|
|
3039
|
|
|
50
|
50
|
|
50
|
|
4812
|
|
|
50
|
50
|
|
50
|
|
361
|
|
|
50
|
50
|
|
50
|
|
117
|
|
|
50
|
50
|
|
50
|
|
2664
|
|
|
50
|
50
|
|
50
|
|
4724
|
|
|
50
|
50
|
|
50
|
|
359
|
|
|
50
|
50
|
|
50
|
|
115
|
|
|
50
|
|
|
50
|
|
2842
|
|
|
50
|
|
|
50
|
|
4815
|
|
|
50
|
|
|
50
|
|
411
|
|
|
50
|
|
|
50
|
|
133
|
|
|
50
|
|
|
50
|
|
2945
|
|
|
50
|
|
|
50
|
|
4762
|
|
|
50
|
|
|
50
|
|
364
|
|
|
50
|
|
|
50
|
|
115
|
|
|
50
|
|
|
50
|
|
2830
|
|
|
50
|
|
|
50
|
|
4698
|
|
|
50
|
|
|
50
|
|
388
|
|
|
50
|
|
|
50
|
|
114
|
|
|
50
|
|
|
50
|
|
2666
|
|
|
50
|
|
|
50
|
|
5447
|
|
|
50
|
|
|
50
|
|
384
|
|
|
50
|
|
|
50
|
|
105
|
|
|
50
|
|
|
50
|
|
3017
|
|
|
50
|
|
|
50
|
|
5659
|
|
|
50
|
|
|
50
|
|
369
|
|
|
50
|
|
|
50
|
|
152
|
|
|
50
|
|
|
50
|
|
2939
|
|
|
50
|
|
|
50
|
|
4677
|
|
|
50
|
|
|
50
|
|
393
|
|
|
50
|
|
|
50
|
|
118
|
|
|
50
|
|
|
50
|
|
2536
|
|
|
50
|
|
|
50
|
|
5127
|
|
|
50
|
|
|
50
|
|
397
|
|
|
50
|
|
|
50
|
|
119
|
|
|
50
|
|
|
50
|
|
2994
|
|
|
50
|
|
|
50
|
|
5054
|
|
|
50
|
|
|
50
|
|
379
|
|
|
50
|
|
|
50
|
|
132
|
|
|
50
|
|
|
50
|
|
3528
|
|
|
50
|
|
|
50
|
|
5332
|
|
|
50
|
|
|
50
|
|
399
|
|
|
50
|
|
|
50
|
|
129
|
|
|
50
|
|
|
50
|
|
2798
|
|
|
50
|
|
|
50
|
|
4652
|
|
|
50
|
|
|
50
|
|
377
|
|
|
50
|
|
|
50
|
|
129
|
|
|
50
|
|
|
50
|
|
2671
|
|
|
50
|
|
|
50
|
|
4933
|
|
|
50
|
|
|
50
|
|
400
|
|
|
50
|
|
|
50
|
|
137
|
|
|
50
|
|
|
50
|
|
2923
|
|
|
50
|
|
|
50
|
|
6552
|
|
|
50
|
|
|
50
|
|
387
|
|
|
50
|
|
|
50
|
|
225
|
|
|
50
|
|
|
50
|
|
3965
|
|
|
50
|
|
|
50
|
|
5489
|
|
|
50
|
|
|
50
|
|
433
|
|
|
50
|
|
|
50
|
|
119
|
|
|
50
|
|
|
50
|
|
2804
|
|
|
50
|
|
|
50
|
|
4827
|
|
|
50
|
|
|
50
|
|
359
|
|
|
50
|
|
|
50
|
|
131
|
|
|
50
|
|
|
50
|
|
5083
|
|
|
50
|
|
|
50
|
|
4650
|
|
|
50
|
|
|
50
|
|
367
|
|
|
50
|
|
|
50
|
|
99
|
|
|
50
|
|
|
50
|
|
2811
|
|
|
50
|
|
|
50
|
|
4988
|
|
|
50
|
|
|
50
|
|
400
|
|
|
50
|
|
|
50
|
|
131
|
|
|
50
|
|
|
50
|
|
2971
|
|
|
50
|
|
|
50
|
|
5022
|
|
|
50
|
|
|
50
|
|
382
|
|
|
50
|
|
|
50
|
|
197
|
|
|
50
|
|
|
50
|
|
2863
|
|
|
50
|
|
|
50
|
|
4999
|
|
|
50
|
|
|
50
|
|
353
|
|
|
50
|
|
|
50
|
|
99
|
|
|
50
|
|
|
50
|
|
2831
|
|
|
50
|
|
|
50
|
|
4686
|
|
|
50
|
|
|
50
|
|
368
|
|
|
50
|
|
|
50
|
|
115
|
|
|
50
|
|
|
50
|
|
2879
|
|
|
50
|
|
|
50
|
|
5405
|
|
|
50
|
|
|
50
|
|
363
|
|
|
50
|
|
|
50
|
|
100
|
|
|
50
|
|
|
50
|
|
2315
|
|
|
50
|
|
|
50
|
|
4659
|
|
|
50
|
|
|
50
|
|
365
|
|
|
50
|
|
|
50
|
|
142
|
|
|
50
|
|
|
|
|
2695
|
|
|
50
|
|
|
|
|
4982
|
|
|
50
|
|
|
|
|
363
|
|
|
50
|
|
|
|
|
124
|
|
|
50
|
|
|
|
|
2725
|
|
|
50
|
|
|
|
|
4931
|
|
|
50
|
|
|
|
|
363
|
|
|
50
|
|
|
|
|
110
|
|
|
50
|
|
|
|
|
2471
|
|
|
50
|
|
|
|
|
4468
|
|
|
50
|
|
|
|
|
399
|
|
|
50
|
|
|
|
|
111
|
|
|
50
|
|
|
|
|
2643
|
|
|
50
|
|
|
|
|
5120
|
|
|
50
|
|
|
|
|
367
|
|
|
50
|
|
|
|
|
122
|
|
|
50
|
|
|
|
|
2773
|
|
|
50
|
|
|
|
|
5053
|
|
|
50
|
|
|
|
|
376
|
|
|
50
|
|
|
|
|
111
|
|
|
50
|
|
|
|
|
2905
|
|
|
50
|
|
|
|
|
4815
|
|
|
50
|
|
|
|
|
370
|
|
|
50
|
|
|
|
|
104
|
|
|
50
|
|
|
|
|
2483
|
|
|
50
|
|
|
|
|
4957
|
|
|
50
|
|
|
|
|
335
|
|
|
50
|
|
|
|
|
116
|
|
|
50
|
|
|
|
|
2633
|
|
|
50
|
|
|
|
|
4590
|
|
|
50
|
|
|
|
|
335
|
|
|
50
|
|
|
|
|
109
|
|
|
50
|
|
|
|
|
3028
|
|
|
50
|
|
|
|
|
4628
|
|
|
50
|
|
|
|
|
363
|
|
|
50
|
|
|
|
|
105
|
|
|
50
|
|
|
|
|
2518
|
|
|
50
|
|
|
|
|
5114
|
|
|
50
|
|
|
|
|
403
|
|
|
50
|
|
|
|
|
139
|
|
|
50
|
|
|
|
|
3498
|
|
|
50
|
|
|
|
|
4990
|
|
|
2100
|
|
|
|
|
181124
|
|
58
|
2100
|
50
|
|
|
|
12431
|
return 0 if $@;
|
59
|
2100
|
|
|
|
|
5739
|
1;
|
60
|
|
|
|
|
|
|
}
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub _debug {
|
63
|
18614
|
|
|
18614
|
|
95080
|
my $msg = shift;
|
64
|
18614
|
|
66
|
|
|
31020
|
my $caller = (shift or caller);
|
65
|
18614
|
50
|
|
|
|
37582
|
print STDERR __PACKAGE__." DEBUG: Package $caller, $msg\n" if $parameters->{$caller}->{debug};
|
66
|
|
|
|
|
|
|
}
|
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub _find_symbols {
|
69
|
50
|
|
|
50
|
|
85
|
my $self = shift;
|
70
|
50
|
|
|
|
|
66
|
my $package = shift;
|
71
|
50
|
|
|
|
|
83
|
my @paths;
|
72
|
|
|
|
|
|
|
my $seen_paths;
|
73
|
50
|
|
|
|
|
129
|
_debug("Looking for symbols", $package);
|
74
|
50
|
|
|
|
|
304
|
for my $i (Submodules->find("${package}::Perlmazing")) {
|
75
|
13800
|
100
|
|
|
|
2298021
|
next if $i->{Clobber};
|
76
|
4600
|
|
|
|
|
12142
|
_debug("Found file $i->{AbsPath} for symbol $i->{Name}", $package);
|
77
|
4600
|
|
|
|
|
16220
|
$found_symbols->{$package}->{$i->Name} = $i;
|
78
|
4600
|
100
|
|
|
|
61543
|
if ($i->Module eq "${package}::Perlmazing::Precompile::$i->{Name}") {
|
79
|
2550
|
|
|
|
|
33320
|
$precompile_symbols->{$package}->{$i->Name} = $i;
|
80
|
|
|
|
|
|
|
}
|
81
|
50
|
|
|
50
|
|
426
|
no strict 'refs';
|
|
50
|
|
|
|
|
98
|
|
|
50
|
|
|
|
|
2029
|
|
82
|
50
|
|
|
50
|
|
295
|
no warnings; # prevents during-cleanup warnings when Submodules was destroyed and $i is undefined
|
|
50
|
|
|
|
|
99
|
|
|
50
|
|
|
|
|
62157
|
|
83
|
4600
|
|
|
|
|
19091
|
*{"${package}::$i->{Name}"} = sub {
|
84
|
1092
|
|
|
1092
|
|
18258
|
unshift @_, $package, $i->Name;
|
85
|
1092
|
|
|
|
|
15530
|
goto &_autoload;
|
86
|
4600
|
|
|
|
|
60974
|
};
|
87
|
|
|
|
|
|
|
}
|
88
|
|
|
|
|
|
|
}
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub precompile {
|
91
|
50
|
|
|
50
|
1
|
119
|
my $self = shift;
|
92
|
50
|
|
|
|
|
119
|
my $package = caller;
|
93
|
50
|
50
|
|
|
|
190
|
return unless exists $precompile_symbols->{$package};
|
94
|
50
|
|
|
|
|
104
|
for my $name (sort keys %{$precompile_symbols->{$package}}) {
|
|
50
|
|
|
|
|
1148
|
|
95
|
|
|
|
|
|
|
# We detect already precompiled symbols by undefining this variable
|
96
|
|
|
|
|
|
|
# Note that symbols can in some cases (by internal recursion) be called
|
97
|
|
|
|
|
|
|
# more than once, not allowing _load_symbol to complete and mark it as loaded
|
98
|
|
|
|
|
|
|
# before being called again, so this part comes handy in those cases.
|
99
|
2550
|
50
|
|
|
|
6643
|
next if not defined $precompile_symbols->{$package}->{$name};
|
100
|
2550
|
|
|
|
|
4189
|
undef $precompile_symbols->{$package}->{$name};
|
101
|
2550
|
|
|
|
|
6141
|
_debug("Precompiling symbol $name", $package);
|
102
|
2550
|
|
|
|
|
4324
|
_load_symbol($package, $name);
|
103
|
|
|
|
|
|
|
}
|
104
|
|
|
|
|
|
|
}
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub _preload {
|
107
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
108
|
0
|
|
|
|
|
0
|
my $package = shift;
|
109
|
0
|
|
|
|
|
0
|
for my $i (@_) {
|
110
|
0
|
|
|
|
|
0
|
_debug("Preloading symbol $i", $package);
|
111
|
0
|
|
|
|
|
0
|
_load_symbol($package, $i);
|
112
|
|
|
|
|
|
|
}
|
113
|
|
|
|
|
|
|
}
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub _autoload {
|
116
|
1092
|
|
|
1092
|
|
1896
|
my ($package, $symbol) = (shift, shift);
|
117
|
1092
|
|
|
|
|
2617
|
_debug("Autoloading symbol $symbol", $package);
|
118
|
1092
|
|
|
|
|
1794
|
my $code = _load_symbol($package, $symbol);
|
119
|
1092
|
|
|
|
|
2926
|
goto $code;
|
120
|
|
|
|
|
|
|
}
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub _load_symbol {
|
123
|
3642
|
|
|
3642
|
|
6241
|
my ($package, $symbol) = (shift, shift);
|
124
|
3642
|
|
|
|
|
4479
|
local $@;
|
125
|
3642
|
100
|
100
|
|
|
14637
|
return $loaded_symbols->{$package}->{$symbol} if exists $loaded_symbols->{$package} and exists $loaded_symbols->{$package}->{$symbol};
|
126
|
2568
|
50
|
33
|
|
|
8618
|
croak "File $package/Perlmazing/$symbol.pm cannot be found in \@INC for symbol \&${package}::$symbol - \@INC contains: @INC" unless exists $found_symbols->{$package} and exists $found_symbols->{$package}->{$symbol};
|
127
|
2568
|
|
|
|
|
10894
|
_debug("Reading file $found_symbols->{$package}->{$symbol}", $package);
|
128
|
2568
|
|
|
|
|
7188
|
my $code = $found_symbols->{$package}->{$symbol}->read;
|
129
|
2568
|
|
|
|
|
313222
|
_debug("Parsing contents of $found_symbols->{$package}->{$symbol}->{AbsPath}", $package);
|
130
|
2568
|
|
|
|
|
3792
|
my $stderr = '';
|
131
|
2568
|
|
|
|
|
8045
|
my $eval_string = "\n#line 1 $found_symbols->{$package}->{$symbol}->{AbsPath}\npackage ${package}::Perlmazing::$symbol; $code";
|
132
|
|
|
|
|
|
|
{
|
133
|
2568
|
|
|
|
|
3466
|
local *STDERR;
|
|
2568
|
|
|
|
|
5400
|
|
134
|
50
|
|
|
50
|
|
316
|
open STDERR, '>>', \$stderr;
|
|
50
|
|
|
|
|
109
|
|
|
50
|
|
|
|
|
383
|
|
|
2568
|
|
|
|
|
19113
|
|
135
|
2568
|
|
|
|
|
48092
|
untaint $eval_string;
|
136
|
2568
|
|
|
|
|
826938
|
eval $eval_string;
|
137
|
|
|
|
|
|
|
}
|
138
|
2568
|
50
|
|
|
|
19177
|
if (my $e = $@) {
|
139
|
0
|
|
|
|
|
0
|
croak "While attempting to load symbol '$symbol': $e";
|
140
|
|
|
|
|
|
|
}
|
141
|
2568
|
50
|
|
|
|
5792
|
print STDERR $stderr if length $stderr;
|
142
|
2568
|
|
|
|
|
31689
|
$loaded_symbols->{$package}->{$symbol} = "${package}::Perlmazing::${symbol}"->can('main');
|
143
|
2568
|
50
|
|
|
|
7440
|
die "Unable to find sub 'main' at $found_symbols->{$package}->{$symbol}->{AbsPath} line 1 to EOF\n" unless $loaded_symbols->{$package}->{$symbol};
|
144
|
2568
|
|
|
|
|
10757
|
_debug("Replacing skeleton symbol with actual code from $found_symbols->{$package}->{$symbol}->{AbsPath}", $package);
|
145
|
2568
|
50
|
|
|
|
18300
|
if ("${package}::Perlmazing::${symbol}"->isa('Perlmazing::Listable')) {
|
146
|
0
|
|
|
|
|
0
|
_debug("Symbol &${package}::$symbol isa Perlmazing::Listable, creating wrapper sub around it", $package);
|
147
|
0
|
|
|
|
|
0
|
my $sub_main = $loaded_symbols->{$package}->{$symbol};
|
148
|
|
|
|
|
|
|
my $sub_pre = sub {
|
149
|
0
|
|
|
0
|
|
0
|
for my $i (@_) {
|
150
|
0
|
|
|
|
|
0
|
$sub_main->($i);
|
151
|
|
|
|
|
|
|
}
|
152
|
0
|
|
|
|
|
0
|
};
|
153
|
|
|
|
|
|
|
$loaded_symbols->{$package}->{$symbol} = sub {
|
154
|
0
|
|
|
0
|
|
0
|
my $wantarray = wantarray;
|
155
|
0
|
|
|
|
|
0
|
my @call = caller(1);
|
156
|
0
|
|
|
|
|
0
|
my @res = eval {
|
157
|
0
|
0
|
|
|
|
0
|
(@_) = ($_) if not @_;
|
158
|
0
|
0
|
|
|
|
0
|
if ($wantarray) {
|
|
|
0
|
|
|
|
|
|
159
|
0
|
|
|
|
|
0
|
my @res = @_;
|
160
|
0
|
|
|
|
|
0
|
foreach my $i (@res) {
|
161
|
0
|
|
|
|
|
0
|
$sub_pre->($i);
|
162
|
|
|
|
|
|
|
}
|
163
|
0
|
|
|
|
|
0
|
return @res;
|
164
|
|
|
|
|
|
|
} elsif (defined $wantarray) {
|
165
|
0
|
|
|
|
|
0
|
my $i = $_[0];
|
166
|
0
|
|
|
|
|
0
|
$sub_pre->($i);
|
167
|
0
|
|
|
|
|
0
|
return $i;
|
168
|
|
|
|
|
|
|
} else {
|
169
|
0
|
|
|
|
|
0
|
foreach my $i (@_) {
|
170
|
0
|
|
|
|
|
0
|
$sub_pre->($i);
|
171
|
|
|
|
|
|
|
}
|
172
|
|
|
|
|
|
|
}
|
173
|
|
|
|
|
|
|
};
|
174
|
0
|
0
|
|
|
|
0
|
if (my $e = $@) {
|
175
|
0
|
0
|
|
|
|
0
|
if ($e =~ /^Modification of a read\-only value attempted/) {
|
176
|
0
|
|
|
|
|
0
|
die "Modification of a read-only value attempted at $call[1] line $call[2]\n";
|
177
|
|
|
|
|
|
|
} else {
|
178
|
0
|
|
|
|
|
0
|
die "Unhandled error in listable function: $e\n";
|
179
|
|
|
|
|
|
|
}
|
180
|
|
|
|
|
|
|
}
|
181
|
0
|
0
|
|
|
|
0
|
return @res if $wantarray;
|
182
|
0
|
|
|
|
|
0
|
$res[0];
|
183
|
0
|
|
|
|
|
0
|
};
|
184
|
|
|
|
|
|
|
}
|
185
|
50
|
|
|
50
|
|
434
|
no strict 'refs';
|
|
50
|
|
|
|
|
94
|
|
|
50
|
|
|
|
|
1707
|
|
186
|
50
|
|
|
50
|
|
269
|
no warnings qw(redefine once);
|
|
50
|
|
|
|
|
91
|
|
|
50
|
|
|
|
|
23245
|
|
187
|
2568
|
|
|
|
|
4796
|
my $skeleton = *{"${package}::$symbol"}{CODE};
|
|
2568
|
|
|
|
|
7138
|
|
188
|
2568
|
|
|
|
|
5032
|
my ($callers, $offset);
|
189
|
2568
|
|
|
|
|
8182
|
while (my $caller = caller($offset++)) {
|
190
|
13043
|
|
|
|
|
27356
|
$callers->{$caller}++;
|
191
|
|
|
|
|
|
|
}
|
192
|
2568
|
|
|
|
|
3566
|
$callers->{$package}++;
|
193
|
2568
|
|
|
|
|
8349
|
for my $i (keys %$callers) {
|
194
|
7756
|
100
|
|
|
|
14396
|
next if $i eq __PACKAGE__;
|
195
|
5188
|
100
|
|
|
|
5250
|
if (my $ref = *{"${i}::$symbol"}{CODE}) {
|
|
5188
|
|
|
|
|
18336
|
|
196
|
2587
|
|
|
|
|
2939
|
my $proto_old = prototype \&{"${i}::$symbol"};
|
|
2587
|
|
|
|
|
6118
|
|
197
|
2587
|
|
|
|
|
5579
|
my $proto_new = prototype $loaded_symbols->{$package}->{$symbol};
|
198
|
2587
|
100
|
66
|
|
|
21562
|
if ((defined $proto_new and defined $proto_old and $proto_old ne $proto_new) or (defined $proto_old and not defined $proto_new) or (defined $proto_new and not defined $proto_old)) {
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
199
|
2100
|
50
|
|
|
|
4315
|
carp "Warning: Too late to apply prototype ($proto_new) to symbol &${i}::$symbol - perl compilation phase has passed already" unless _is_compile_phase();
|
200
|
2100
|
|
|
|
|
2905
|
set_prototype \&{"${i}::$symbol"}, $proto_new;
|
|
2100
|
|
|
|
|
14957
|
|
201
|
|
|
|
|
|
|
}
|
202
|
2587
|
50
|
|
|
|
9975
|
*{"${i}::$symbol"} = $loaded_symbols->{$package}->{$symbol} if $ref eq $skeleton;
|
|
2587
|
|
|
|
|
12044
|
|
203
|
|
|
|
|
|
|
}
|
204
|
|
|
|
|
|
|
}
|
205
|
2568
|
|
|
|
|
10164
|
_debug(__PACKAGE__." no longer has power over symbol &${package}::$symbol (it's now loaded on it's own code)", $package);
|
206
|
2568
|
|
|
|
|
9097
|
$loaded_symbols->{$package}->{$symbol};
|
207
|
|
|
|
|
|
|
}
|
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
package Perlmazing::Listable;
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
1;
|
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
__END__
|