JezK
Edit File: Xref.pm
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;