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