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