ext/B/B/Xref.pm

   1 package B::Xref;
   2
   3 our $VERSION = '1.01';
   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        line numbers
  25           object2        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>
  68
  69 Don't output the "(definitions)" sections.
  70
  71 =item C<-D[tO]>
  72
  73 (Internal) debug options, probably only useful if C<-r> included.
  74 The C<t> option prints the object on the top of the stack as it's
  75 being tracked. The C<O> option prints each operator as it's being
  76 processed in the execution order of the program.
  77
  78 =back
  79
  80 =head1 BUGS
  81
  82 Non-lexical variables are quite difficult to track through a program.
  83 Sometimes the type of a non-lexical variable's use is impossible to
  84 determine. Introductions of non-lexical non-scalars don't seem to be
  85 reported properly.
  86
  87 =head1 AUTHOR
  88
  89 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
  90
  91 =cut
  92
  93 use strict;
  94 use Config;
  95 use B qw(peekop class comppadlist main_start svref_2object walksymtable
  96          OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
  97         );
  98
  99 sub UNKNOWN { ["?", "?", "?"] }
 100
 101 my @pad;                        # lexicals in current pad
 102                                 # as ["(lexical)", type, name]
 103 my %done;                       # keyed by $$op: set when each $op is done
 104 my $top = UNKNOWN;              # shadows top element of stack as
 105                                 # [pack, type, name] (pack can be "(lexical)")
 106 my $file;                       # shadows current filename
 107 my $line;                       # shadows current line number
 108 my $subname;                    # shadows current sub name
 109 my %table;                      # Multi-level hash to record all uses etc.
 110 my @todo = ();                  # List of CVs that need processing
 111
 112 my %code = (intro => "i", used => "",
 113             subdef => "s", subused => "&",
 114             formdef => "f", meth => "->");
 115
 116
 117 # Options
 118 my ($debug_op, $debug_top, $nodefs, $raw);
 119
 120 sub process {
 121     my ($var, $event) = @_;
 122     my ($pack, $type, $name) = @$var;
 123     if ($type eq "*") {
 124         if ($event eq "used") {
 125             return;
 126         } elsif ($event eq "subused") {
 127             $type = "&";
 128         }
 129     }
 130     $type =~ s/(.)\*$/$1/g;
 131     if ($raw) {
 132         printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
 133             $file, $subname, $line, $pack, $type, $name, $event;
 134     } else {
 135         # Wheee
 136         push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
 137             $line);
 138     }
 139 }
 140
 141 sub load_pad {
 142     my $padlist = shift;
 143     my ($namelistav, $vallistav, @namelist, $ix);
 144     @pad = ();
 145     return if class($padlist) eq "SPECIAL";
 146     ($namelistav,$vallistav) = $padlist->ARRAY;
 147     @namelist = $namelistav->ARRAY;
 148     for ($ix = 1; $ix < @namelist; $ix++) {
 149         my $namesv = $namelist[$ix];
 150         next if class($namesv) eq "SPECIAL";
 151         my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 152         $pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
 153     }
 154     if ($Config{useithreads}) {
 155         my (@vallist);
 156         @vallist = $vallistav->ARRAY;
 157         for ($ix = 1; $ix < @vallist; $ix++) {
 158             my $valsv = $vallist[$ix];
 159             next unless class($valsv) eq "GV";
 160             # these pad GVs don't have corresponding names, so same @pad
 161             # array can be used without collisions
 162             $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
 163         }
 164     }
 165 }
 166
 167 sub xref {
 168     my $start = shift;
 169     my $op;
 170     for ($op = $start; $$op; $op = $op->next) {
 171         last if $done{$$op}++;
 172         warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
 173         warn peekop($op), "\n" if $debug_op;
 174         my $opname = $op->name;
 175         if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 176             xref($op->other);
 177         } elsif ($opname eq "match" || $opname eq "subst") {
 178             xref($op->pmreplstart);
 179         } elsif ($opname eq "substcont") {
 180             xref($op->other->pmreplstart);
 181             $op = $op->other;
 182             redo;
 183         } elsif ($opname eq "enterloop") {
 184             xref($op->redoop);
 185             xref($op->nextop);
 186             xref($op->lastop);
 187         } elsif ($opname eq "subst") {
 188             xref($op->pmreplstart);
 189         } else {
 190             no strict 'refs';
 191             my $ppname = "pp_$opname";
 192             &$ppname($op) if defined(&$ppname);
 193         }
 194     }
 195 }
 196
 197 sub xref_cv {
 198     my $cv = shift;
 199     my $pack = $cv->GV->STASH->NAME;
 200     $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
 201     load_pad($cv->PADLIST);
 202     xref($cv->START);
 203     $subname = "(main)";
 204 }
 205
 206 sub xref_object {
 207     my $cvref = shift;
 208     xref_cv(svref_2object($cvref));
 209 }
 210
 211 sub xref_main {
 212     $subname = "(main)";
 213     load_pad(comppadlist);
 214     xref(main_start);
 215     while (@todo) {
 216         xref_cv(shift @todo);
 217     }
 218 }
 219
 220 sub pp_nextstate {
 221     my $op = shift;
 222     $file = $op->file;
 223     $line = $op->line;
 224     $top = UNKNOWN;
 225 }
 226
 227 sub pp_padsv {
 228     my $op = shift;
 229     $top = $pad[$op->targ];
 230     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 231 }
 232
 233 sub pp_padav { pp_padsv(@_) }
 234 sub pp_padhv { pp_padsv(@_) }
 235
 236 sub deref {
 237     my ($op, $var, $as) = @_;
 238     $var->[1] = $as . $var->[1];
 239     process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
 240 }
 241
 242 sub pp_rv2cv { deref(shift, $top, "&"); }
 243 sub pp_rv2hv { deref(shift, $top, "%"); }
 244 sub pp_rv2sv { deref(shift, $top, "\$"); }
 245 sub pp_rv2av { deref(shift, $top, "\@"); }
 246 sub pp_rv2gv { deref(shift, $top, "*"); }
 247
 248 sub pp_gvsv {
 249     my $op = shift;
 250     my $gv;
 251     if ($Config{useithreads}) {
 252         $top = $pad[$op->padix];
 253         $top = UNKNOWN unless $top;
 254         $top->[1] = '$';
 255     }
 256     else {
 257         $gv = $op->gv;
 258         $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
 259     }
 260     process($top, $op->private & OPpLVAL_INTRO ||
 261                   $op->private & OPpOUR_INTRO   ? "intro" : "used");
 262 }
 263
 264 sub pp_gv {
 265     my $op = shift;
 266     my $gv;
 267     if ($Config{useithreads}) {
 268         $top = $pad[$op->padix];
 269         $top = UNKNOWN unless $top;
 270         $top->[1] = '*';
 271     }
 272     else {
 273         $gv = $op->gv;
 274         $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
 275     }
 276     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 277 }
 278
 279 sub pp_const {
 280     my $op = shift;
 281     my $sv = $op->sv;
 282     # constant could be in the pad (under useithreads)
 283     if ($$sv) {
 284         $top = ["?", "",
 285                 (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
 286                 ? cstring($sv->PV) : "?"];
 287     }
 288     else {
 289         $top = $pad[$op->targ];
 290         $top = UNKNOWN unless $top;
 291     }
 292 }
 293
 294 sub pp_method {
 295     my $op = shift;
 296     $top = ["(method)", "->".$top->[1], $top->[2]];
 297 }
 298
 299 sub pp_entersub {
 300     my $op = shift;
 301     if ($top->[1] eq "m") {
 302         process($top, "meth");
 303     } else {
 304         process($top, "subused");
 305     }
 306     $top = UNKNOWN;
 307 }
 308
 309 #
 310 # Stuff for cross referencing definitions of variables and subs
 311 #
 312
 313 sub B::GV::xref {
 314     my $gv = shift;
 315     my $cv = $gv->CV;
 316     if ($$cv) {
 317         #return if $done{$$cv}++;
 318         $file = $gv->FILE;
 319         $line = $gv->LINE;
 320         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 321         push(@todo, $cv);
 322     }
 323     my $form = $gv->FORM;
 324     if ($$form) {
 325         return if $done{$$form}++;
 326         $file = $gv->FILE;
 327         $line = $gv->LINE;
 328         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 329     }
 330 }
 331
 332 sub xref_definitions {
 333     my ($pack, %exclude);
 334     return if $nodefs;
 335     $subname = "(definitions)";
 336     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 337                       strict vars FileHandle Exporter Carp PerlIO::Layer
 338                       attributes utf8 warnings)) {
 339         $exclude{$pack."::"} = 1;
 340     }
 341     no strict qw(vars refs);
 342     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 343 }
 344
 345 sub output {
 346     return if $raw;
 347     my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
 348         $perpack, $pername, $perev);
 349     foreach $file (sort(keys(%table))) {
 350         $perfile = $table{$file};
 351         print "File $file\n";
 352         foreach $subname (sort(keys(%$perfile))) {
 353             $persubname = $perfile->{$subname};
 354             print "  Subroutine $subname\n";
 355             foreach $pack (sort(keys(%$persubname))) {
 356                 $perpack = $persubname->{$pack};
 357                 print "    Package $pack\n";
 358                 foreach $name (sort(keys(%$perpack))) {
 359                     $pername = $perpack->{$name};
 360                     my @lines;
 361                     foreach $ev (qw(intro formdef subdef meth subused used)) {
 362                         $perev = $pername->{$ev};
 363                         if (defined($perev) && @$perev) {
 364                             my $code = $code{$ev};
 365                             push(@lines, map("$code$_", @$perev));
 366                         }
 367                     }
 368                     printf "      %-16s  %s\n", $name, join(", ", @lines);
 369                 }
 370             }
 371         }
 372     }
 373 }
 374
 375 sub compile {
 376     my @options = @_;
 377     my ($option, $opt, $arg);
 378   OPTION:
 379     while ($option = shift @options) {
 380         if ($option =~ /^-(.)(.*)/) {
 381             $opt = $1;
 382             $arg = $2;
 383         } else {
 384             unshift @options, $option;
 385             last OPTION;
 386         }
 387         if ($opt eq "-" && $arg eq "-") {
 388             shift @options;
 389             last OPTION;
 390         } elsif ($opt eq "o") {
 391             $arg ||= shift @options;
 392             open(STDOUT, ">$arg") or return "$arg: $!\n";
 393         } elsif ($opt eq "d") {
 394             $nodefs = 1;
 395         } elsif ($opt eq "r") {
 396             $raw = 1;
 397         } elsif ($opt eq "D") {
 398             $arg ||= shift @options;
 399             foreach $arg (split(//, $arg)) {
 400                 if ($arg eq "o") {
 401                     B->debug(1);
 402                 } elsif ($arg eq "O") {
 403                     $debug_op = 1;
 404                 } elsif ($arg eq "t") {
 405                     $debug_top = 1;
 406                 }
 407             }
 408         }
 409     }
 410     if (@options) {
 411         return sub {
 412             my $objname;
 413             xref_definitions();
 414             foreach $objname (@options) {
 415                 $objname = "main::$objname" unless $objname =~ /::/;
 416                 eval "xref_object(\\&$objname)";
 417                 die "xref_object(\\&$objname) failed: $@" if $@;
 418             }
 419             output();
 420         }
 421     } else {
 422         return sub {
 423             xref_definitions();
 424             xref_main();
 425             output();
 426         }
 427     }
 428 }
 429
 430 1;