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 =~ /^(.)([^\0]*)(\0.*)?$/;
 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 $opname = $op->name;
 157         if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 158             xref($op->other);
 159         } elsif ($opname eq "match" || $opname eq "subst") {
 160             xref($op->pmreplstart);
 161         } elsif ($opname eq "substcont") {
 162             xref($op->other->pmreplstart);
 163             $op = $op->other;
 164             redo;
 165         } elsif ($opname eq "enterloop") {
 166             xref($op->redoop);
 167             xref($op->nextop);
 168             xref($op->lastop);
 169         } elsif ($opname eq "subst") {
 170             xref($op->pmreplstart);
 171         } else {
 172             no strict 'refs';
 173             my $ppname = "pp_$opname";
 174             &$ppname($op) if defined(&$ppname);
 175         }
 176     }
 177 }
 178
 179 sub xref_cv {
 180     my $cv = shift;
 181     my $pack = $cv->GV->STASH->NAME;
 182     $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
 183     load_pad($cv->PADLIST);
 184     xref($cv->START);
 185     $subname = "(main)";
 186 }
 187
 188 sub xref_object {
 189     my $cvref = shift;
 190     xref_cv(svref_2object($cvref));
 191 }
 192
 193 sub xref_main {
 194     $subname = "(main)";
 195     load_pad(comppadlist);
 196     xref(main_start);
 197     while (@todo) {
 198         xref_cv(shift @todo);
 199     }
 200 }
 201
 202 sub pp_nextstate {
 203     my $op = shift;
 204     $file = $op->file;
 205     $line = $op->line;
 206     $top = UNKNOWN;
 207 }
 208
 209 sub pp_padsv {
 210     my $op = shift;
 211     $top = $pad[$op->targ];
 212     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 213 }
 214
 215 sub pp_padav { pp_padsv(@_) }
 216 sub pp_padhv { pp_padsv(@_) }
 217
 218 sub deref {
 219     my ($var, $as) = @_;
 220     $var->[1] = $as . $var->[1];
 221     process($var, "used");
 222 }
 223
 224 sub pp_rv2cv { deref($top, "&"); }
 225 sub pp_rv2hv { deref($top, "%"); }
 226 sub pp_rv2sv { deref($top, "\$"); }
 227 sub pp_rv2av { deref($top, "\@"); }
 228 sub pp_rv2gv { deref($top, "*"); }
 229
 230 sub pp_gvsv {
 231     my $op = shift;
 232     my $gv = $op->gv;
 233     $top = [$gv->STASH->NAME, '$', $gv->NAME];
 234     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 235 }
 236
 237 sub pp_gv {
 238     my $op = shift;
 239     my $gv = $op->gv;
 240     $top = [$gv->STASH->NAME, "*", $gv->NAME];
 241     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 242 }
 243
 244 sub pp_const {
 245     my $op = shift;
 246     my $sv = $op->sv;
 247     $top = ["?", "",
 248             (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
 249 }
 250
 251 sub pp_method {
 252     my $op = shift;
 253     $top = ["(method)", "->".$top->[1], $top->[2]];
 254 }
 255
 256 sub pp_entersub {
 257     my $op = shift;
 258     if ($top->[1] eq "m") {
 259         process($top, "meth");
 260     } else {
 261         process($top, "subused");
 262     }
 263     $top = UNKNOWN;
 264 }
 265
 266 #
 267 # Stuff for cross referencing definitions of variables and subs
 268 #
 269
 270 sub B::GV::xref {
 271     my $gv = shift;
 272     my $cv = $gv->CV;
 273     if ($$cv) {
 274         #return if $done{$$cv}++;
 275         $file = $gv->FILE;
 276         $line = $gv->LINE;
 277         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 278         push(@todo, $cv);
 279     }
 280     my $form = $gv->FORM;
 281     if ($$form) {
 282         return if $done{$$form}++;
 283         $file = $gv->FILE;
 284         $line = $gv->LINE;
 285         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 286     }
 287 }
 288
 289 sub xref_definitions {
 290     my ($pack, %exclude);
 291     return if $nodefs;
 292     $subname = "(definitions)";
 293     foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
 294                       strict vars FileHandle Exporter Carp)) {
 295         $exclude{$pack."::"} = 1;
 296     }
 297     no strict qw(vars refs);
 298     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 299 }
 300
 301 sub output {
 302     return if $raw;
 303     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 304         $perpack, $pername, $perev);
 305     foreach $file (sort(keys(%table))) {
 306         $perfile = $table{$file};
 307         print "File $file\n";
 308         foreach $subname (sort(keys(%$perfile))) {
 309             $persubname = $perfile->{$subname};
 310             print "  Subroutine $subname\n";
 311             foreach $pack (sort(keys(%$persubname))) {
 312                 $perpack = $persubname->{$pack};
 313                 print "    Package $pack\n";
 314                 foreach $name (sort(keys(%$perpack))) {
 315                     $pername = $perpack->{$name};
 316                     my @lines;
 317                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 318                         $perev = $pername->{$ev};
 319                         if (defined($perev) && @$perev) {
 320                             my $code = $code{$ev};
 321                             push(@lines, map("$code$_", @$perev));
 322                         }
 323                     }
 324                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 325                 }
 326             }
 327         }
 328     }
 329 }
 330
 331 sub compile {
 332     my @options = @_;
 333     my ($option, $opt, $arg);
 334   OPTION:
 335     while ($option = shift @options) {
 336         if ($option =~ /^-(.)(.*)/) {
 337             $opt = $1;
 338             $arg = $2;
 339         } else {
 340             unshift @options, $option;
 341             last OPTION;
 342         }
 343         if ($opt eq "-" && $arg eq "-") {
 344             shift @options;
 345             last OPTION;
 346         } elsif ($opt eq "o") {
 347             $arg ||= shift @options;
 348             open(STDOUT, ">$arg") or return "$arg: $!\n";
 349         } elsif ($opt eq "d") {
 350             $nodefs = 1;
 351         } elsif ($opt eq "r") {
 352             $raw = 1;
 353         } elsif ($opt eq "D") {
 354             $arg ||= shift @options;
 355             foreach $arg (split(//, $arg)) {
 356                 if ($arg eq "o") {
 357                     B->debug(1);
 358                 } elsif ($arg eq "O") {
 359                     $debug_op = 1;
 360                 } elsif ($arg eq "t") {
 361                     $debug_top = 1;
 362                 }
 363             }
 364         }
 365     }
 366     if (@options) {
 367         return sub {
 368             my $objname;
 369             xref_definitions();
 370             foreach $objname (@options) {
 371                 $objname = "main::$objname" unless $objname =~ /::/;
 372                 eval "xref_object(\\&$objname)";
 373                 die "xref_object(\\&$objname) failed: $@" if $@;
 374             }
 375             output();
 376         }
 377     } else {
 378         return sub {
 379             xref_definitions();
 380             xref_main();
 381             output();
 382         }
 383     }
 384 }
 385
 386 1;