Initial bulk commit for "Git on MSys"
[msysgit/historical-msysgit.git] / lib / perl5 / 5.6.1 / msys / B / Xref.pm
blobb4078b8bd39a07dddd6df35095a266850555953b
1 package B::Xref;
3 =head1 NAME
5 B::Xref - Generates cross reference reports for Perl programs
7 =head1 SYNOPSIS
9 perl -MO=Xref[,OPTIONS] foo.pl
11 =head1 DESCRIPTION
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.
17 The report generated is in the following format:
19 File filename1
20 Subroutine subname1
21 Package package1
22 object1 C<line numbers>
23 object2 C<line numbers>
24 ...
25 Package package2
26 ...
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.
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.
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".
49 =head1 OPTIONS
51 Option words are separated by commas (not whitespace) and follow the
52 usual conventions of compiler backend options.
54 =over 8
56 =item C<-oFILENAME>
58 Directs output to C<FILENAME> instead of standard output.
60 =item C<-r>
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.
65 =item C<-D[tO]>
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.
72 =back
74 =head1 BUGS
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.
81 =head1 AUTHOR
83 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
85 =cut
87 use strict;
88 use Config;
89 use B qw(peekop class comppadlist main_start svref_2object walksymtable
90 OPpLVAL_INTRO SVf_POK
93 sub UNKNOWN { ["?", "?", "?"] }
95 my @pad; # lexicals in current pad
96 # as ["(lexical)", type, name]
97 my %done; # keyed by $$op: set when each $op is done
98 my $top = UNKNOWN; # shadows top element of stack as
99 # [pack, type, name] (pack can be "(lexical)")
100 my $file; # shadows current filename
101 my $line; # shadows current line number
102 my $subname; # shadows current sub name
103 my %table; # Multi-level hash to record all uses etc.
104 my @todo = (); # List of CVs that need processing
106 my %code = (intro => "i", used => "",
107 subdef => "s", subused => "&",
108 formdef => "f", meth => "->");
111 # Options
112 my ($debug_op, $debug_top, $nodefs, $raw);
114 sub process {
115 my ($var, $event) = @_;
116 my ($pack, $type, $name) = @$var;
117 if ($type eq "*") {
118 if ($event eq "used") {
119 return;
120 } elsif ($event eq "subused") {
121 $type = "&";
124 $type =~ s/(.)\*$/$1/g;
125 if ($raw) {
126 printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
127 $file, $subname, $line, $pack, $type, $name, $event;
128 } else {
129 # Wheee
130 push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
131 $line);
135 sub load_pad {
136 my $padlist = shift;
137 my ($namelistav, $vallistav, @namelist, $ix);
138 @pad = ();
139 return if class($padlist) eq "SPECIAL";
140 ($namelistav,$vallistav) = $padlist->ARRAY;
141 @namelist = $namelistav->ARRAY;
142 for ($ix = 1; $ix < @namelist; $ix++) {
143 my $namesv = $namelist[$ix];
144 next if class($namesv) eq "SPECIAL";
145 my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
146 $pad[$ix] = ["(lexical)", $type, $name];
148 if ($Config{useithreads}) {
149 my (@vallist);
150 @vallist = $vallistav->ARRAY;
151 for ($ix = 1; $ix < @vallist; $ix++) {
152 my $valsv = $vallist[$ix];
153 next unless class($valsv) eq "GV";
154 # these pad GVs don't have corresponding names, so same @pad
155 # array can be used without collisions
156 $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
161 sub xref {
162 my $start = shift;
163 my $op;
164 for ($op = $start; $$op; $op = $op->next) {
165 last if $done{$$op}++;
166 warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
167 warn peekop($op), "\n" if $debug_op;
168 my $opname = $op->name;
169 if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
170 xref($op->other);
171 } elsif ($opname eq "match" || $opname eq "subst") {
172 xref($op->pmreplstart);
173 } elsif ($opname eq "substcont") {
174 xref($op->other->pmreplstart);
175 $op = $op->other;
176 redo;
177 } elsif ($opname eq "enterloop") {
178 xref($op->redoop);
179 xref($op->nextop);
180 xref($op->lastop);
181 } elsif ($opname eq "subst") {
182 xref($op->pmreplstart);
183 } else {
184 no strict 'refs';
185 my $ppname = "pp_$opname";
186 &$ppname($op) if defined(&$ppname);
191 sub xref_cv {
192 my $cv = shift;
193 my $pack = $cv->GV->STASH->NAME;
194 $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
195 load_pad($cv->PADLIST);
196 xref($cv->START);
197 $subname = "(main)";
200 sub xref_object {
201 my $cvref = shift;
202 xref_cv(svref_2object($cvref));
205 sub xref_main {
206 $subname = "(main)";
207 load_pad(comppadlist);
208 xref(main_start);
209 while (@todo) {
210 xref_cv(shift @todo);
214 sub pp_nextstate {
215 my $op = shift;
216 $file = $op->file;
217 $line = $op->line;
218 $top = UNKNOWN;
221 sub pp_padsv {
222 my $op = shift;
223 $top = $pad[$op->targ];
224 process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
227 sub pp_padav { pp_padsv(@_) }
228 sub pp_padhv { pp_padsv(@_) }
230 sub deref {
231 my ($var, $as) = @_;
232 $var->[1] = $as . $var->[1];
233 process($var, "used");
236 sub pp_rv2cv { deref($top, "&"); }
237 sub pp_rv2hv { deref($top, "%"); }
238 sub pp_rv2sv { deref($top, "\$"); }
239 sub pp_rv2av { deref($top, "\@"); }
240 sub pp_rv2gv { deref($top, "*"); }
242 sub pp_gvsv {
243 my $op = shift;
244 my $gv;
245 if ($Config{useithreads}) {
246 $top = $pad[$op->padix];
247 $top = UNKNOWN unless $top;
248 $top->[1] = '$';
250 else {
251 $gv = $op->gv;
252 $top = [$gv->STASH->NAME, '$', $gv->NAME];
254 process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
257 sub pp_gv {
258 my $op = shift;
259 my $gv;
260 if ($Config{useithreads}) {
261 $top = $pad[$op->padix];
262 $top = UNKNOWN unless $top;
263 $top->[1] = '*';
265 else {
266 $gv = $op->gv;
267 $top = [$gv->STASH->NAME, "*", $gv->NAME];
269 process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
272 sub pp_const {
273 my $op = shift;
274 my $sv = $op->sv;
275 # constant could be in the pad (under useithreads)
276 if ($$sv) {
277 $top = ["?", "",
278 (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
280 else {
281 $top = $pad[$op->targ];
285 sub pp_method {
286 my $op = shift;
287 $top = ["(method)", "->".$top->[1], $top->[2]];
290 sub pp_entersub {
291 my $op = shift;
292 if ($top->[1] eq "m") {
293 process($top, "meth");
294 } else {
295 process($top, "subused");
297 $top = UNKNOWN;
301 # Stuff for cross referencing definitions of variables and subs
304 sub B::GV::xref {
305 my $gv = shift;
306 my $cv = $gv->CV;
307 if ($$cv) {
308 #return if $done{$$cv}++;
309 $file = $gv->FILE;
310 $line = $gv->LINE;
311 process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
312 push(@todo, $cv);
314 my $form = $gv->FORM;
315 if ($$form) {
316 return if $done{$$form}++;
317 $file = $gv->FILE;
318 $line = $gv->LINE;
319 process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
323 sub xref_definitions {
324 my ($pack, %exclude);
325 return if $nodefs;
326 $subname = "(definitions)";
327 foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
328 strict vars FileHandle Exporter Carp)) {
329 $exclude{$pack."::"} = 1;
331 no strict qw(vars refs);
332 walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
335 sub output {
336 return if $raw;
337 my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
338 $perpack, $pername, $perev);
339 foreach $file (sort(keys(%table))) {
340 $perfile = $table{$file};
341 print "File $file\n";
342 foreach $subname (sort(keys(%$perfile))) {
343 $persubname = $perfile->{$subname};
344 print " Subroutine $subname\n";
345 foreach $pack (sort(keys(%$persubname))) {
346 $perpack = $persubname->{$pack};
347 print " Package $pack\n";
348 foreach $name (sort(keys(%$perpack))) {
349 $pername = $perpack->{$name};
350 my @lines;
351 foreach $ev (qw(intro formdef subdef meth subused used)) {
352 $perev = $pername->{$ev};
353 if (defined($perev) && @$perev) {
354 my $code = $code{$ev};
355 push(@lines, map("$code$_", @$perev));
358 printf " %-16s %s\n", $name, join(", ", @lines);
365 sub compile {
366 my @options = @_;
367 my ($option, $opt, $arg);
368 OPTION:
369 while ($option = shift @options) {
370 if ($option =~ /^-(.)(.*)/) {
371 $opt = $1;
372 $arg = $2;
373 } else {
374 unshift @options, $option;
375 last OPTION;
377 if ($opt eq "-" && $arg eq "-") {
378 shift @options;
379 last OPTION;
380 } elsif ($opt eq "o") {
381 $arg ||= shift @options;
382 open(STDOUT, ">$arg") or return "$arg: $!\n";
383 } elsif ($opt eq "d") {
384 $nodefs = 1;
385 } elsif ($opt eq "r") {
386 $raw = 1;
387 } elsif ($opt eq "D") {
388 $arg ||= shift @options;
389 foreach $arg (split(//, $arg)) {
390 if ($arg eq "o") {
391 B->debug(1);
392 } elsif ($arg eq "O") {
393 $debug_op = 1;
394 } elsif ($arg eq "t") {
395 $debug_top = 1;
400 if (@options) {
401 return sub {
402 my $objname;
403 xref_definitions();
404 foreach $objname (@options) {
405 $objname = "main::$objname" unless $objname =~ /::/;
406 eval "xref_object(\\&$objname)";
407 die "xref_object(\\&$objname) failed: $@" if $@;
409 output();
411 } else {
412 return sub {
413 xref_definitions();
414 xref_main();
415 output();