ext/B/B/Xref.pm

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