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 B qw(peekop class comppadlist main_start svref_2object walksymtable
  89          OPpLVAL_INTRO SVf_POK
  90         );
  91
  92 sub UNKNOWN { ["?", "?", "?"] }
  93
  94 my @pad;                        # lexicals in current pad
  95                                 # as ["(lexical)", type, name]
  96 my %done;                       # keyed by $$op: set when each $op is done
  97 my $top = UNKNOWN;              # shadows top element of stack as
  98                                 # [pack, type, name] (pack can be "(lexical)")
  99 my $file;                       # shadows current filename
 100 my $line;                       # shadows current line number
 101 my $subname;                    # shadows current sub name
 102 my %table;                      # Multi-level hash to record all uses etc.
 103 my @todo = ();                  # List of CVs that need processing
 104
 105 my %code = (intro => "i", used => "",
 106             subdef => "s", subused => "&",
 107             formdef => "f", meth => "->");
 108
 109
 110 # Options
 111 my ($debug_op, $debug_top, $nodefs, $raw);
 112
 113 sub process {
 114     my ($var, $event) = @_;
 115     my ($pack, $type, $name) = @$var;
 116     if ($type eq "*") {
 117         if ($event eq "used") {
 118             return;
 119         } elsif ($event eq "subused") {
 120             $type = "&";
 121         }
 122     }
 123     $type =~ s/(.)\*$/$1/g;
 124     if ($raw) {
 125         printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
 126             $file, $subname, $line, $pack, $type, $name, $event;
 127     } else {
 128         # Wheee
 129         push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
 130             $line);
 131     }
 132 }
 133
 134 sub load_pad {
 135     my $padlist = shift;
 136     my ($namelistav, @namelist, $ix);
 137     @pad = ();
 138     return if class($padlist) eq "SPECIAL";
 139     ($namelistav) = $padlist->ARRAY;
 140     @namelist = $namelistav->ARRAY;
 141     for ($ix = 1; $ix < @namelist; $ix++) {
 142         my $namesv = $namelist[$ix];
 143         next if class($namesv) eq "SPECIAL";
 144         my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
 145         $pad[$ix] = ["(lexical)", $type, $name];
 146     }
 147 }
 148
 149 sub xref {
 150     my $start = shift;
 151     my $op;
 152     for ($op = $start; $$op; $op = $op->next) {
 153         last if $done{$$op}++;
 154         warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
 155         warn peekop($op), "\n" if $debug_op;
 156         my $ppname = $op->ppaddr;
 157         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) {
 158             xref($op->other);
 159         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
 160             xref($op->pmreplstart);
 161         } elsif ($ppname eq "pp_substcont") {
 162             xref($op->other->pmreplstart);
 163             $op = $op->other;
 164             redo;
 165         } elsif ($ppname eq "pp_cond_expr") {
 166             # pp_cond_expr never returns op_next
 167             xref($op->true);
 168             $op = $op->false;
 169             redo;
 170         } elsif ($ppname eq "pp_enterloop") {
 171             xref($op->redoop);
 172             xref($op->nextop);
 173             xref($op->lastop);
 174         } elsif ($ppname eq "pp_subst") {
 175             xref($op->pmreplstart);
 176         } else {
 177             no strict 'refs';
 178             &$ppname($op) if defined(&$ppname);
 179         }
 180     }
 181 }
 182
 183 sub xref_cv {
 184     my $cv = shift;
 185     my $pack = $cv->GV->STASH->NAME;
 186     $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
 187     load_pad($cv->PADLIST);
 188     xref($cv->START);
 189     $subname = "(main)";
 190 }
 191
 192 sub xref_object {
 193     my $cvref = shift;
 194     xref_cv(svref_2object($cvref));
 195 }
 196
 197 sub xref_main {
 198     $subname = "(main)";
 199     load_pad(comppadlist);
 200     xref(main_start);
 201     while (@todo) {
 202         xref_cv(shift @todo);
 203     }
 204 }
 205
 206 sub pp_nextstate {
 207     my $op = shift;
 208     $file = $op->filegv->SV->PV;
 209     $line = $op->line;
 210     $top = UNKNOWN;
 211 }
 212
 213 sub pp_padsv {
 214     my $op = shift;
 215     $top = $pad[$op->targ];
 216     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 217 }
 218
 219 sub pp_padav { pp_padsv(@_) }
 220 sub pp_padhv { pp_padsv(@_) }
 221
 222 sub deref {
 223     my ($var, $as) = @_;
 224     $var->[1] = $as . $var->[1];
 225     process($var, "used");
 226 }
 227
 228 sub pp_rv2cv { deref($top, "&"); }
 229 sub pp_rv2hv { deref($top, "%"); }
 230 sub pp_rv2sv { deref($top, "\$"); }
 231 sub pp_rv2av { deref($top, "\@"); }
 232 sub pp_rv2gv { deref($top, "*"); }
 233
 234 sub pp_gvsv {
 235     my $op = shift;
 236     my $gv = $op->gv;
 237     $top = [$gv->STASH->NAME, '$', $gv->NAME];
 238     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 239 }
 240
 241 sub pp_gv {
 242     my $op = shift;
 243     my $gv = $op->gv;
 244     $top = [$gv->STASH->NAME, "*", $gv->NAME];
 245     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 246 }
 247
 248 sub pp_const {
 249     my $op = shift;
 250     my $sv = $op->sv;
 251     $top = ["?", "",
 252             (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
 253 }
 254
 255 sub pp_method {
 256     my $op = shift;
 257     $top = ["(method)", "->".$top->[1], $top->[2]];
 258 }
 259
 260 sub pp_entersub {
 261     my $op = shift;
 262     if ($top->[1] eq "m") {
 263         process($top, "meth");
 264     } else {
 265         process($top, "subused");
 266     }
 267     $top = UNKNOWN;
 268 }
 269
 270 #
 271 # Stuff for cross referencing definitions of variables and subs
 272 #
 273
 274 sub B::GV::xref {
 275     my $gv = shift;
 276     my $cv = $gv->CV;
 277     if ($$cv) {
 278         #return if $done{$$cv}++;
 279         $file = $gv->FILEGV->SV->PV;
 280         $line = $gv->LINE;
 281         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 282         push(@todo, $cv);
 283     }
 284     my $form = $gv->FORM;
 285     if ($$form) {
 286         return if $done{$$form}++;
 287         $file = $gv->FILEGV->SV->PV;
 288         $line = $gv->LINE;
 289         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 290     }
 291 }
 292
 293 sub xref_definitions {
 294     my ($pack, %exclude);
 295     return if $nodefs;
 296     $subname = "(definitions)";
 297     foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
 298                       strict vars FileHandle Exporter Carp)) {
 299         $exclude{$pack."::"} = 1;
 300     }
 301     no strict qw(vars refs);
 302     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 303 }
 304
 305 sub output {
 306     return if $raw;
 307     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 308         $perpack, $pername, $perev);
 309     foreach $file (sort(keys(%table))) {
 310         $perfile = $table{$file};
 311         print "File $file\n";
 312         foreach $subname (sort(keys(%$perfile))) {
 313             $persubname = $perfile->{$subname};
 314             print "  Subroutine $subname\n";
 315             foreach $pack (sort(keys(%$persubname))) {
 316                 $perpack = $persubname->{$pack};
 317                 print "    Package $pack\n";
 318                 foreach $name (sort(keys(%$perpack))) {
 319                     $pername = $perpack->{$name};
 320                     my @lines;
 321                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 322                         $perev = $pername->{$ev};
 323                         if (defined($perev) && @$perev) {
 324                             my $code = $code{$ev};
 325                             push(@lines, map("$code$_", @$perev));
 326                         }
 327                     }
 328                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 329                 }
 330             }
 331         }
 332     }
 333 }
 334
 335 sub compile {
 336     my @options = @_;
 337     my ($option, $opt, $arg);
 338   OPTION:
 339     while ($option = shift @options) {
 340         if ($option =~ /^-(.)(.*)/) {
 341             $opt = $1;
 342             $arg = $2;
 343         } else {
 344             unshift @options, $option;
 345             last OPTION;
 346         }
 347         if ($opt eq "-" && $arg eq "-") {
 348             shift @options;
 349             last OPTION;
 350         } elsif ($opt eq "o") {
 351             $arg ||= shift @options;
 352             open(STDOUT, ">$arg") or return "$arg: $!\n";
 353         } elsif ($opt eq "d") {
 354             $nodefs = 1;
 355         } elsif ($opt eq "r") {
 356             $raw = 1;
 357         } elsif ($opt eq "D") {
 358             $arg ||= shift @options;
 359             foreach $arg (split(//, $arg)) {
 360                 if ($arg eq "o") {
 361                     B->debug(1);
 362                 } elsif ($arg eq "O") {
 363                     $debug_op = 1;
 364                 } elsif ($arg eq "t") {
 365                     $debug_top = 1;
 366                 }
 367             }
 368         }
 369     }
 370     if (@options) {
 371         return sub {
 372             my $objname;
 373             xref_definitions();
 374             foreach $objname (@options) {
 375                 $objname = "main::$objname" unless $objname =~ /::/;
 376                 eval "xref_object(\\&$objname)";
 377                 die "xref_object(\\&$objname) failed: $@" if $@;
 378             }
 379             output();
 380         }
 381     } else {
 382         return sub {
 383             xref_definitions();
 384             xref_main();
 385             output();
 386         }
 387     }
 388 }
 389
 390 1;