Commit | Line | Data |
a798dbf2 |
1 | package B::Xref; |
2 | |
3 | =head1 NAME |
4 | |
5 | B::Xref - Generates cross reference reports for Perl programs |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | perl -MO=Xref[,OPTIONS] foo.pl |
10 | |
11 | =head1 DESCRIPTION |
12 | |
13 | The B::Xref module is used to generate a cross reference listing of all |
14 | definitions and uses of variables, subroutines and formats in a Perl program. |
15 | It is implemented as a backend for the Perl compiler. |
16 | |
17 | The report generated is in the following format: |
18 | |
19 | File filename1 |
20 | Subroutine subname1 |
21 | Package package1 |
22 | object1 C<line numbers> |
23 | object2 C<line numbers> |
24 | ... |
25 | Package package2 |
26 | ... |
27 | |
28 | Each B<File> section reports on a single file. Each B<Subroutine> section |
29 | reports on a single subroutine apart from the special cases |
30 | "(definitions)" and "(main)". These report, respectively, on subroutine |
31 | definitions found by the initial symbol table walk and on the main part of |
32 | the program or module external to all subroutines. |
33 | |
34 | The report is then grouped by the B<Package> of each variable, |
35 | subroutine or format with the special case "(lexicals)" meaning |
36 | lexical variables. Each B<object> name (implicitly qualified by its |
37 | containing B<Package>) includes its type character(s) at the beginning |
38 | where possible. Lexical variables are easier to track and even |
39 | included dereferencing information where possible. |
40 | |
41 | The C<line numbers> are a comma separated list of line numbers (some |
42 | preceded by code letters) where that object is used in some way. |
43 | Simple uses aren't preceded by a code letter. Introductions (such as |
44 | where a lexical is first defined with C<my>) are indicated with the |
45 | letter "i". Subroutine and method calls are indicated by the character |
46 | "&". Subroutine definitions are indicated by "s" and format |
47 | definitions by "f". |
48 | |
49 | =head1 OPTIONS |
50 | |
51 | Option words are separated by commas (not whitespace) and follow the |
52 | usual conventions of compiler backend options. |
53 | |
54 | =over 8 |
55 | |
56 | =item C<-oFILENAME> |
57 | |
58 | Directs output to C<FILENAME> instead of standard output. |
59 | |
60 | =item C<-r> |
61 | |
62 | Raw output. Instead of producing a human-readable report, outputs a line |
63 | in machine-readable form for each definition/use of a variable/sub/format. |
64 | |
65 | =item C<-D[tO]> |
66 | |
67 | (Internal) debug options, probably only useful if C<-r> included. |
68 | The C<t> option prints the object on the top of the stack as it's |
69 | being tracked. The C<O> option prints each operator as it's being |
70 | processed in the execution order of the program. |
71 | |
72 | =back |
73 | |
74 | =head1 BUGS |
75 | |
76 | Non-lexical variables are quite difficult to track through a program. |
77 | Sometimes the type of a non-lexical variable's use is impossible to |
78 | determine. Introductions of non-lexical non-scalars don't seem to be |
79 | reported properly. |
80 | |
81 | =head1 AUTHOR |
82 | |
83 | Malcolm Beattie, mbeattie@sable.ox.ac.uk. |
84 | |
85 | =cut |
86 | |
87 | use strict; |
4c1f658f |
88 | use B qw(peekop class comppadlist main_start svref_2object walksymtable |
89 | OPpLVAL_INTRO SVf_POK |
90 | ); |
a798dbf2 |
91 | |
92 | sub UNKNOWN { ["?", "?", "?"] } |
93 | |
94 | my @pad; # lexicals in current pad |
95 | # as ["(lexical)", type, name] |
96 | my %done; # keyed by $$op: set when each $op is done |
97 | my $top = UNKNOWN; # shadows top element of stack as |
98 | # [pack, type, name] (pack can be "(lexical)") |
99 | my $file; # shadows current filename |
100 | my $line; # shadows current line number |
101 | my $subname; # shadows current sub name |
102 | my %table; # Multi-level hash to record all uses etc. |
103 | my @todo = (); # List of CVs that need processing |
104 | |
105 | my %code = (intro => "i", used => "", |
106 | subdef => "s", subused => "&", |
107 | formdef => "f", meth => "->"); |
108 | |
109 | |
110 | # Options |
111 | my ($debug_op, $debug_top, $nodefs, $raw); |
112 | |
113 | sub process { |
114 | my ($var, $event) = @_; |
115 | my ($pack, $type, $name) = @$var; |
116 | if ($type eq "*") { |
117 | if ($event eq "used") { |
118 | return; |
119 | } elsif ($event eq "subused") { |
120 | $type = "&"; |
121 | } |
122 | } |
123 | $type =~ s/(.)\*$/$1/g; |
124 | if ($raw) { |
125 | printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", |
126 | $file, $subname, $line, $pack, $type, $name, $event; |
127 | } else { |
128 | # Wheee |
129 | push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, |
130 | $line); |
131 | } |
132 | } |
133 | |
134 | sub load_pad { |
135 | my $padlist = shift; |
136 | my ($namelistav, @namelist, $ix); |
137 | @pad = (); |
138 | return if class($padlist) eq "SPECIAL"; |
139 | ($namelistav) = $padlist->ARRAY; |
140 | @namelist = $namelistav->ARRAY; |
141 | for ($ix = 1; $ix < @namelist; $ix++) { |
142 | my $namesv = $namelist[$ix]; |
143 | next if class($namesv) eq "SPECIAL"; |
144 | my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; |
145 | $pad[$ix] = ["(lexical)", $type, $name]; |
146 | } |
147 | } |
148 | |
149 | sub xref { |
150 | my $start = shift; |
151 | my $op; |
152 | for ($op = $start; $$op; $op = $op->next) { |
153 | last if $done{$$op}++; |
154 | warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; |
155 | warn peekop($op), "\n" if $debug_op; |
156 | my $ppname = $op->ppaddr; |
157 | if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { |
158 | xref($op->other); |
159 | } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { |
160 | xref($op->pmreplstart); |
161 | } elsif ($ppname eq "pp_substcont") { |
162 | xref($op->other->pmreplstart); |
163 | $op = $op->other; |
164 | redo; |
165 | } elsif ($ppname eq "pp_cond_expr") { |
166 | # pp_cond_expr never returns op_next |
167 | xref($op->true); |
168 | $op = $op->false; |
169 | redo; |
170 | } elsif ($ppname eq "pp_enterloop") { |
171 | xref($op->redoop); |
172 | xref($op->nextop); |
173 | xref($op->lastop); |
174 | } elsif ($ppname eq "pp_subst") { |
175 | xref($op->pmreplstart); |
176 | } else { |
177 | no strict 'refs'; |
178 | &$ppname($op) if defined(&$ppname); |
179 | } |
180 | } |
181 | } |
182 | |
183 | sub xref_cv { |
184 | my $cv = shift; |
185 | my $pack = $cv->GV->STASH->NAME; |
186 | $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; |
187 | load_pad($cv->PADLIST); |
188 | xref($cv->START); |
189 | $subname = "(main)"; |
190 | } |
191 | |
192 | sub xref_object { |
193 | my $cvref = shift; |
194 | xref_cv(svref_2object($cvref)); |
195 | } |
196 | |
197 | sub xref_main { |
198 | $subname = "(main)"; |
199 | load_pad(comppadlist); |
200 | xref(main_start); |
201 | while (@todo) { |
202 | xref_cv(shift @todo); |
203 | } |
204 | } |
205 | |
206 | sub pp_nextstate { |
207 | my $op = shift; |
208 | $file = $op->filegv->SV->PV; |
209 | $line = $op->line; |
210 | $top = UNKNOWN; |
211 | } |
212 | |
213 | sub pp_padsv { |
214 | my $op = shift; |
215 | $top = $pad[$op->targ]; |
216 | process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); |
217 | } |
218 | |
219 | sub pp_padav { pp_padsv(@_) } |
220 | sub pp_padhv { pp_padsv(@_) } |
221 | |
222 | sub deref { |
223 | my ($var, $as) = @_; |
224 | $var->[1] = $as . $var->[1]; |
225 | process($var, "used"); |
226 | } |
227 | |
228 | sub pp_rv2cv { deref($top, "&"); } |
229 | sub pp_rv2hv { deref($top, "%"); } |
230 | sub pp_rv2sv { deref($top, "\$"); } |
231 | sub pp_rv2av { deref($top, "\@"); } |
232 | sub pp_rv2gv { deref($top, "*"); } |
233 | |
234 | sub pp_gvsv { |
235 | my $op = shift; |
236 | my $gv = $op->gv; |
237 | $top = [$gv->STASH->NAME, '$', $gv->NAME]; |
238 | process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); |
239 | } |
240 | |
241 | sub pp_gv { |
242 | my $op = shift; |
243 | my $gv = $op->gv; |
244 | $top = [$gv->STASH->NAME, "*", $gv->NAME]; |
245 | process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); |
246 | } |
247 | |
248 | sub pp_const { |
249 | my $op = shift; |
250 | my $sv = $op->sv; |
251 | $top = ["?", "", |
252 | (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; |
253 | } |
254 | |
255 | sub pp_method { |
256 | my $op = shift; |
257 | $top = ["(method)", "->".$top->[1], $top->[2]]; |
258 | } |
259 | |
260 | sub pp_entersub { |
261 | my $op = shift; |
262 | if ($top->[1] eq "m") { |
263 | process($top, "meth"); |
264 | } else { |
265 | process($top, "subused"); |
266 | } |
267 | $top = UNKNOWN; |
268 | } |
269 | |
270 | # |
271 | # Stuff for cross referencing definitions of variables and subs |
272 | # |
273 | |
274 | sub B::GV::xref { |
275 | my $gv = shift; |
276 | my $cv = $gv->CV; |
277 | if ($$cv) { |
278 | #return if $done{$$cv}++; |
279 | $file = $gv->FILEGV->SV->PV; |
280 | $line = $gv->LINE; |
281 | process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); |
282 | push(@todo, $cv); |
283 | } |
284 | my $form = $gv->FORM; |
285 | if ($$form) { |
286 | return if $done{$$form}++; |
287 | $file = $gv->FILEGV->SV->PV; |
288 | $line = $gv->LINE; |
289 | process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); |
290 | } |
291 | } |
292 | |
293 | sub xref_definitions { |
294 | my ($pack, %exclude); |
295 | return if $nodefs; |
296 | $subname = "(definitions)"; |
297 | foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS |
298 | strict vars FileHandle Exporter Carp)) { |
299 | $exclude{$pack."::"} = 1; |
300 | } |
301 | no strict qw(vars refs); |
302 | walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); |
303 | } |
304 | |
305 | sub output { |
306 | return if $raw; |
307 | my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, |
308 | $perpack, $pername, $perev); |
309 | foreach $file (sort(keys(%table))) { |
310 | $perfile = $table{$file}; |
311 | print "File $file\n"; |
312 | foreach $subname (sort(keys(%$perfile))) { |
313 | $persubname = $perfile->{$subname}; |
314 | print " Subroutine $subname\n"; |
315 | foreach $pack (sort(keys(%$persubname))) { |
316 | $perpack = $persubname->{$pack}; |
317 | print " Package $pack\n"; |
318 | foreach $name (sort(keys(%$perpack))) { |
319 | $pername = $perpack->{$name}; |
320 | my @lines; |
321 | foreach $ev (qw(intro formdef subdef meth subused used)) { |
322 | $perev = $pername->{$ev}; |
323 | if (defined($perev) && @$perev) { |
324 | my $code = $code{$ev}; |
325 | push(@lines, map("$code$_", @$perev)); |
326 | } |
327 | } |
328 | printf " %-16s %s\n", $name, join(", ", @lines); |
329 | } |
330 | } |
331 | } |
332 | } |
333 | } |
334 | |
335 | sub compile { |
336 | my @options = @_; |
337 | my ($option, $opt, $arg); |
338 | OPTION: |
339 | while ($option = shift @options) { |
340 | if ($option =~ /^-(.)(.*)/) { |
341 | $opt = $1; |
342 | $arg = $2; |
343 | } else { |
344 | unshift @options, $option; |
345 | last OPTION; |
346 | } |
347 | if ($opt eq "-" && $arg eq "-") { |
348 | shift @options; |
349 | last OPTION; |
350 | } elsif ($opt eq "o") { |
351 | $arg ||= shift @options; |
352 | open(STDOUT, ">$arg") or return "$arg: $!\n"; |
353 | } elsif ($opt eq "d") { |
354 | $nodefs = 1; |
355 | } elsif ($opt eq "r") { |
356 | $raw = 1; |
357 | } elsif ($opt eq "D") { |
358 | $arg ||= shift @options; |
359 | foreach $arg (split(//, $arg)) { |
360 | if ($arg eq "o") { |
361 | B->debug(1); |
362 | } elsif ($arg eq "O") { |
363 | $debug_op = 1; |
364 | } elsif ($arg eq "t") { |
365 | $debug_top = 1; |
366 | } |
367 | } |
368 | } |
369 | } |
370 | if (@options) { |
371 | return sub { |
372 | my $objname; |
373 | xref_definitions(); |
374 | foreach $objname (@options) { |
375 | $objname = "main::$objname" unless $objname =~ /::/; |
376 | eval "xref_object(\\&$objname)"; |
377 | die "xref_object(\\&$objname) failed: $@" if $@; |
378 | } |
379 | output(); |
380 | } |
381 | } else { |
382 | return sub { |
383 | xref_definitions(); |
384 | xref_main(); |
385 | output(); |
386 | } |
387 | } |
388 | } |
389 | |
390 | 1; |