1N/Apackage B::Xref;
1N/A
1N/Aour $VERSION = '1.01';
1N/A
1N/A=head1 NAME
1N/A
1N/AB::Xref - Generates cross reference reports for Perl programs
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/Aperl -MO=Xref[,OPTIONS] foo.pl
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/AThe B::Xref module is used to generate a cross reference listing of all
1N/Adefinitions and uses of variables, subroutines and formats in a Perl program.
1N/AIt is implemented as a backend for the Perl compiler.
1N/A
1N/AThe report generated is in the following format:
1N/A
1N/A File filename1
1N/A Subroutine subname1
1N/A Package package1
1N/A object1 line numbers
1N/A object2 line numbers
1N/A ...
1N/A Package package2
1N/A ...
1N/A
1N/AEach B<File> section reports on a single file. Each B<Subroutine> section
1N/Areports on a single subroutine apart from the special cases
1N/A"(definitions)" and "(main)". These report, respectively, on subroutine
1N/Adefinitions found by the initial symbol table walk and on the main part of
1N/Athe program or module external to all subroutines.
1N/A
1N/AThe report is then grouped by the B<Package> of each variable,
1N/Asubroutine or format with the special case "(lexicals)" meaning
1N/Alexical variables. Each B<object> name (implicitly qualified by its
1N/Acontaining B<Package>) includes its type character(s) at the beginning
1N/Awhere possible. Lexical variables are easier to track and even
1N/Aincluded dereferencing information where possible.
1N/A
1N/AThe C<line numbers> are a comma separated list of line numbers (some
1N/Apreceded by code letters) where that object is used in some way.
1N/ASimple uses aren't preceded by a code letter. Introductions (such as
1N/Awhere a lexical is first defined with C<my>) are indicated with the
1N/Aletter "i". Subroutine and method calls are indicated by the character
1N/A"&". Subroutine definitions are indicated by "s" and format
1N/Adefinitions by "f".
1N/A
1N/A=head1 OPTIONS
1N/A
1N/AOption words are separated by commas (not whitespace) and follow the
1N/Ausual conventions of compiler backend options.
1N/A
1N/A=over 8
1N/A
1N/A=item C<-oFILENAME>
1N/A
1N/ADirects output to C<FILENAME> instead of standard output.
1N/A
1N/A=item C<-r>
1N/A
1N/ARaw output. Instead of producing a human-readable report, outputs a line
1N/Ain machine-readable form for each definition/use of a variable/sub/format.
1N/A
1N/A=item C<-d>
1N/A
1N/ADon't output the "(definitions)" sections.
1N/A
1N/A=item C<-D[tO]>
1N/A
1N/A(Internal) debug options, probably only useful if C<-r> included.
1N/AThe C<t> option prints the object on the top of the stack as it's
1N/Abeing tracked. The C<O> option prints each operator as it's being
1N/Aprocessed in the execution order of the program.
1N/A
1N/A=back
1N/A
1N/A=head1 BUGS
1N/A
1N/ANon-lexical variables are quite difficult to track through a program.
1N/ASometimes the type of a non-lexical variable's use is impossible to
1N/Adetermine. Introductions of non-lexical non-scalars don't seem to be
1N/Areported properly.
1N/A
1N/A=head1 AUTHOR
1N/A
1N/AMalcolm Beattie, mbeattie@sable.ox.ac.uk.
1N/A
1N/A=cut
1N/A
1N/Ause strict;
1N/Ause Config;
1N/Ause B qw(peekop class comppadlist main_start svref_2object walksymtable
1N/A OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
1N/A );
1N/A
1N/Asub UNKNOWN { ["?", "?", "?"] }
1N/A
1N/Amy @pad; # lexicals in current pad
1N/A # as ["(lexical)", type, name]
1N/Amy %done; # keyed by $$op: set when each $op is done
1N/Amy $top = UNKNOWN; # shadows top element of stack as
1N/A # [pack, type, name] (pack can be "(lexical)")
1N/Amy $file; # shadows current filename
1N/Amy $line; # shadows current line number
1N/Amy $subname; # shadows current sub name
1N/Amy %table; # Multi-level hash to record all uses etc.
1N/Amy @todo = (); # List of CVs that need processing
1N/A
1N/Amy %code = (intro => "i", used => "",
1N/A subdef => "s", subused => "&",
1N/A formdef => "f", meth => "->");
1N/A
1N/A
1N/A# Options
1N/Amy ($debug_op, $debug_top, $nodefs, $raw);
1N/A
1N/Asub process {
1N/A my ($var, $event) = @_;
1N/A my ($pack, $type, $name) = @$var;
1N/A if ($type eq "*") {
1N/A if ($event eq "used") {
1N/A return;
1N/A } elsif ($event eq "subused") {
1N/A $type = "&";
1N/A }
1N/A }
1N/A $type =~ s/(.)\*$/$1/g;
1N/A if ($raw) {
1N/A printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
1N/A $file, $subname, $line, $pack, $type, $name, $event;
1N/A } else {
1N/A # Wheee
1N/A push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
1N/A $line);
1N/A }
1N/A}
1N/A
1N/Asub load_pad {
1N/A my $padlist = shift;
1N/A my ($namelistav, $vallistav, @namelist, $ix);
1N/A @pad = ();
1N/A return if class($padlist) eq "SPECIAL";
1N/A ($namelistav,$vallistav) = $padlist->ARRAY;
1N/A @namelist = $namelistav->ARRAY;
1N/A for ($ix = 1; $ix < @namelist; $ix++) {
1N/A my $namesv = $namelist[$ix];
1N/A next if class($namesv) eq "SPECIAL";
1N/A my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
1N/A $pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
1N/A }
1N/A if ($Config{useithreads}) {
1N/A my (@vallist);
1N/A @vallist = $vallistav->ARRAY;
1N/A for ($ix = 1; $ix < @vallist; $ix++) {
1N/A my $valsv = $vallist[$ix];
1N/A next unless class($valsv) eq "GV";
1N/A # these pad GVs don't have corresponding names, so same @pad
1N/A # array can be used without collisions
1N/A $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub xref {
1N/A my $start = shift;
1N/A my $op;
1N/A for ($op = $start; $$op; $op = $op->next) {
1N/A last if $done{$$op}++;
1N/A warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
1N/A warn peekop($op), "\n" if $debug_op;
1N/A my $opname = $op->name;
1N/A if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
1N/A xref($op->other);
1N/A } elsif ($opname eq "match" || $opname eq "subst") {
1N/A xref($op->pmreplstart);
1N/A } elsif ($opname eq "substcont") {
1N/A xref($op->other->pmreplstart);
1N/A $op = $op->other;
1N/A redo;
1N/A } elsif ($opname eq "enterloop") {
1N/A xref($op->redoop);
1N/A xref($op->nextop);
1N/A xref($op->lastop);
1N/A } elsif ($opname eq "subst") {
1N/A xref($op->pmreplstart);
1N/A } else {
1N/A no strict 'refs';
1N/A my $ppname = "pp_$opname";
1N/A &$ppname($op) if defined(&$ppname);
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub xref_cv {
1N/A my $cv = shift;
1N/A my $pack = $cv->GV->STASH->NAME;
1N/A $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
1N/A load_pad($cv->PADLIST);
1N/A xref($cv->START);
1N/A $subname = "(main)";
1N/A}
1N/A
1N/Asub xref_object {
1N/A my $cvref = shift;
1N/A xref_cv(svref_2object($cvref));
1N/A}
1N/A
1N/Asub xref_main {
1N/A $subname = "(main)";
1N/A load_pad(comppadlist);
1N/A xref(main_start);
1N/A while (@todo) {
1N/A xref_cv(shift @todo);
1N/A }
1N/A}
1N/A
1N/Asub pp_nextstate {
1N/A my $op = shift;
1N/A $file = $op->file;
1N/A $line = $op->line;
1N/A $top = UNKNOWN;
1N/A}
1N/A
1N/Asub pp_padsv {
1N/A my $op = shift;
1N/A $top = $pad[$op->targ];
1N/A process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
1N/A}
1N/A
1N/Asub pp_padav { pp_padsv(@_) }
1N/Asub pp_padhv { pp_padsv(@_) }
1N/A
1N/Asub deref {
1N/A my ($op, $var, $as) = @_;
1N/A $var->[1] = $as . $var->[1];
1N/A process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
1N/A}
1N/A
1N/Asub pp_rv2cv { deref(shift, $top, "&"); }
1N/Asub pp_rv2hv { deref(shift, $top, "%"); }
1N/Asub pp_rv2sv { deref(shift, $top, "\$"); }
1N/Asub pp_rv2av { deref(shift, $top, "\@"); }
1N/Asub pp_rv2gv { deref(shift, $top, "*"); }
1N/A
1N/Asub pp_gvsv {
1N/A my $op = shift;
1N/A my $gv;
1N/A if ($Config{useithreads}) {
1N/A $top = $pad[$op->padix];
1N/A $top = UNKNOWN unless $top;
1N/A $top->[1] = '$';
1N/A }
1N/A else {
1N/A $gv = $op->gv;
1N/A $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
1N/A }
1N/A process($top, $op->private & OPpLVAL_INTRO ||
1N/A $op->private & OPpOUR_INTRO ? "intro" : "used");
1N/A}
1N/A
1N/Asub pp_gv {
1N/A my $op = shift;
1N/A my $gv;
1N/A if ($Config{useithreads}) {
1N/A $top = $pad[$op->padix];
1N/A $top = UNKNOWN unless $top;
1N/A $top->[1] = '*';
1N/A }
1N/A else {
1N/A $gv = $op->gv;
1N/A $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
1N/A }
1N/A process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
1N/A}
1N/A
1N/Asub pp_const {
1N/A my $op = shift;
1N/A my $sv = $op->sv;
1N/A # constant could be in the pad (under useithreads)
1N/A if ($$sv) {
1N/A $top = ["?", "",
1N/A (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
1N/A ? cstring($sv->PV) : "?"];
1N/A }
1N/A else {
1N/A $top = $pad[$op->targ];
1N/A $top = UNKNOWN unless $top;
1N/A }
1N/A}
1N/A
1N/Asub pp_method {
1N/A my $op = shift;
1N/A $top = ["(method)", "->".$top->[1], $top->[2]];
1N/A}
1N/A
1N/Asub pp_entersub {
1N/A my $op = shift;
1N/A if ($top->[1] eq "m") {
1N/A process($top, "meth");
1N/A } else {
1N/A process($top, "subused");
1N/A }
1N/A $top = UNKNOWN;
1N/A}
1N/A
1N/A#
1N/A# Stuff for cross referencing definitions of variables and subs
1N/A#
1N/A
1N/Asub B::GV::xref {
1N/A my $gv = shift;
1N/A my $cv = $gv->CV;
1N/A if ($$cv) {
1N/A #return if $done{$$cv}++;
1N/A $file = $gv->FILE;
1N/A $line = $gv->LINE;
1N/A process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
1N/A push(@todo, $cv);
1N/A }
1N/A my $form = $gv->FORM;
1N/A if ($$form) {
1N/A return if $done{$$form}++;
1N/A $file = $gv->FILE;
1N/A $line = $gv->LINE;
1N/A process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
1N/A }
1N/A}
1N/A
1N/Asub xref_definitions {
1N/A my ($pack, %exclude);
1N/A return if $nodefs;
1N/A $subname = "(definitions)";
1N/A foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
1N/A strict vars FileHandle Exporter Carp PerlIO::Layer
1N/A attributes utf8 warnings)) {
1N/A $exclude{$pack."::"} = 1;
1N/A }
1N/A no strict qw(vars refs);
1N/A walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
1N/A}
1N/A
1N/Asub output {
1N/A return if $raw;
1N/A my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
1N/A $perpack, $pername, $perev);
1N/A foreach $file (sort(keys(%table))) {
1N/A $perfile = $table{$file};
1N/A print "File $file\n";
1N/A foreach $subname (sort(keys(%$perfile))) {
1N/A $persubname = $perfile->{$subname};
1N/A print " Subroutine $subname\n";
1N/A foreach $pack (sort(keys(%$persubname))) {
1N/A $perpack = $persubname->{$pack};
1N/A print " Package $pack\n";
1N/A foreach $name (sort(keys(%$perpack))) {
1N/A $pername = $perpack->{$name};
1N/A my @lines;
1N/A foreach $ev (qw(intro formdef subdef meth subused used)) {
1N/A $perev = $pername->{$ev};
1N/A if (defined($perev) && @$perev) {
1N/A my $code = $code{$ev};
1N/A push(@lines, map("$code$_", @$perev));
1N/A }
1N/A }
1N/A printf " %-16s %s\n", $name, join(", ", @lines);
1N/A }
1N/A }
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub compile {
1N/A my @options = @_;
1N/A my ($option, $opt, $arg);
1N/A OPTION:
1N/A while ($option = shift @options) {
1N/A if ($option =~ /^-(.)(.*)/) {
1N/A $opt = $1;
1N/A $arg = $2;
1N/A } else {
1N/A unshift @options, $option;
1N/A last OPTION;
1N/A }
1N/A if ($opt eq "-" && $arg eq "-") {
1N/A shift @options;
1N/A last OPTION;
1N/A } elsif ($opt eq "o") {
1N/A $arg ||= shift @options;
1N/A open(STDOUT, ">$arg") or return "$arg: $!\n";
1N/A } elsif ($opt eq "d") {
1N/A $nodefs = 1;
1N/A } elsif ($opt eq "r") {
1N/A $raw = 1;
1N/A } elsif ($opt eq "D") {
1N/A $arg ||= shift @options;
1N/A foreach $arg (split(//, $arg)) {
1N/A if ($arg eq "o") {
1N/A B->debug(1);
1N/A } elsif ($arg eq "O") {
1N/A $debug_op = 1;
1N/A } elsif ($arg eq "t") {
1N/A $debug_top = 1;
1N/A }
1N/A }
1N/A }
1N/A }
1N/A if (@options) {
1N/A return sub {
1N/A my $objname;
1N/A xref_definitions();
1N/A foreach $objname (@options) {
1N/A $objname = "main::$objname" unless $objname =~ /::/;
1N/A eval "xref_object(\\&$objname)";
1N/A die "xref_object(\\&$objname) failed: $@" if $@;
1N/A }
1N/A output();
1N/A }
1N/A } else {
1N/A return sub {
1N/A xref_definitions();
1N/A xref_main();
1N/A output();
1N/A }
1N/A }
1N/A}
1N/A
1N/A1;