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 OPpOUR_INTRO
  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 ($op, $var, $as) = @_;
 234     $var->[1] = $as . $var->[1];
 235     process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
 236 }
 237
 238 sub pp_rv2cv { deref(shift, $top, "&"); }
 239 sub pp_rv2hv { deref(shift, $top, "%"); }
 240 sub pp_rv2sv { deref(shift, $top, "\$"); }
 241 sub pp_rv2av { deref(shift, $top, "\@"); }
 242 sub pp_rv2gv { deref(shift, $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->SAFENAME];
 255     }
 256     process($top, $op->private & OPpLVAL_INTRO ||
 257                   $op->private & OPpOUR_INTRO   ? "intro" : "used");
 258 }
 259
 260 sub pp_gv {
 261     my $op = shift;
 262     my $gv;
 263     if ($Config{useithreads}) {
 264         $top = $pad[$op->padix];
 265         $top = UNKNOWN unless $top;
 266         $top->[1] = '*';
 267     }
 268     else {
 269         $gv = $op->gv;
 270         $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
 271     }
 272     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 273 }
 274
 275 sub pp_const {
 276     my $op = shift;
 277     my $sv = $op->sv;
 278     # constant could be in the pad (under useithreads)
 279     if ($$sv) {
 280         $top = ["?", "",
 281                 (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
 282     }
 283     else {
 284         $top = $pad[$op->targ];
 285         $top = UNKNOWN unless $top;
 286     }
 287 }
 288
 289 sub pp_method {
 290     my $op = shift;
 291     $top = ["(method)", "->".$top->[1], $top->[2]];
 292 }
 293
 294 sub pp_entersub {
 295     my $op = shift;
 296     if ($top->[1] eq "m") {
 297         process($top, "meth");
 298     } else {
 299         process($top, "subused");
 300     }
 301     $top = UNKNOWN;
 302 }
 303
 304 #
 305 # Stuff for cross referencing definitions of variables and subs
 306 #
 307
 308 sub B::GV::xref {
 309     my $gv = shift;
 310     my $cv = $gv->CV;
 311     if ($$cv) {
 312         #return if $done{$$cv}++;
 313         $file = $gv->FILE;
 314         $line = $gv->LINE;
 315         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 316         push(@todo, $cv);
 317     }
 318     my $form = $gv->FORM;
 319     if ($$form) {
 320         return if $done{$$form}++;
 321         $file = $gv->FILE;
 322         $line = $gv->LINE;
 323         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 324     }
 325 }
 326
 327 sub xref_definitions {
 328     my ($pack, %exclude);
 329     return if $nodefs;
 330     $subname = "(definitions)";
 331     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 332                       strict vars FileHandle Exporter Carp PerlIO::Layer
 333                       attributes utf8 warnings)) {
 334         $exclude{$pack."::"} = 1;
 335     }
 336     no strict qw(vars refs);
 337     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 338 }
 339
 340 sub output {
 341     return if $raw;
 342     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 343         $perpack, $pername, $perev);
 344     foreach $file (sort(keys(%table))) {
 345         $perfile = $table{$file};
 346         print "File $file\n";
 347         foreach $subname (sort(keys(%$perfile))) {
 348             $persubname = $perfile->{$subname};
 349             print "  Subroutine $subname\n";
 350             foreach $pack (sort(keys(%$persubname))) {
 351                 $perpack = $persubname->{$pack};
 352                 print "    Package $pack\n";
 353                 foreach $name (sort(keys(%$perpack))) {
 354                     $pername = $perpack->{$name};
 355                     my @lines;
 356                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 357                         $perev = $pername->{$ev};
 358                         if (defined($perev) && @$perev) {
 359                             my $code = $code{$ev};
 360                             push(@lines, map("$code$_", @$perev));
 361                         }
 362                     }
 363                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 364                 }
 365             }
 366         }
 367     }
 368 }
 369
 370 sub compile {
 371     my @options = @_;
 372     my ($option, $opt, $arg);
 373   OPTION:
 374     while ($option = shift @options) {
 375         if ($option =~ /^-(.)(.*)/) {
 376             $opt = $1;
 377             $arg = $2;
 378         } else {
 379             unshift @options, $option;
 380             last OPTION;
 381         }
 382         if ($opt eq "-" && $arg eq "-") {
 383             shift @options;
 384             last OPTION;
 385         } elsif ($opt eq "o") {
 386             $arg ||= shift @options;
 387             open(STDOUT, ">$arg") or return "$arg: $!\n";
 388         } elsif ($opt eq "d") {
 389             $nodefs = 1;
 390         } elsif ($opt eq "r") {
 391             $raw = 1;
 392         } elsif ($opt eq "D") {
 393             $arg ||= shift @options;
 394             foreach $arg (split(//, $arg)) {
 395                 if ($arg eq "o") {
 396                     B->debug(1);
 397                 } elsif ($arg eq "O") {
 398                     $debug_op = 1;
 399                 } elsif ($arg eq "t") {
 400                     $debug_top = 1;
 401                 }
 402             }
 403         }
 404     }
 405     if (@options) {
 406         return sub {
 407             my $objname;
 408             xref_definitions();
 409             foreach $objname (@options) {
 410                 $objname = "main::$objname" unless $objname =~ /::/;
 411                 eval "xref_object(\\&$objname)";
 412                 die "xref_object(\\&$objname) failed: $@" if $@;
 413             }
 414             output();
 415         }
 416     } else {
 417         return sub {
 418             xref_definitions();
 419             xref_main();
 420             output();
 421         }
 422     }
 423 }
 424
 425 1;