ext/B/B/Xref.pm

   1 package B::Xref;
   2
   3 our $VERSION = '1.00';
   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        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;
  90 use Config;
  91 use B qw(peekop class comppadlist main_start svref_2object walksymtable
  92          OPpLVAL_INTRO SVf_POK
  93         );
  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;
 139     my ($namelistav, $vallistav, @namelist, $ix);
 140     @pad = ();
 141     return if class($padlist) eq "SPECIAL";
 142     ($namelistav,$vallistav) = $padlist->ARRAY;
 143     @namelist = $namelistav->ARRAY;
 144     for ($ix = 1; $ix < @namelist; $ix++) {
 145         my $namesv = $namelist[$ix];
 146         next if class($namesv) eq "SPECIAL";
 147         my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 148         $pad[$ix] = ["(lexical)", $type, $name];
 149     }
 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     }
 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;
 170         my $opname = $op->name;
 171         if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 172             xref($op->other);
 173         } elsif ($opname eq "match" || $opname eq "subst") {
 174             xref($op->pmreplstart);
 175         } elsif ($opname eq "substcont") {
 176             xref($op->other->pmreplstart);
 177             $op = $op->other;
 178             redo;
 179         } elsif ($opname eq "enterloop") {
 180             xref($op->redoop);
 181             xref($op->nextop);
 182             xref($op->lastop);
 183         } elsif ($opname eq "subst") {
 184             xref($op->pmreplstart);
 185         } else {
 186             no strict 'refs';
 187             my $ppname = "pp_$opname";
 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;
 218     $file = $op->file;
 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 {
 233     my ($var, $as) = @_;
 234     $var->[1] = $as . $var->[1];
 235     process($var, "used");
 236 }
 237
 238 sub pp_rv2cv { deref($top, "&"); }
 239 sub pp_rv2hv { deref($top, "%"); }
 240 sub pp_rv2sv { deref($top, "\$"); }
 241 sub pp_rv2av { deref($top, "\@"); }
 242 sub pp_rv2gv { deref($top, "*"); }
 243
 244 sub pp_gvsv {
 245     my $op = shift;
 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     }
 256     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 257 }
 258
 259 sub pp_gv {
 260     my $op = shift;
 261     my $gv;
 262     if ($Config{useithreads}) {
 263         $top = $pad[$op->padix];
 264         $top = UNKNOWN unless $top;
 265         $top->[1] = '*';
 266     }
 267     else {
 268         $gv = $op->gv;
 269         $top = [$gv->STASH->NAME, "*", $gv->NAME];
 270     }
 271     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 272 }
 273
 274 sub pp_const {
 275     my $op = shift;
 276     my $sv = $op->sv;
 277     # constant could be in the pad (under useithreads)
 278     if ($$sv) {
 279         $top = ["?", "",
 280                 (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
 281     }
 282     else {
 283         $top = $pad[$op->targ];
 284     }
 285 }
 286
 287 sub pp_method {
 288     my $op = shift;
 289     $top = ["(method)", "->".$top->[1], $top->[2]];
 290 }
 291
 292 sub pp_entersub {
 293     my $op = shift;
 294     if ($top->[1] eq "m") {
 295         process($top, "meth");
 296     } else {
 297         process($top, "subused");
 298     }
 299     $top = UNKNOWN;
 300 }
 301
 302 #
 303 # Stuff for cross referencing definitions of variables and subs
 304 #
 305
 306 sub B::GV::xref {
 307     my $gv = shift;
 308     my $cv = $gv->CV;
 309     if ($$cv) {
 310         #return if $done{$$cv}++;
 311         $file = $gv->FILE;
 312         $line = $gv->LINE;
 313         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 314         push(@todo, $cv);
 315     }
 316     my $form = $gv->FORM;
 317     if ($$form) {
 318         return if $done{$$form}++;
 319         $file = $gv->FILE;
 320         $line = $gv->LINE;
 321         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 322     }
 323 }
 324
 325 sub xref_definitions {
 326     my ($pack, %exclude);
 327     return if $nodefs;
 328     $subname = "(definitions)";
 329     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 330                       strict vars FileHandle Exporter Carp)) {
 331         $exclude{$pack."::"} = 1;
 332     }
 333     no strict qw(vars refs);
 334     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 335 }
 336
 337 sub output {
 338     return if $raw;
 339     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 340         $perpack, $pername, $perev);
 341     foreach $file (sort(keys(%table))) {
 342         $perfile = $table{$file};
 343         print "File $file\n";
 344         foreach $subname (sort(keys(%$perfile))) {
 345             $persubname = $perfile->{$subname};
 346             print "  Subroutine $subname\n";
 347             foreach $pack (sort(keys(%$persubname))) {
 348                 $perpack = $persubname->{$pack};
 349                 print "    Package $pack\n";
 350                 foreach $name (sort(keys(%$perpack))) {
 351                     $pername = $perpack->{$name};
 352                     my @lines;
 353                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 354                         $perev = $pername->{$ev};
 355                         if (defined($perev) && @$perev) {
 356                             my $code = $code{$ev};
 357                             push(@lines, map("$code$_", @$perev));
 358                         }
 359                     }
 360                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 361                 }
 362             }
 363         }
 364     }
 365 }
 366
 367 sub compile {
 368     my @options = @_;
 369     my ($option, $opt, $arg);
 370   OPTION:
 371     while ($option = shift @options) {
 372         if ($option =~ /^-(.)(.*)/) {
 373             $opt = $1;
 374             $arg = $2;
 375         } else {
 376             unshift @options, $option;
 377             last OPTION;
 378         }
 379         if ($opt eq "-" && $arg eq "-") {
 380             shift @options;
 381             last OPTION;
 382         } elsif ($opt eq "o") {
 383             $arg ||= shift @options;
 384             open(STDOUT, ">$arg") or return "$arg: $!\n";
 385         } elsif ($opt eq "d") {
 386             $nodefs = 1;
 387         } elsif ($opt eq "r") {
 388             $raw = 1;
 389         } elsif ($opt eq "D") {
 390             $arg ||= shift @options;
 391             foreach $arg (split(//, $arg)) {
 392                 if ($arg eq "o") {
 393                     B->debug(1);
 394                 } elsif ($arg eq "O") {
 395                     $debug_op = 1;
 396                 } elsif ($arg eq "t") {
 397                     $debug_top = 1;
 398                 }
 399             }
 400         }
 401     }
 402     if (@options) {
 403         return sub {
 404             my $objname;
 405             xref_definitions();
 406             foreach $objname (@options) {
 407                 $objname = "main::$objname" unless $objname =~ /::/;
 408                 eval "xref_object(\\&$objname)";
 409                 die "xref_object(\\&$objname) failed: $@" if $@;
 410             }
 411             output();
 412         }
 413     } else {
 414         return sub {
 415             xref_definitions();
 416             xref_main();
 417             output();
 418         }
 419     }
 420 }
 421
 422 1;