ext/B/B/Xref.pm

   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;
  88 use Config;
  89 use B qw(peekop class comppadlist main_start svref_2object walksymtable
  90          OPpLVAL_INTRO SVf_POK
  91         );
  92
  93 sub UNKNOWN { ["?", "?", "?"] }
  94
  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
 105
 106 my %code = (intro => "i", used => "",
 107             subdef => "s", subused => "&",
 108             formdef => "f", meth => "->");
 109
 110
 111 # Options
 112 my ($debug_op, $debug_top, $nodefs, $raw);
 113
 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 = "&";
 122         }
 123     }
 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);
 132     }
 133 }
 134
 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];
 147     }
 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];
 157         }
 158     }
 159 }
 160
 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);
 187         }
 188     }
 189 }
 190
 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)";
 198 }
 199
 200 sub xref_object {
 201     my $cvref = shift;
 202     xref_cv(svref_2object($cvref));
 203 }
 204
 205 sub xref_main {
 206     $subname = "(main)";
 207     load_pad(comppadlist);
 208     xref(main_start);
 209     while (@todo) {
 210         xref_cv(shift @todo);
 211     }
 212 }
 213
 214 sub pp_nextstate {
 215     my $op = shift;
 216     $file = $op->file;
 217     $line = $op->line;
 218     $top = UNKNOWN;
 219 }
 220
 221 sub pp_padsv {
 222     my $op = shift;
 223     $top = $pad[$op->targ];
 224     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 225 }
 226
 227 sub pp_padav { pp_padsv(@_) }
 228 sub pp_padhv { pp_padsv(@_) }
 229
 230 sub deref {
 231     my ($var, $as) = @_;
 232     $var->[1] = $as . $var->[1];
 233     process($var, "used");
 234 }
 235
 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, "*"); }
 241
 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] = '$';
 249     }
 250     else {
 251         $gv = $op->gv;
 252         $top = [$gv->STASH->NAME, '$', $gv->NAME];
 253     }
 254     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 255 }
 256
 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] = '*';
 264     }
 265     else {
 266         $gv = $op->gv;
 267         $top = [$gv->STASH->NAME, "*", $gv->NAME];
 268     }
 269     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 270 }
 271
 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 : "?"];
 279     }
 280     else {
 281         $top = $pad[$op->targ];
 282     }
 283 }
 284
 285 sub pp_method {
 286     my $op = shift;
 287     $top = ["(method)", "->".$top->[1], $top->[2]];
 288 }
 289
 290 sub pp_entersub {
 291     my $op = shift;
 292     if ($top->[1] eq "m") {
 293         process($top, "meth");
 294     } else {
 295         process($top, "subused");
 296     }
 297     $top = UNKNOWN;
 298 }
 299
 300 #
 301 # Stuff for cross referencing definitions of variables and subs
 302 #
 303
 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);
 313     }
 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");
 320     }
 321 }
 322
 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;
 330     }
 331     no strict qw(vars refs);
 332     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 333 }
 334
 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));
 356                         }
 357                     }
 358                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 359                 }
 360             }
 361         }
 362     }
 363 }
 364
 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;
 376         }
 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;
 396                 }
 397             }
 398         }
 399     }
 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 $@;
 408             }
 409             output();
 410         }
 411     } else {
 412         return sub {
 413             xref_definitions();
 414             xref_main();
 415             output();
 416         }
 417     }
 418 }
 419
 420 1;