line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Evo::Internal::Util; |
2
|
67
|
|
|
67
|
|
375
|
use strict; |
|
67
|
|
|
|
|
136
|
|
|
67
|
|
|
|
|
1514
|
|
3
|
67
|
|
|
67
|
|
285
|
use warnings; |
|
67
|
|
|
|
|
397
|
|
|
67
|
|
|
|
|
1813
|
|
4
|
67
|
|
|
67
|
|
24870
|
use experimental 'signatures'; |
|
67
|
|
|
|
|
182884
|
|
|
67
|
|
|
|
|
334
|
|
5
|
67
|
|
|
67
|
|
8452
|
no warnings 'experimental::signatures'; |
|
67
|
|
|
|
|
141
|
|
|
67
|
|
|
|
|
1743
|
|
6
|
67
|
|
|
67
|
|
329
|
use Carp qw(carp croak); |
|
67
|
|
|
|
|
121
|
|
|
67
|
|
|
|
|
2891
|
|
7
|
67
|
|
|
67
|
|
349
|
use B qw(svref_2object); |
|
67
|
|
|
|
|
125
|
|
|
67
|
|
|
|
|
7228
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $RX_PKG_NOT_FIRST = qr/[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*/; |
10
|
|
|
|
|
|
|
our $RX_PKG = qr/^[A-Z_a-z]$RX_PKG_NOT_FIRST*$/; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
|
13
|
67
|
|
|
67
|
|
429
|
use constant SUBRE => qr/^[a-zA-Z_]\w*$/; |
|
67
|
|
|
|
|
165
|
|
|
67
|
|
|
|
|
13639
|
|
14
|
728
|
|
|
728
|
0
|
4269
|
sub check_subname { $_[0] =~ SUBRE } |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# usefull? |
17
|
0
|
0
|
|
0
|
0
|
0
|
sub find_caller_except ($skip_ns, $i, $caller) { |
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
18
|
0
|
|
|
|
|
0
|
while ($caller = (caller($i++))[0]) { |
19
|
0
|
0
|
|
|
|
0
|
return $caller if $caller ne $skip_ns; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
2069
|
50
|
|
2069
|
0
|
5408
|
sub monkey_patch ($pkg, %hash) { |
|
2069
|
50
|
|
|
|
4805
|
|
|
2069
|
|
|
|
|
3290
|
|
|
2069
|
|
|
|
|
7123
|
|
|
2069
|
|
|
|
|
3395
|
|
24
|
67
|
|
|
67
|
|
465
|
no strict 'refs'; ## no critic |
|
67
|
|
|
|
|
135
|
|
|
67
|
|
|
|
|
6952
|
|
25
|
2069
|
|
|
|
|
8189
|
*{"${pkg}::$_"} = $hash{$_} for keys %hash; |
|
5435
|
|
|
|
|
74302
|
|
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#todo: decide what to do with empty subroutins |
29
|
9
|
50
|
|
9
|
0
|
2657
|
sub monkey_patch_silent ($pkg, %hash) { |
|
9
|
50
|
|
|
|
27
|
|
|
9
|
|
|
|
|
121
|
|
|
9
|
|
|
|
|
32
|
|
|
9
|
|
|
|
|
16
|
|
30
|
67
|
|
|
67
|
|
395
|
no strict 'refs'; ## no critic |
|
67
|
|
|
|
|
146
|
|
|
67
|
|
|
|
|
1596
|
|
31
|
67
|
|
|
67
|
|
303
|
no warnings 'redefine'; |
|
67
|
|
|
|
|
129
|
|
|
67
|
|
|
|
|
14099
|
|
32
|
9
|
|
|
|
|
14
|
my %restore; |
33
|
9
|
|
|
|
|
26
|
foreach my $name (keys %hash) { |
34
|
10
|
|
|
|
|
19
|
$restore{$name} = *{"${pkg}::$name"}{CODE}; |
|
10
|
|
|
|
|
44
|
|
35
|
10
|
50
|
0
|
|
|
38
|
warn "Can't delete empty ${pkg}::$name" and next unless $hash{$name}; |
36
|
10
|
|
|
|
|
16
|
*{"${pkg}::$name"} = $hash{$name}; |
|
10
|
|
|
|
|
35
|
|
37
|
|
|
|
|
|
|
} |
38
|
9
|
|
|
|
|
42
|
\%restore; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# returns a package where code was declared and a name |
42
|
|
|
|
|
|
|
# ->CONST not documented, but exists in B::CV and defined in /CORE/cv.h as |
43
|
|
|
|
|
|
|
# define CvCONST(cv) (CvFLAGS(cv) & CVf_CONST) |
44
|
|
|
|
|
|
|
# this flag is used by Evo::Class to determine that constants should be inherited |
45
|
2741
|
50
|
|
2741
|
0
|
9897
|
sub code2names($r) { |
|
2741
|
50
|
|
|
|
5868
|
|
|
2741
|
|
|
|
|
3917
|
|
|
2741
|
|
|
|
|
3762
|
|
46
|
2741
|
|
|
|
|
7171
|
my $sv = svref_2object($r); |
47
|
2741
|
|
|
|
|
7301
|
my $gv = $sv->GV; |
48
|
2741
|
|
|
|
|
6589
|
my $stash = $gv->STASH; |
49
|
2741
|
|
|
|
|
13911
|
($stash->NAME, $gv->NAME, $sv->CONST); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
3881
|
50
|
|
3881
|
0
|
10948
|
sub names2code ($pkg, $name) { |
|
3881
|
50
|
|
|
|
7285
|
|
|
3881
|
|
|
|
|
5371
|
|
|
3881
|
|
|
|
|
5141
|
|
|
3881
|
|
|
|
|
4863
|
|
53
|
67
|
|
|
67
|
|
407
|
no strict 'refs'; ## no critic |
|
67
|
|
|
|
|
144
|
|
|
67
|
|
|
|
|
4925
|
|
54
|
3881
|
|
|
|
|
5214
|
*{"${pkg}::$name"}{CODE}; |
|
3881
|
|
|
|
|
16897
|
|
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
|
58
|
62
|
50
|
|
62
|
0
|
1272
|
sub list_symbols($pkg) { |
|
62
|
50
|
|
|
|
261
|
|
|
62
|
|
|
|
|
119
|
|
|
62
|
|
|
|
|
146
|
|
59
|
67
|
|
|
67
|
|
355
|
no strict 'refs'; ##no critic |
|
67
|
|
|
|
|
150
|
|
|
67
|
|
|
|
|
27207
|
|
60
|
62
|
|
|
|
|
106
|
grep { $_ =~ /^[a-zA-Z_]\w*$/ } keys %{"${pkg}::"}; |
|
1636
|
|
|
|
|
3694
|
|
|
62
|
|
|
|
|
376
|
|
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
#sub undef_symbols($ns) { |
64
|
|
|
|
|
|
|
# no strict 'refs'; ## no critic |
65
|
|
|
|
|
|
|
# undef *{"${ns}::$_"} for list_symbols($ns); |
66
|
|
|
|
|
|
|
#} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
#sub uniq { |
70
|
|
|
|
|
|
|
# my %seen; |
71
|
|
|
|
|
|
|
# return grep { !$seen{$_}++ } @_; |
72
|
|
|
|
|
|
|
#} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# returns a subroutine than can pretend a code in the other package/file/line |
75
|
1869
|
50
|
|
1869
|
0
|
5021
|
sub inject(%opts) { |
|
1869
|
|
|
|
|
7012
|
|
|
1869
|
|
|
|
|
2940
|
|
76
|
1869
|
|
|
|
|
5107
|
my ($package, $filename, $line, $code) = @opts{qw(package filename line code)}; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
## no critic |
79
|
|
|
|
|
|
|
( |
80
|
1869
|
|
|
|
|
110268
|
eval qq{package $package; |
81
|
|
|
|
|
|
|
#line $line "$filename" |
82
|
|
|
|
|
|
|
sub { \$code->(\@_) } |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
#sub find_subnames ($pkg, $code) { |
88
|
|
|
|
|
|
|
# no strict 'refs'; ## no critic |
89
|
|
|
|
|
|
|
# my %symbols = %{$pkg . "::"}; |
90
|
|
|
|
|
|
|
# |
91
|
|
|
|
|
|
|
# # because use constant adds refs to package symbols hash |
92
|
|
|
|
|
|
|
# grep { !ref($symbols{$_}) && (*{$symbols{$_}}{CODE} // 0) == $code } keys %symbols; |
93
|
|
|
|
|
|
|
#} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
|
96
|
140
|
50
|
|
140
|
|
419
|
sub _parent ($caller) { |
|
140
|
50
|
|
|
|
404
|
|
|
140
|
|
|
|
|
255
|
|
|
140
|
|
|
|
|
230
|
|
97
|
140
|
|
|
|
|
509
|
my @arr = split /::/, $caller; |
98
|
140
|
|
|
|
|
276
|
pop @arr; |
99
|
140
|
|
|
|
|
689
|
join '::', @arr; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
2566
|
50
|
|
2566
|
0
|
6804
|
sub resolve_package ($caller, $pkg) { |
|
2566
|
50
|
|
|
|
5748
|
|
|
2566
|
|
|
|
|
4334
|
|
|
2566
|
|
|
|
|
4934
|
|
|
2566
|
|
|
|
|
3952
|
|
103
|
|
|
|
|
|
|
|
104
|
2566
|
100
|
|
|
|
15588
|
return $pkg if $pkg =~ $RX_PKG; |
105
|
|
|
|
|
|
|
|
106
|
1703
|
100
|
|
|
|
14649
|
return "Evo::$1" if $pkg =~ /^\-($RX_PKG_NOT_FIRST)$/; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# parent. TODO: many // |
109
|
251
|
100
|
|
|
|
973
|
if ($pkg =~ /^\/(.*)$/) { |
110
|
140
|
|
|
|
|
344
|
my $rest = $1; |
111
|
140
|
100
|
|
|
|
386
|
my $parent = _parent($caller) |
112
|
|
|
|
|
|
|
or croak "Can't resolve $pkg: can't find parent of caller $caller"; |
113
|
|
|
|
|
|
|
|
114
|
139
|
50
|
|
|
|
2541
|
return "$parent$rest" if "$parent$rest" =~ /^$RX_PKG$/; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
111
|
100
|
|
|
|
2441
|
return "${caller}::$1" if $pkg =~ /^::($RX_PKG_NOT_FIRST)$/; |
118
|
|
|
|
|
|
|
|
119
|
4
|
|
|
|
|
392
|
croak "Can't resolve $pkg for caller $caller"; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
3
|
50
|
|
3
|
0
|
2842
|
sub suppress_carp ($me, $caller) { |
|
3
|
50
|
|
|
|
10
|
|
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
5
|
|
124
|
67
|
|
|
67
|
|
428
|
no strict 'refs'; ## no critic |
|
67
|
|
|
|
|
136
|
|
|
67
|
|
|
|
|
5007
|
|
125
|
3
|
100
|
|
|
|
4
|
push @{"${caller}::CARP_NOT"}, $me if !grep { $_ eq $me } @{"${caller}::CARP_NOT"}; |
|
2
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
15
|
|
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
1; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
__END__ |