File Coverage

blib/lib/Devel/TraceUse.pm
Criterion Covered Total %
statement 43 119 36.1
branch 14 76 18.4
condition 3 10 30.0
subroutine 8 16 50.0
pod 0 7 0.0
total 68 228 29.8


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__