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         $top = UNKNOWN unless $top;
 285     }
 286 }
 287
 288 sub pp_method {
 289     my $op = shift;
 290     $top = ["(method)", "->".$top->[1], $top->[2]];
 291 }
 292
 293 sub pp_entersub {
 294     my $op = shift;
 295     if ($top->[1] eq "m") {
 296         process($top, "meth");
 297     } else {
 298         process($top, "subused");
 299     }
 300     $top = UNKNOWN;
 301 }
 302
 303 #
 304 # Stuff for cross referencing definitions of variables and subs
 305 #
 306
 307 sub B::GV::xref {
 308     my $gv = shift;
 309     my $cv = $gv->CV;
 310     if ($$cv) {
 311         #return if $done{$$cv}++;
 312         $file = $gv->FILE;
 313         $line = $gv->LINE;
 314         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 315         push(@todo, $cv);
 316     }
 317     my $form = $gv->FORM;
 318     if ($$form) {
 319         return if $done{$$form}++;
 320         $file = $gv->FILE;
 321         $line = $gv->LINE;
 322         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 323     }
 324 }
 325
 326 sub xref_definitions {
 327     my ($pack, %exclude);
 328     return if $nodefs;
 329     $subname = "(definitions)";
 330     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 331                       strict vars FileHandle Exporter Carp)) {
 332         $exclude{$pack."::"} = 1;
 333     }
 334     no strict qw(vars refs);
 335     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 336 }
 337
 338 sub output {
 339     return if $raw;
 340     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 341         $perpack, $pername, $perev);
 342     foreach $file (sort(keys(%table))) {
 343         $perfile = $table{$file};
 344         print "File $file\n";
 345         foreach $subname (sort(keys(%$perfile))) {
 346             $persubname = $perfile->{$subname};
 347             print "  Subroutine $subname\n";
 348             foreach $pack (sort(keys(%$persubname))) {
 349                 $perpack = $persubname->{$pack};
 350                 print "    Package $pack\n";
 351                 foreach $name (sort(keys(%$perpack))) {
 352                     $pername = $perpack->{$name};
 353                     my @lines;
 354                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 355                         $perev = $pername->{$ev};
 356                         if (defined($perev) && @$perev) {
 357                             my $code = $code{$ev};
 358                             push(@lines, map("$code$_", @$perev));
 359                         }
 360                     }
 361                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 362                 }
 363             }
 364         }
 365     }
 366 }
 367
 368 sub compile {
 369     my @options = @_;
 370     my ($option, $opt, $arg);
 371   OPTION:
 372     while ($option = shift @options) {
 373         if ($option =~ /^-(.)(.*)/) {
 374             $opt = $1;
 375             $arg = $2;
 376         } else {
 377             unshift @options, $option;
 378             last OPTION;
 379         }
 380         if ($opt eq "-" && $arg eq "-") {
 381             shift @options;
 382             last OPTION;
 383         } elsif ($opt eq "o") {
 384             $arg ||= shift @options;
 385             open(STDOUT, ">$arg") or return "$arg: $!\n";
 386         } elsif ($opt eq "d") {
 387             $nodefs = 1;
 388         } elsif ($opt eq "r") {
 389             $raw = 1;
 390         } elsif ($opt eq "D") {
 391             $arg ||= shift @options;
 392             foreach $arg (split(//, $arg)) {
 393                 if ($arg eq "o") {
 394                     B->debug(1);
 395                 } elsif ($arg eq "O") {
 396                     $debug_op = 1;
 397                 } elsif ($arg eq "t") {
 398                     $debug_top = 1;
 399                 }
 400             }
 401         }
 402     }
 403     if (@options) {
 404         return sub {
 405             my $objname;
 406             xref_definitions();
 407             foreach $objname (@options) {
 408                 $objname = "main::$objname" unless $objname =~ /::/;
 409                 eval "xref_object(\\&$objname)";
 410                 die "xref_object(\\&$objname) failed: $@" if $@;
 411             }
 412             output();
 413         }
 414     } else {
 415         return sub {
 416             xref_definitions();
 417             xref_main();
 418             output();
 419         }
 420     }
 421 }
 422
 423 1;