line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::TraceUse; |
2
|
|
|
|
|
|
|
$Devel::TraceUse::VERSION = '2.097'; |
3
|
|
|
|
|
|
|
# detect being loaded via -d:TraceUse and disable the debugger features we |
4
|
|
|
|
|
|
|
# don't need. better names for evals (0x100) and anon subs (0x200). |
5
|
|
|
|
|
|
|
BEGIN { |
6
|
3
|
50
|
33
|
3
|
|
141195
|
if (!defined &DB::DB && $^P & 0x02) { |
7
|
0
|
|
|
|
|
0
|
$^P = 0x100 | 0x200; |
8
|
|
|
|
|
|
|
} |
9
|
|
|
|
|
|
|
} |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
BEGIN { |
12
|
3
|
|
|
3
|
|
54
|
unshift @INC, \&trace_use; |
13
|
|
|
|
|
|
|
*CORE::GLOBAL::require = sub { |
14
|
65
|
|
|
65
|
|
15574
|
my ($arg) = @_; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# ensure our hook remains first in @INC |
17
|
65
|
100
|
|
|
|
265
|
@INC = ( \&trace_use, grep "$_" ne \&trace_use . '', @INC ) |
18
|
|
|
|
|
|
|
if $INC[0] ne \&trace_use; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# let require do the heavy lifting |
21
|
65
|
|
|
|
|
437
|
CORE::require($arg); |
22
|
3
|
|
|
|
|
6132
|
}; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# initialize the tree of require calls |
26
|
|
|
|
|
|
|
my $root = (caller)[1]; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# keys in %TRACE: |
29
|
|
|
|
|
|
|
# - ranked: modules load attemps in chronological order |
30
|
|
|
|
|
|
|
# - loaded_by: track "filename"s loaded by "filepath" (value from %INC) |
31
|
|
|
|
|
|
|
# - used: track loaded modules by "filename" (parameter to require) |
32
|
|
|
|
|
|
|
# - loader: track potential proxy modules |
33
|
|
|
|
|
|
|
# |
34
|
|
|
|
|
|
|
# %TRACE is built incrementally by trace_use, and augmented by post_process |
35
|
|
|
|
|
|
|
my %TRACE; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my %reported; # track reported "filename" |
38
|
|
|
|
|
|
|
my $rank = 0; # record the loading order of modules |
39
|
|
|
|
|
|
|
my $quiet = 1; # no output until decided otherwise |
40
|
|
|
|
|
|
|
my $output_fh; # optional write filehandle where results will be output |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# Hide core modules (for the specified version)? |
43
|
|
|
|
|
|
|
my $hide_core = 0; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub import { |
46
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# ensure "use Devel::TraceUse ();" will produce no output |
49
|
0
|
|
|
|
|
0
|
$quiet = 0; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# process options |
52
|
0
|
|
|
|
|
0
|
for(@_) { |
53
|
0
|
0
|
|
|
|
0
|
if(/^hidecore(?::(.*))?/) { |
|
|
0
|
|
|
|
|
|
54
|
0
|
0
|
|
|
|
0
|
$hide_core = numify( $1 ? $1 : $] ); |
55
|
|
|
|
|
|
|
} elsif (/^output:(.*)$/) { |
56
|
0
|
0
|
|
|
|
0
|
open $output_fh, '>', $1 or die "can't open $1: $!"; |
57
|
|
|
|
|
|
|
} else { |
58
|
0
|
|
|
|
|
0
|
die "Unknown argument to $class: $_\n"; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
my @caller_info = qw( package filepath line ); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
### %TRACE CONSTRUCTION |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# Keys used in the data structure: |
68
|
|
|
|
|
|
|
# - filename: parameter passed to use/require |
69
|
|
|
|
|
|
|
# - module: module, computed from filename |
70
|
|
|
|
|
|
|
# - rank: rank of loading |
71
|
|
|
|
|
|
|
# - eval: was this use/require done in an eval? |
72
|
|
|
|
|
|
|
# - loaded: list of files loaded from this one |
73
|
|
|
|
|
|
|
# - filepath: file that was actually loaded from disk (obtained from %INC) |
74
|
|
|
|
|
|
|
# - caller: information on the caller (same keys + everything from caller()) |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub trace_use |
77
|
|
|
|
|
|
|
{ |
78
|
18
|
|
|
18
|
0
|
158044
|
my ( $code, $filename ) = @_; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# $filename may be an actual filename, e.g. with do() |
81
|
|
|
|
|
|
|
# try to compute a module name from it |
82
|
18
|
|
|
|
|
28
|
my $module = $filename; |
83
|
18
|
50
|
|
|
|
140
|
$module =~ s{/}{::}g |
84
|
|
|
|
|
|
|
if $module =~ s/\.pm$//; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# chronological list of modules we tried to load |
87
|
18
|
|
|
|
|
36
|
push @{ $TRACE{ranked} }, my $info = { |
|
18
|
|
|
|
|
99
|
|
88
|
|
|
|
|
|
|
filename => $filename, |
89
|
|
|
|
|
|
|
module => $module, |
90
|
|
|
|
|
|
|
rank => ++$rank, |
91
|
|
|
|
|
|
|
eval => '', |
92
|
|
|
|
|
|
|
}; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# info about the loading module |
95
|
18
|
|
|
|
|
52
|
my $caller = $info->{caller} = {}; |
96
|
18
|
|
|
|
|
27
|
my $caller_initial_level = 1; # one for the require() wrapper |
97
|
18
|
50
|
|
|
|
48
|
$caller_initial_level++ if $] >= 5.037007; # and another for modern perls |
98
|
|
|
|
|
|
|
# which eval the INC hook. |
99
|
18
|
|
|
|
|
96
|
@{$caller}{@caller_info} = caller($caller_initial_level); |
|
18
|
|
|
|
|
72
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# try to compute a "filename" (as received by require) |
102
|
18
|
|
|
|
|
47
|
$caller->{filename} = $caller->{filepath}; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# some values seen in the wild: |
105
|
|
|
|
|
|
|
# - "(eval $num)[$path:$line]" (debugger) |
106
|
|
|
|
|
|
|
# - "$filename (autosplit into $path)" (AutoLoader) |
107
|
18
|
100
|
|
|
|
61
|
if ( $caller->{filename} =~ /^(\(eval \d+\))(?:\[(.*):(\d+)\])?$/ ) { |
108
|
2
|
|
|
|
|
4
|
$info->{eval} = $1; |
109
|
2
|
|
|
|
|
6
|
$caller->{filename} = $caller->{filepath} = $2; |
110
|
2
|
|
|
|
|
4
|
$caller->{line} = $3; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# clean up path |
114
|
|
|
|
|
|
|
$caller->{filename} |
115
|
18
|
|
|
|
|
32
|
=~ s!^(?:@{[ join '|', map quotemeta, reverse sort @INC ]})/?!!; |
|
18
|
|
|
|
|
1282
|
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# try to compute the package associated with the file |
118
|
18
|
|
|
|
|
77
|
$caller->{filepackage} = $caller->{filename}; |
119
|
18
|
|
|
|
|
44
|
$caller->{filepackage} =~ s/\.(pm|al)\s.*$/.$1/; |
120
|
|
|
|
|
|
|
$caller->{filepackage} =~ s{/}{::}g |
121
|
18
|
100
|
|
|
|
89
|
if $caller->{filepackage} =~ s/\.pm$//; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# record who tried to load us (and store our index) |
124
|
18
|
|
|
|
|
36
|
push @{ $TRACE{loaded_by}{ $caller->{filepath} } }, $info->{rank} - 1; |
|
18
|
|
|
|
|
69
|
|
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# record potential proxies |
127
|
18
|
50
|
|
|
|
54
|
if ( $caller->{filename} ) { |
128
|
18
|
|
|
|
|
27
|
my $level = $caller_initial_level; # set up above |
129
|
18
|
|
|
|
|
27
|
my $subroutine; |
130
|
18
|
|
100
|
|
|
136
|
while ( $subroutine = ( caller ++$level )[3] || '' ) { |
131
|
21
|
100
|
|
|
|
139
|
last if $subroutine =~ /::/; |
132
|
|
|
|
|
|
|
} |
133
|
18
|
|
|
|
|
37
|
$TRACE{loader}{ join "\0", @{$caller}{qw( filename line )}, $subroutine }++; |
|
18
|
|
|
|
|
76
|
|
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# let Perl ultimately find the required file |
137
|
18
|
|
|
|
|
12755
|
return; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# some post-processing that requires the modules to have been actually loaded |
141
|
|
|
|
|
|
|
sub post_process { |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# process the list of loading attempts in reverse order: |
144
|
|
|
|
|
|
|
# if a module shows up more than once, then all occurences |
145
|
|
|
|
|
|
|
# are failures to load, except maybe the last one |
146
|
0
|
0
|
|
0
|
0
|
0
|
for my $module ( reverse @{ $TRACE{ranked} || [] } ) { |
|
0
|
|
|
|
|
0
|
|
147
|
0
|
|
|
|
|
0
|
my $filename = $module->{filename}; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# module was successfully loaded |
150
|
0
|
0
|
|
|
|
0
|
if ( exists $INC{$filename} ) { |
151
|
0
|
|
0
|
|
|
0
|
$TRACE{used}{$filename} ||= $module; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# map "filename" to "filepath" for everything that was loaded |
156
|
0
|
|
|
|
|
0
|
while ( my ( $filename, $filepath ) = each %INC ) { |
157
|
0
|
0
|
|
|
|
0
|
if ( exists $TRACE{used}{$filename} ) { |
158
|
0
|
|
0
|
|
|
0
|
$TRACE{used}{$filename}{loaded} = delete $TRACE{loaded_by}{$filepath} || []; |
159
|
0
|
|
|
|
|
0
|
$TRACE{used}{$filename}{filepath} = $filepath; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# extract version |
164
|
0
|
|
|
|
|
0
|
for my $mod ( @{ $TRACE{ranked} } ) { |
|
0
|
|
|
|
|
0
|
|
165
|
0
|
|
|
|
|
0
|
$mod->{version} = ${"$mod->{module}\::VERSION"}; |
|
0
|
|
|
|
|
0
|
|
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
### UTILITY FUNCTIONS |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# we don't want to use version.pm on old Perls |
172
|
|
|
|
|
|
|
sub numify { |
173
|
24
|
|
|
24
|
0
|
117763
|
my ($version) = @_; |
174
|
24
|
|
|
|
|
52
|
$version =~ y/_//d; |
175
|
24
|
|
|
|
|
80
|
my @parts = split /\./, $version; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# %Module::CoreList::version's keys are x.yyyzzz *numbers* |
178
|
24
|
|
|
|
|
212
|
return 0+ join '', shift @parts, '.', map sprintf( '%03s', $_ ), @parts; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
### OUTPUT FORMATTERS |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub show_trace_visitor { |
184
|
0
|
|
|
0
|
0
|
0
|
my ( $mod, $pos, $output_cb, @args ) = @_; |
185
|
|
|
|
|
|
|
|
186
|
0
|
|
|
|
|
0
|
my $caller = $mod->{caller}; |
187
|
0
|
|
|
|
|
0
|
my $message = sprintf( '%4s.', $mod->{rank} ) . ' ' x $pos; |
188
|
0
|
|
|
|
|
0
|
$message .= "$mod->{module}"; |
189
|
0
|
0
|
|
|
|
0
|
$message .= defined $mod->{version} ? " $mod->{version}," : ','; |
190
|
|
|
|
|
|
|
$message .= " $caller->{filename}" |
191
|
0
|
0
|
|
|
|
0
|
if defined $caller->{filename}; |
192
|
|
|
|
|
|
|
$message .= " line $caller->{line}" |
193
|
0
|
0
|
|
|
|
0
|
if defined $caller->{line}; |
194
|
|
|
|
|
|
|
$message .= " $mod->{eval}" |
195
|
0
|
0
|
|
|
|
0
|
if $mod->{eval}; |
196
|
|
|
|
|
|
|
$message .= " [$caller->{package}]" |
197
|
0
|
0
|
|
|
|
0
|
if $caller->{package} ne $caller->{filepackage}; |
198
|
|
|
|
|
|
|
$message .= " (FAILED)" |
199
|
0
|
0
|
|
|
|
0
|
if !exists $mod->{filepath}; |
200
|
|
|
|
|
|
|
|
201
|
0
|
|
|
|
|
0
|
$output_cb->($message, @args); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub visit_trace |
205
|
|
|
|
|
|
|
{ |
206
|
0
|
|
|
0
|
0
|
0
|
my ( $visitor, $mod, $pos, @args ) = @_; |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
|
|
|
0
|
my $hide = 0; |
209
|
|
|
|
|
|
|
|
210
|
0
|
0
|
|
|
|
0
|
if ( ref $mod ) { |
211
|
0
|
0
|
|
|
|
0
|
if($hide_core) { |
212
|
0
|
|
|
|
|
0
|
$hide = exists $Module::CoreList::version{$hide_core}{$mod->{module}}; |
213
|
|
|
|
|
|
|
} |
214
|
0
|
0
|
|
|
|
0
|
$visitor->( $mod, $pos, @args ) unless $hide; |
215
|
0
|
|
|
|
|
0
|
$reported{$mod->{filename}}++; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
else { |
218
|
0
|
|
|
|
|
0
|
$mod = { loaded => delete $TRACE{loaded_by}{$mod} }; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
visit_trace( $visitor, $_, $hide ? $pos : $pos + 1, @args ) |
222
|
0
|
0
|
|
|
|
0
|
for map $TRACE{ranked}[$_], @{ $mod->{loaded} }; |
|
0
|
|
|
|
|
0
|
|
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
sub dump_proxies |
226
|
|
|
|
|
|
|
{ |
227
|
0
|
|
|
0
|
0
|
0
|
my $output = shift; |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
my @hot_loaders = |
230
|
0
|
|
|
|
|
0
|
sort { $TRACE{loader}{$b} <=> $TRACE{loader}{$a} } |
231
|
0
|
|
|
|
|
0
|
grep { $TRACE{loader}{$_} > 1 } |
232
|
0
|
|
|
|
|
0
|
keys %{ $TRACE{loader} }; |
|
0
|
|
|
|
|
0
|
|
233
|
|
|
|
|
|
|
|
234
|
0
|
0
|
|
|
|
0
|
return unless @hot_loaders; |
235
|
|
|
|
|
|
|
|
236
|
0
|
|
|
|
|
0
|
$output->("Possible proxies:"); |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
|
|
0
|
for my $loader (@hot_loaders) { |
239
|
0
|
|
|
|
|
0
|
my ( $filename, $line, $subroutine ) = split /\0/, $loader; |
240
|
|
|
|
|
|
|
$output->(sprintf("%4d %s line %d%s", |
241
|
0
|
0
|
|
|
|
0
|
$TRACE{loader}{$loader}, |
242
|
|
|
|
|
|
|
$filename, $line, |
243
|
|
|
|
|
|
|
(length($subroutine) ? ", sub $subroutine" : ''))); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub dump_result |
248
|
|
|
|
|
|
|
{ |
249
|
3
|
50
|
|
3
|
0
|
113
|
return if $quiet; |
250
|
|
|
|
|
|
|
|
251
|
0
|
|
|
|
|
0
|
post_process(); |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# let people know more accurate information is available |
254
|
0
|
0
|
|
|
|
0
|
warn "Use -d:TraceUse for more accurate information.\n" if !$^P; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# load Module::CoreList if needed |
257
|
0
|
0
|
|
|
|
0
|
if ($hide_core) { |
258
|
0
|
|
|
|
|
0
|
local @INC = grep { $_ ne \&trace_use } @INC; |
|
0
|
|
|
|
|
0
|
|
259
|
0
|
|
|
|
|
0
|
local %INC = %INC; # don't report it loaded |
260
|
0
|
|
|
0
|
|
0
|
local *trace_use = sub {}; |
261
|
0
|
|
|
|
|
0
|
require Module::CoreList; |
262
|
|
|
|
|
|
|
warn sprintf "Module::CoreList %s doesn't know about Perl %s\n", |
263
|
|
|
|
|
|
|
$Module::CoreList::VERSION, $hide_core |
264
|
0
|
0
|
|
|
|
0
|
if !exists $Module::CoreList::version{$hide_core}; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
my $output = defined $output_fh |
268
|
0
|
|
|
0
|
|
0
|
? sub { print $output_fh "$_[0]\n" } |
269
|
0
|
0
|
|
0
|
|
0
|
: sub { warn "$_[0]\n" }; |
|
0
|
|
|
|
|
0
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# output the diagnostic |
272
|
0
|
|
|
|
|
0
|
$output->("Modules used from $root:"); |
273
|
0
|
|
|
|
|
0
|
visit_trace( \&show_trace_visitor, $root, 0, $output ); |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# anything left? |
276
|
0
|
0
|
|
|
|
0
|
if ( %{ $TRACE{loaded_by} } ) { |
|
0
|
|
|
|
|
0
|
|
277
|
|
|
|
|
|
|
visit_trace( \&show_trace_visitor, $_, 0, $output ) |
278
|
0
|
|
|
|
|
0
|
for sort keys %{ $TRACE{loaded_by} }; |
|
0
|
|
|
|
|
0
|
|
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
# did we miss some modules? |
282
|
0
|
0
|
|
|
|
0
|
if (my @missed |
283
|
0
|
0
|
|
|
|
0
|
= sort grep { !exists $reported{$_} && $_ ne 'Devel/TraceUse.pm' } |
284
|
|
|
|
|
|
|
keys %INC |
285
|
|
|
|
|
|
|
) |
286
|
|
|
|
|
|
|
{ |
287
|
0
|
0
|
|
|
|
0
|
$output->("Modules used, but not reported:") if @missed; |
288
|
0
|
|
|
|
|
0
|
$output->(" $_") for @missed; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
0
|
|
|
|
|
0
|
dump_proxies($output); |
292
|
|
|
|
|
|
|
|
293
|
0
|
0
|
|
|
|
0
|
close $output_fh if defined $output_fh; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
### HOOK INSTALLATION |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# If perl runs with -c we want to dump |
299
|
|
|
|
|
|
|
CHECK { |
300
|
|
|
|
|
|
|
# "perl -c" ? |
301
|
2
|
50
|
|
2
|
|
5561
|
dump_result() if $^C; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
3
|
|
|
3
|
|
3100458
|
END { dump_result() } |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
1; |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
__END__ |