Initial Commit
This commit is contained in:
Riley Schneider
496
database/perl/lib/B/Xref.pm
Normal file
496
database/perl/lib/B/Xref.pm
Normal file
@@ -0,0 +1,496 @@
|
||||
package B::Xref;
|
||||
|
||||
our $VERSION = '1.07';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Xref - Generates cross reference reports for Perl programs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MO=Xref[,OPTIONS] foo.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B::Xref module is used to generate a cross reference listing of all
|
||||
definitions and uses of variables, subroutines and formats in a Perl program.
|
||||
It is implemented as a backend for the Perl compiler.
|
||||
|
||||
The report generated is in the following format:
|
||||
|
||||
File filename1
|
||||
Subroutine subname1
|
||||
Package package1
|
||||
object1 line numbers
|
||||
object2 line numbers
|
||||
...
|
||||
Package package2
|
||||
...
|
||||
|
||||
Each B<File> section reports on a single file. Each B<Subroutine> section
|
||||
reports on a single subroutine apart from the special cases
|
||||
"(definitions)" and "(main)". These report, respectively, on subroutine
|
||||
definitions found by the initial symbol table walk and on the main part of
|
||||
the program or module external to all subroutines.
|
||||
|
||||
The report is then grouped by the B<Package> of each variable,
|
||||
subroutine or format with the special case "(lexicals)" meaning
|
||||
lexical variables. Each B<object> name (implicitly qualified by its
|
||||
containing B<Package>) includes its type character(s) at the beginning
|
||||
where possible. Lexical variables are easier to track and even
|
||||
included dereferencing information where possible.
|
||||
|
||||
The C<line numbers> are a comma separated list of line numbers (some
|
||||
preceded by code letters) where that object is used in some way.
|
||||
Simple uses aren't preceded by a code letter. Introductions (such as
|
||||
where a lexical is first defined with C<my>) are indicated with the
|
||||
letter "i". Subroutine and method calls are indicated by the character
|
||||
"&". Subroutine definitions are indicated by "s" and format
|
||||
definitions by "f".
|
||||
|
||||
For instance, here's part of the report from the I<pod2man> program that
|
||||
comes with Perl:
|
||||
|
||||
Subroutine clear_noremap
|
||||
Package (lexical)
|
||||
$ready_to_print i1069, 1079
|
||||
Package main
|
||||
$& 1086
|
||||
$. 1086
|
||||
$0 1086
|
||||
$1 1087
|
||||
$2 1085, 1085
|
||||
$3 1085, 1085
|
||||
$ARGV 1086
|
||||
%HTML_Escapes 1085, 1085
|
||||
|
||||
This shows the variables used in the subroutine C<clear_noremap>. The
|
||||
variable C<$ready_to_print> is a my() (lexical) variable,
|
||||
B<i>ntroduced (first declared with my()) on line 1069, and used on
|
||||
line 1079. The variable C<$&> from the main package is used on 1086,
|
||||
and so on.
|
||||
|
||||
A line number may be prefixed by a single letter:
|
||||
|
||||
=over 4
|
||||
|
||||
=item i
|
||||
|
||||
Lexical variable introduced (declared with my()) for the first time.
|
||||
|
||||
=item &
|
||||
|
||||
Subroutine or method call.
|
||||
|
||||
=item s
|
||||
|
||||
Subroutine defined.
|
||||
|
||||
=item r
|
||||
|
||||
Format defined.
|
||||
|
||||
=back
|
||||
|
||||
The most useful option the cross referencer has is to save the report
|
||||
to a separate file. For instance, to save the report on
|
||||
I<myperlprogram> to the file I<report>:
|
||||
|
||||
$ perl -MO=Xref,-oreport myperlprogram
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Option words are separated by commas (not whitespace) and follow the
|
||||
usual conventions of compiler backend options.
|
||||
|
||||
=over 8
|
||||
|
||||
=item C<-oFILENAME>
|
||||
|
||||
Directs output to C<FILENAME> instead of standard output.
|
||||
|
||||
=item C<-r>
|
||||
|
||||
Raw output. Instead of producing a human-readable report, outputs a line
|
||||
in machine-readable form for each definition/use of a variable/sub/format.
|
||||
|
||||
=item C<-d>
|
||||
|
||||
Don't output the "(definitions)" sections.
|
||||
|
||||
=item C<-D[tO]>
|
||||
|
||||
(Internal) debug options, probably only useful if C<-r> included.
|
||||
The C<t> option prints the object on the top of the stack as it's
|
||||
being tracked. The C<O> option prints each operator as it's being
|
||||
processed in the execution order of the program.
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Non-lexical variables are quite difficult to track through a program.
|
||||
Sometimes the type of a non-lexical variable's use is impossible to
|
||||
determine. Introductions of non-lexical non-scalars don't seem to be
|
||||
reported properly.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Malcolm Beattie, mbeattie@sable.ox.ac.uk.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Config;
|
||||
use B qw(peekop class comppadlist main_start svref_2object walksymtable
|
||||
OPpLVAL_INTRO SVf_POK SVf_ROK OPpOUR_INTRO cstring
|
||||
);
|
||||
|
||||
sub UNKNOWN { ["?", "?", "?"] }
|
||||
|
||||
my @pad; # lexicals in current pad
|
||||
# as ["(lexical)", type, name]
|
||||
my %done; # keyed by $$op: set when each $op is done
|
||||
my $top = UNKNOWN; # shadows top element of stack as
|
||||
# [pack, type, name] (pack can be "(lexical)")
|
||||
my $file; # shadows current filename
|
||||
my $line; # shadows current line number
|
||||
my $subname; # shadows current sub name
|
||||
my %table; # Multi-level hash to record all uses etc.
|
||||
my @todo = (); # List of CVs that need processing
|
||||
|
||||
my %code = (intro => "i", used => "",
|
||||
subdef => "s", subused => "&",
|
||||
formdef => "f", meth => "->");
|
||||
|
||||
|
||||
# Options
|
||||
my ($debug_op, $debug_top, $nodefs, $raw);
|
||||
|
||||
sub process {
|
||||
my ($var, $event) = @_;
|
||||
my ($pack, $type, $name) = @$var;
|
||||
if ($type eq "*") {
|
||||
if ($event eq "used") {
|
||||
return;
|
||||
} elsif ($event eq "subused") {
|
||||
$type = "&";
|
||||
}
|
||||
}
|
||||
$type =~ s/(.)\*$/$1/g;
|
||||
if ($raw) {
|
||||
printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
|
||||
$file, $subname, $line, $pack, $type, $name, $event;
|
||||
} else {
|
||||
# Wheee
|
||||
push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
|
||||
$line);
|
||||
}
|
||||
}
|
||||
|
||||
sub load_pad {
|
||||
my $padlist = shift;
|
||||
my ($namelistav, $vallistav, @namelist, $ix);
|
||||
@pad = ();
|
||||
return if class($padlist) =~ '^(?:SPECIAL|NULL)\z';
|
||||
($namelistav,$vallistav) = $padlist->ARRAY;
|
||||
@namelist = $namelistav->ARRAY;
|
||||
for ($ix = 1; $ix < @namelist; $ix++) {
|
||||
my $namesv = $namelist[$ix];
|
||||
next if class($namesv) eq "SPECIAL";
|
||||
my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
|
||||
$pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
|
||||
}
|
||||
if ($Config{useithreads}) {
|
||||
my (@vallist);
|
||||
@vallist = $vallistav->ARRAY;
|
||||
for ($ix = 1; $ix < @vallist; $ix++) {
|
||||
my $valsv = $vallist[$ix];
|
||||
next unless class($valsv) eq "GV";
|
||||
next if class($valsv->STASH) eq 'SPECIAL';
|
||||
# these pad GVs don't have corresponding names, so same @pad
|
||||
# array can be used without collisions
|
||||
$pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub xref {
|
||||
my $start = shift;
|
||||
my $op;
|
||||
for ($op = $start; $$op; $op = $op->next) {
|
||||
last if $done{$$op}++;
|
||||
warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
|
||||
warn peekop($op), "\n" if $debug_op;
|
||||
my $opname = $op->name;
|
||||
if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
|
||||
xref($op->other);
|
||||
} elsif ($opname eq "match" || $opname eq "subst") {
|
||||
xref($op->pmreplstart);
|
||||
} elsif ($opname eq "substcont") {
|
||||
xref($op->other->pmreplstart);
|
||||
$op = $op->other;
|
||||
redo;
|
||||
} elsif ($opname eq "enterloop") {
|
||||
xref($op->redoop);
|
||||
xref($op->nextop);
|
||||
xref($op->lastop);
|
||||
} elsif ($opname eq "subst") {
|
||||
xref($op->pmreplstart);
|
||||
} else {
|
||||
no strict 'refs';
|
||||
my $ppname = "pp_$opname";
|
||||
&$ppname($op) if defined(&$ppname);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub xref_cv {
|
||||
my $cv = shift;
|
||||
my $pack = $cv->GV->STASH->NAME;
|
||||
$subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
|
||||
load_pad($cv->PADLIST);
|
||||
xref($cv->START);
|
||||
$subname = "(main)";
|
||||
}
|
||||
|
||||
sub xref_object {
|
||||
my $cvref = shift;
|
||||
xref_cv(svref_2object($cvref));
|
||||
}
|
||||
|
||||
sub xref_main {
|
||||
$subname = "(main)";
|
||||
load_pad(comppadlist);
|
||||
xref(main_start);
|
||||
while (@todo) {
|
||||
xref_cv(shift @todo);
|
||||
}
|
||||
}
|
||||
|
||||
sub pp_nextstate {
|
||||
my $op = shift;
|
||||
$file = $op->file;
|
||||
$line = $op->line;
|
||||
$top = UNKNOWN;
|
||||
}
|
||||
|
||||
sub pp_padrange {
|
||||
my $op = shift;
|
||||
my $count = $op->private & 127;
|
||||
for my $i (0..$count-1) {
|
||||
$top = $pad[$op->targ + $i];
|
||||
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
|
||||
}
|
||||
}
|
||||
|
||||
sub pp_padsv {
|
||||
my $op = shift;
|
||||
$top = $pad[$op->targ];
|
||||
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
|
||||
}
|
||||
|
||||
sub pp_padav { pp_padsv(@_) }
|
||||
sub pp_padhv { pp_padsv(@_) }
|
||||
|
||||
sub deref {
|
||||
my ($op, $var, $as) = @_;
|
||||
$var->[1] = $as . $var->[1];
|
||||
process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
|
||||
}
|
||||
|
||||
sub pp_rv2cv { deref(shift, $top, "&"); }
|
||||
sub pp_rv2hv { deref(shift, $top, "%"); }
|
||||
sub pp_rv2sv { deref(shift, $top, "\$"); }
|
||||
sub pp_rv2av { deref(shift, $top, "\@"); }
|
||||
sub pp_rv2gv { deref(shift, $top, "*"); }
|
||||
|
||||
sub pp_gvsv {
|
||||
my $op = shift;
|
||||
my $gv;
|
||||
if ($Config{useithreads}) {
|
||||
$top = $pad[$op->padix];
|
||||
$top = UNKNOWN unless $top;
|
||||
$top->[1] = '$';
|
||||
}
|
||||
else {
|
||||
$gv = $op->gv;
|
||||
$top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
|
||||
}
|
||||
process($top, $op->private & OPpLVAL_INTRO ||
|
||||
$op->private & OPpOUR_INTRO ? "intro" : "used");
|
||||
}
|
||||
|
||||
sub pp_gv {
|
||||
my $op = shift;
|
||||
my $gv;
|
||||
if ($Config{useithreads}) {
|
||||
$top = $pad[$op->padix];
|
||||
$top = UNKNOWN unless $top;
|
||||
$top->[1] = '*';
|
||||
}
|
||||
else {
|
||||
$gv = $op->gv;
|
||||
if ($gv->FLAGS & SVf_ROK) { # sub ref
|
||||
my $cv = $gv->RV;
|
||||
$top = [$cv->STASH->NAME, '*', B::safename($cv->NAME_HEK)]
|
||||
}
|
||||
else {
|
||||
$top = [$gv->STASH->NAME, '*', $gv->SAFENAME];
|
||||
}
|
||||
}
|
||||
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
|
||||
}
|
||||
|
||||
sub pp_const {
|
||||
my $op = shift;
|
||||
my $sv = $op->sv;
|
||||
# constant could be in the pad (under useithreads)
|
||||
if ($$sv) {
|
||||
$top = ["?", "",
|
||||
(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
|
||||
? cstring($sv->PV) : "?"];
|
||||
}
|
||||
else {
|
||||
$top = $pad[$op->targ];
|
||||
$top = UNKNOWN unless $top;
|
||||
}
|
||||
}
|
||||
|
||||
sub pp_method {
|
||||
my $op = shift;
|
||||
$top = ["(method)", "->".$top->[1], $top->[2]];
|
||||
}
|
||||
|
||||
sub pp_entersub {
|
||||
my $op = shift;
|
||||
if ($top->[1] eq "m") {
|
||||
process($top, "meth");
|
||||
} else {
|
||||
process($top, "subused");
|
||||
}
|
||||
$top = UNKNOWN;
|
||||
}
|
||||
|
||||
#
|
||||
# Stuff for cross referencing definitions of variables and subs
|
||||
#
|
||||
|
||||
sub B::GV::xref {
|
||||
my $gv = shift;
|
||||
my $cv = $gv->CV;
|
||||
if ($$cv) {
|
||||
#return if $done{$$cv}++;
|
||||
$file = $gv->FILE;
|
||||
$line = $gv->LINE;
|
||||
process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
|
||||
push(@todo, $cv);
|
||||
}
|
||||
my $form = $gv->FORM;
|
||||
if ($$form) {
|
||||
return if $done{$$form}++;
|
||||
$file = $gv->FILE;
|
||||
$line = $gv->LINE;
|
||||
process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
|
||||
}
|
||||
}
|
||||
|
||||
sub xref_definitions {
|
||||
my ($pack, %exclude);
|
||||
return if $nodefs;
|
||||
$subname = "(definitions)";
|
||||
foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
|
||||
strict vars FileHandle Exporter Carp PerlIO::Layer
|
||||
attributes utf8 warnings)) {
|
||||
$exclude{$pack."::"} = 1;
|
||||
}
|
||||
no strict qw(vars refs);
|
||||
walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
|
||||
}
|
||||
|
||||
sub output {
|
||||
return if $raw;
|
||||
my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
|
||||
$perpack, $pername, $perev);
|
||||
foreach $file (sort(keys(%table))) {
|
||||
$perfile = $table{$file};
|
||||
print "File $file\n";
|
||||
foreach $subname (sort(keys(%$perfile))) {
|
||||
$persubname = $perfile->{$subname};
|
||||
print " Subroutine $subname\n";
|
||||
foreach $pack (sort(keys(%$persubname))) {
|
||||
$perpack = $persubname->{$pack};
|
||||
print " Package $pack\n";
|
||||
foreach $name (sort(keys(%$perpack))) {
|
||||
$pername = $perpack->{$name};
|
||||
my @lines;
|
||||
foreach $ev (qw(intro formdef subdef meth subused used)) {
|
||||
$perev = $pername->{$ev};
|
||||
if (defined($perev) && @$perev) {
|
||||
my $code = $code{$ev};
|
||||
push(@lines, map("$code$_", @$perev));
|
||||
}
|
||||
}
|
||||
printf " %-16s %s\n", $name, join(", ", @lines);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub compile {
|
||||
my @options = @_;
|
||||
my ($option, $opt, $arg);
|
||||
OPTION:
|
||||
while ($option = shift @options) {
|
||||
if ($option =~ /^-(.)(.*)/) {
|
||||
$opt = $1;
|
||||
$arg = $2;
|
||||
} else {
|
||||
unshift @options, $option;
|
||||
last OPTION;
|
||||
}
|
||||
if ($opt eq "-" && $arg eq "-") {
|
||||
shift @options;
|
||||
last OPTION;
|
||||
} elsif ($opt eq "o") {
|
||||
$arg ||= shift @options;
|
||||
open(STDOUT, '>', $arg) or return "$arg: $!\n";
|
||||
} elsif ($opt eq "d") {
|
||||
$nodefs = 1;
|
||||
} elsif ($opt eq "r") {
|
||||
$raw = 1;
|
||||
} elsif ($opt eq "D") {
|
||||
$arg ||= shift @options;
|
||||
foreach $arg (split(//, $arg)) {
|
||||
if ($arg eq "o") {
|
||||
B->debug(1);
|
||||
} elsif ($arg eq "O") {
|
||||
$debug_op = 1;
|
||||
} elsif ($arg eq "t") {
|
||||
$debug_top = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if (@options) {
|
||||
return sub {
|
||||
my $objname;
|
||||
xref_definitions();
|
||||
foreach $objname (@options) {
|
||||
$objname = "main::$objname" unless $objname =~ /::/;
|
||||
eval "xref_object(\\&$objname)";
|
||||
die "xref_object(\\&$objname) failed: $@" if $@;
|
||||
}
|
||||
output();
|
||||
}
|
||||
} else {
|
||||
return sub {
|
||||
xref_definitions();
|
||||
xref_main();
|
||||
output();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user