| 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; |
