[p5sagit/p5-mst-13.2.git] / ext / B / B / Xref.pm

package B::Xref;

our $VERSION = '1.02';

=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".

=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 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) eq "SPECIAL";
    ($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_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;
	$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;
Commit	Line	Data
a798dbf2	1	package B::Xref;
a798dbf2	2
af048c18	3	our $VERSION = '1.02';
28b605d8	4
a798dbf2	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
f8d9d21f	24	object1 line numbers
f8d9d21f	25	object2 line numbers
a798dbf2	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
f8d9d21f	67	=item C<-d>
	68
	69	Don't output the "(definitions)" sections.
	70
a798dbf2	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;
18228111	94	use Config;
4c1f658f	95	use B qw(peekop class comppadlist main_start svref_2object walksymtable
f8d9d21f	96	OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
4c1f658f	97	);
a798dbf2	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;
18228111	143	my ($namelistav, $vallistav, @namelist, $ix);
a798dbf2	144	@pad = ();
a798dbf2	145	return if class($padlist) eq "SPECIAL";
18228111	146	($namelistav,$vallistav) = $padlist->ARRAY;
a798dbf2	147	@namelist = $namelistav->ARRAY;
	148	for ($ix = 1; $ix < @namelist; $ix++) {
	149	my $namesv = $namelist[$ix];
	150	next if class($namesv) eq "SPECIAL";
51e5a3db	151	my ($type, $name) = $namesv->PV =~ /^(.)([^\0])(\0.)?$/;
f8d9d21f	152	$pad[$ix] = ["(lexical)", $type \|\| '?', $name \|\| '?'];
a798dbf2	153	}
18228111	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";
d0da4e62	160	next if class($valsv->STASH) eq 'SPECIAL';
18228111	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	}
a798dbf2	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;
3f872cb9	175	my $opname = $op->name;
3f872cb9	176	if ($opname =~ /^(or\|and\|mapwhile\|grepwhile\|range\|cond_expr)$/) {
a798dbf2	177	xref($op->other);
3f872cb9	178	} elsif ($opname eq "match" \|\| $opname eq "subst") {
a798dbf2	179	xref($op->pmreplstart);
3f872cb9	180	} elsif ($opname eq "substcont") {
a798dbf2	181	xref($op->other->pmreplstart);
	182	$op = $op->other;
	183	redo;
3f872cb9	184	} elsif ($opname eq "enterloop") {
a798dbf2	185	xref($op->redoop);
	186	xref($op->nextop);
	187	xref($op->lastop);
3f872cb9	188	} elsif ($opname eq "subst") {
a798dbf2	189	xref($op->pmreplstart);
	190	} else {
	191	no strict 'refs';
3f872cb9	192	my $ppname = "pp_$opname";
a798dbf2	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;
57843af0	223	$file = $op->file;
a798dbf2	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 {
8e011b7d	238	my ($op, $var, $as) = @_;
a798dbf2	239	$var->[1] = $as . $var->[1];
8e011b7d	240	process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
a798dbf2	241	}
a798dbf2	242
8e011b7d	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, "*"); }
a798dbf2	248
	249	sub pp_gvsv {
	250	my $op = shift;
18228111	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;
586b0d7d	259	$top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
18228111	260	}
8e011b7d	261	process($top, $op->private & OPpLVAL_INTRO \|\|
8e011b7d	262	$op->private & OPpOUR_INTRO ? "intro" : "used");
a798dbf2	263	}
	264
	265	sub pp_gv {
	266	my $op = shift;
18228111	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;
586b0d7d	275	$top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
18228111	276	}
a798dbf2	277	process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
	278	}
	279
	280	sub pp_const {
	281	my $op = shift;
	282	my $sv = $op->sv;
18228111	283	# constant could be in the pad (under useithreads)
	284	if ($$sv) {
	285	$top = ["?", "",
f8d9d21f	286	(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
f8d9d21f	287	? cstring($sv->PV) : "?"];
18228111	288	}
	289	else {
	290	$top = $pad[$op->targ];
fdf1c2a9	291	$top = UNKNOWN unless $top;
18228111	292	}
a798dbf2	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}++;
b195d487	319	$file = $gv->FILE;
a798dbf2	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}++;
b195d487	327	$file = $gv->FILE;
a798dbf2	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)";
595f3c5f	337	foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
586b0d7d	338	strict vars FileHandle Exporter Carp PerlIO::Layer
586b0d7d	339	attributes utf8 warnings)) {
a798dbf2	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;