| Commit | Line | Data |
|---|
| a798dbf2 |
1 | package B::Xref; |
| 2 | |
| 28b605d8 |
3 | our $VERSION = '1.00'; |
| 4 | |
| a798dbf2 |
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 C<line numbers> |
| 25 | object2 C<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[tO]> |
| 68 | |
| 69 | (Internal) debug options, probably only useful if C<-r> included. |
| 70 | The C<t> option prints the object on the top of the stack as it's |
| 71 | being tracked. The C<O> option prints each operator as it's being |
| 72 | processed in the execution order of the program. |
| 73 | |
| 74 | =back |
| 75 | |
| 76 | =head1 BUGS |
| 77 | |
| 78 | Non-lexical variables are quite difficult to track through a program. |
| 79 | Sometimes the type of a non-lexical variable's use is impossible to |
| 80 | determine. Introductions of non-lexical non-scalars don't seem to be |
| 81 | reported properly. |
| 82 | |
| 83 | =head1 AUTHOR |
| 84 | |
| 85 | Malcolm Beattie, mbeattie@sable.ox.ac.uk. |
| 86 | |
| 87 | =cut |
| 88 | |
| 89 | use strict; |
| 18228111 |
90 | use Config; |
| 4c1f658f |
91 | use B qw(peekop class comppadlist main_start svref_2object walksymtable |
| 8e011b7d |
92 | OPpLVAL_INTRO SVf_POK OPpOUR_INTRO |
| 4c1f658f |
93 | ); |
| a798dbf2 |
94 | |
| 95 | sub UNKNOWN { ["?", "?", "?"] } |
| 96 | |
| 97 | my @pad; # lexicals in current pad |
| 98 | # as ["(lexical)", type, name] |
| 99 | my %done; # keyed by $$op: set when each $op is done |
| 100 | my $top = UNKNOWN; # shadows top element of stack as |
| 101 | # [pack, type, name] (pack can be "(lexical)") |
| 102 | my $file; # shadows current filename |
| 103 | my $line; # shadows current line number |
| 104 | my $subname; # shadows current sub name |
| 105 | my %table; # Multi-level hash to record all uses etc. |
| 106 | my @todo = (); # List of CVs that need processing |
| 107 | |
| 108 | my %code = (intro => "i", used => "", |
| 109 | subdef => "s", subused => "&", |
| 110 | formdef => "f", meth => "->"); |
| 111 | |
| 112 | |
| 113 | # Options |
| 114 | my ($debug_op, $debug_top, $nodefs, $raw); |
| 115 | |
| 116 | sub process { |
| 117 | my ($var, $event) = @_; |
| 118 | my ($pack, $type, $name) = @$var; |
| 119 | if ($type eq "*") { |
| 120 | if ($event eq "used") { |
| 121 | return; |
| 122 | } elsif ($event eq "subused") { |
| 123 | $type = "&"; |
| 124 | } |
| 125 | } |
| 126 | $type =~ s/(.)\*$/$1/g; |
| 127 | if ($raw) { |
| 128 | printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", |
| 129 | $file, $subname, $line, $pack, $type, $name, $event; |
| 130 | } else { |
| 131 | # Wheee |
| 132 | push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, |
| 133 | $line); |
| 134 | } |
| 135 | } |
| 136 | |
| 137 | sub load_pad { |
| 138 | my $padlist = shift; |
| 18228111 |
139 | my ($namelistav, $vallistav, @namelist, $ix); |
| a798dbf2 |
140 | @pad = (); |
| 141 | return if class($padlist) eq "SPECIAL"; |
| 18228111 |
142 | ($namelistav,$vallistav) = $padlist->ARRAY; |
| a798dbf2 |
143 | @namelist = $namelistav->ARRAY; |
| 144 | for ($ix = 1; $ix < @namelist; $ix++) { |
| 145 | my $namesv = $namelist[$ix]; |
| 146 | next if class($namesv) eq "SPECIAL"; |
| 51e5a3db |
147 | my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; |
| a798dbf2 |
148 | $pad[$ix] = ["(lexical)", $type, $name]; |
| 149 | } |
| 18228111 |
150 | if ($Config{useithreads}) { |
| 151 | my (@vallist); |
| 152 | @vallist = $vallistav->ARRAY; |
| 153 | for ($ix = 1; $ix < @vallist; $ix++) { |
| 154 | my $valsv = $vallist[$ix]; |
| 155 | next unless class($valsv) eq "GV"; |
| 156 | # these pad GVs don't have corresponding names, so same @pad |
| 157 | # array can be used without collisions |
| 158 | $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; |
| 159 | } |
| 160 | } |
| a798dbf2 |
161 | } |
| 162 | |
| 163 | sub xref { |
| 164 | my $start = shift; |
| 165 | my $op; |
| 166 | for ($op = $start; $$op; $op = $op->next) { |
| 167 | last if $done{$$op}++; |
| 168 | warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; |
| 169 | warn peekop($op), "\n" if $debug_op; |
| 3f872cb9 |
170 | my $opname = $op->name; |
| 171 | if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { |
| a798dbf2 |
172 | xref($op->other); |
| 3f872cb9 |
173 | } elsif ($opname eq "match" || $opname eq "subst") { |
| a798dbf2 |
174 | xref($op->pmreplstart); |
| 3f872cb9 |
175 | } elsif ($opname eq "substcont") { |
| a798dbf2 |
176 | xref($op->other->pmreplstart); |
| 177 | $op = $op->other; |
| 178 | redo; |
| 3f872cb9 |
179 | } elsif ($opname eq "enterloop") { |
| a798dbf2 |
180 | xref($op->redoop); |
| 181 | xref($op->nextop); |
| 182 | xref($op->lastop); |
| 3f872cb9 |
183 | } elsif ($opname eq "subst") { |
| a798dbf2 |
184 | xref($op->pmreplstart); |
| 185 | } else { |
| 186 | no strict 'refs'; |
| 3f872cb9 |
187 | my $ppname = "pp_$opname"; |
| a798dbf2 |
188 | &$ppname($op) if defined(&$ppname); |
| 189 | } |
| 190 | } |
| 191 | } |
| 192 | |
| 193 | sub xref_cv { |
| 194 | my $cv = shift; |
| 195 | my $pack = $cv->GV->STASH->NAME; |
| 196 | $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; |
| 197 | load_pad($cv->PADLIST); |
| 198 | xref($cv->START); |
| 199 | $subname = "(main)"; |
| 200 | } |
| 201 | |
| 202 | sub xref_object { |
| 203 | my $cvref = shift; |
| 204 | xref_cv(svref_2object($cvref)); |
| 205 | } |
| 206 | |
| 207 | sub xref_main { |
| 208 | $subname = "(main)"; |
| 209 | load_pad(comppadlist); |
| 210 | xref(main_start); |
| 211 | while (@todo) { |
| 212 | xref_cv(shift @todo); |
| 213 | } |
| 214 | } |
| 215 | |
| 216 | sub pp_nextstate { |
| 217 | my $op = shift; |
| 57843af0 |
218 | $file = $op->file; |
| a798dbf2 |
219 | $line = $op->line; |
| 220 | $top = UNKNOWN; |
| 221 | } |
| 222 | |
| 223 | sub pp_padsv { |
| 224 | my $op = shift; |
| 225 | $top = $pad[$op->targ]; |
| 226 | process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); |
| 227 | } |
| 228 | |
| 229 | sub pp_padav { pp_padsv(@_) } |
| 230 | sub pp_padhv { pp_padsv(@_) } |
| 231 | |
| 232 | sub deref { |
| 8e011b7d |
233 | my ($op, $var, $as) = @_; |
| a798dbf2 |
234 | $var->[1] = $as . $var->[1]; |
| 8e011b7d |
235 | process($var, $op->private & OPpOUR_INTRO ? "intro" : "used"); |
| a798dbf2 |
236 | } |
| 237 | |
| 8e011b7d |
238 | sub pp_rv2cv { deref(shift, $top, "&"); } |
| 239 | sub pp_rv2hv { deref(shift, $top, "%"); } |
| 240 | sub pp_rv2sv { deref(shift, $top, "\$"); } |
| 241 | sub pp_rv2av { deref(shift, $top, "\@"); } |
| 242 | sub pp_rv2gv { deref(shift, $top, "*"); } |
| a798dbf2 |
243 | |
| 244 | sub pp_gvsv { |
| 245 | my $op = shift; |
| 18228111 |
246 | my $gv; |
| 247 | if ($Config{useithreads}) { |
| 248 | $top = $pad[$op->padix]; |
| 249 | $top = UNKNOWN unless $top; |
| 250 | $top->[1] = '$'; |
| 251 | } |
| 252 | else { |
| 253 | $gv = $op->gv; |
| 254 | $top = [$gv->STASH->NAME, '$', $gv->NAME]; |
| 255 | } |
| 8e011b7d |
256 | process($top, $op->private & OPpLVAL_INTRO || |
| 257 | $op->private & OPpOUR_INTRO ? "intro" : "used"); |
| a798dbf2 |
258 | } |
| 259 | |
| 260 | sub pp_gv { |
| 261 | my $op = shift; |
| 18228111 |
262 | my $gv; |
| 263 | if ($Config{useithreads}) { |
| 264 | $top = $pad[$op->padix]; |
| 265 | $top = UNKNOWN unless $top; |
| 266 | $top->[1] = '*'; |
| 267 | } |
| 268 | else { |
| 269 | $gv = $op->gv; |
| 270 | $top = [$gv->STASH->NAME, "*", $gv->NAME]; |
| 271 | } |
| a798dbf2 |
272 | process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); |
| 273 | } |
| 274 | |
| 275 | sub pp_const { |
| 276 | my $op = shift; |
| 277 | my $sv = $op->sv; |
| 18228111 |
278 | # constant could be in the pad (under useithreads) |
| 279 | if ($$sv) { |
| 280 | $top = ["?", "", |
| 281 | (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; |
| 282 | } |
| 283 | else { |
| 284 | $top = $pad[$op->targ]; |
| fdf1c2a9 |
285 | $top = UNKNOWN unless $top; |
| 18228111 |
286 | } |
| a798dbf2 |
287 | } |
| 288 | |
| 289 | sub pp_method { |
| 290 | my $op = shift; |
| 291 | $top = ["(method)", "->".$top->[1], $top->[2]]; |
| 292 | } |
| 293 | |
| 294 | sub pp_entersub { |
| 295 | my $op = shift; |
| 296 | if ($top->[1] eq "m") { |
| 297 | process($top, "meth"); |
| 298 | } else { |
| 299 | process($top, "subused"); |
| 300 | } |
| 301 | $top = UNKNOWN; |
| 302 | } |
| 303 | |
| 304 | # |
| 305 | # Stuff for cross referencing definitions of variables and subs |
| 306 | # |
| 307 | |
| 308 | sub B::GV::xref { |
| 309 | my $gv = shift; |
| 310 | my $cv = $gv->CV; |
| 311 | if ($$cv) { |
| 312 | #return if $done{$$cv}++; |
| b195d487 |
313 | $file = $gv->FILE; |
| a798dbf2 |
314 | $line = $gv->LINE; |
| 315 | process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); |
| 316 | push(@todo, $cv); |
| 317 | } |
| 318 | my $form = $gv->FORM; |
| 319 | if ($$form) { |
| 320 | return if $done{$$form}++; |
| b195d487 |
321 | $file = $gv->FILE; |
| a798dbf2 |
322 | $line = $gv->LINE; |
| 323 | process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); |
| 324 | } |
| 325 | } |
| 326 | |
| 327 | sub xref_definitions { |
| 328 | my ($pack, %exclude); |
| 329 | return if $nodefs; |
| 330 | $subname = "(definitions)"; |
| 595f3c5f |
331 | foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS |
| a798dbf2 |
332 | strict vars FileHandle Exporter Carp)) { |
| 333 | $exclude{$pack."::"} = 1; |
| 334 | } |
| 335 | no strict qw(vars refs); |
| 336 | walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); |
| 337 | } |
| 338 | |
| 339 | sub output { |
| 340 | return if $raw; |
| 341 | my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, |
| 342 | $perpack, $pername, $perev); |
| 343 | foreach $file (sort(keys(%table))) { |
| 344 | $perfile = $table{$file}; |
| 345 | print "File $file\n"; |
| 346 | foreach $subname (sort(keys(%$perfile))) { |
| 347 | $persubname = $perfile->{$subname}; |
| 348 | print " Subroutine $subname\n"; |
| 349 | foreach $pack (sort(keys(%$persubname))) { |
| 350 | $perpack = $persubname->{$pack}; |
| 351 | print " Package $pack\n"; |
| 352 | foreach $name (sort(keys(%$perpack))) { |
| 353 | $pername = $perpack->{$name}; |
| 354 | my @lines; |
| 355 | foreach $ev (qw(intro formdef subdef meth subused used)) { |
| 356 | $perev = $pername->{$ev}; |
| 357 | if (defined($perev) && @$perev) { |
| 358 | my $code = $code{$ev}; |
| 359 | push(@lines, map("$code$_", @$perev)); |
| 360 | } |
| 361 | } |
| 362 | printf " %-16s %s\n", $name, join(", ", @lines); |
| 363 | } |
| 364 | } |
| 365 | } |
| 366 | } |
| 367 | } |
| 368 | |
| 369 | sub compile { |
| 370 | my @options = @_; |
| 371 | my ($option, $opt, $arg); |
| 372 | OPTION: |
| 373 | while ($option = shift @options) { |
| 374 | if ($option =~ /^-(.)(.*)/) { |
| 375 | $opt = $1; |
| 376 | $arg = $2; |
| 377 | } else { |
| 378 | unshift @options, $option; |
| 379 | last OPTION; |
| 380 | } |
| 381 | if ($opt eq "-" && $arg eq "-") { |
| 382 | shift @options; |
| 383 | last OPTION; |
| 384 | } elsif ($opt eq "o") { |
| 385 | $arg ||= shift @options; |
| 386 | open(STDOUT, ">$arg") or return "$arg: $!\n"; |
| 387 | } elsif ($opt eq "d") { |
| 388 | $nodefs = 1; |
| 389 | } elsif ($opt eq "r") { |
| 390 | $raw = 1; |
| 391 | } elsif ($opt eq "D") { |
| 392 | $arg ||= shift @options; |
| 393 | foreach $arg (split(//, $arg)) { |
| 394 | if ($arg eq "o") { |
| 395 | B->debug(1); |
| 396 | } elsif ($arg eq "O") { |
| 397 | $debug_op = 1; |
| 398 | } elsif ($arg eq "t") { |
| 399 | $debug_top = 1; |
| 400 | } |
| 401 | } |
| 402 | } |
| 403 | } |
| 404 | if (@options) { |
| 405 | return sub { |
| 406 | my $objname; |
| 407 | xref_definitions(); |
| 408 | foreach $objname (@options) { |
| 409 | $objname = "main::$objname" unless $objname =~ /::/; |
| 410 | eval "xref_object(\\&$objname)"; |
| 411 | die "xref_object(\\&$objname) failed: $@" if $@; |
| 412 | } |
| 413 | output(); |
| 414 | } |
| 415 | } else { |
| 416 | return sub { |
| 417 | xref_definitions(); |
| 418 | xref_main(); |
| 419 | output(); |
| 420 | } |
| 421 | } |
| 422 | } |
| 423 | |
| 424 | 1; |
projects / p5sagit/p5-mst-13.2.git / blame