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