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

package B::Xref;

our $VERSION = '1.00';

=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        C<line numbers>
	  object2        C<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[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
        );

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";
	    # 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 ($var, $as) = @_;
    $var->[1] = $as . $var->[1];
    process($var, "used");
}

sub pp_rv2cv { deref($top, "&"); }
sub pp_rv2hv { deref($top, "%"); }
sub pp_rv2sv { deref($top, "\$"); }
sub pp_rv2av { deref($top, "\@"); }
sub pp_rv2gv { deref($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->NAME];
    }
    process($top, $op->private & OPpLVAL_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->NAME];
    }
    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) ? $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)) {
        $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
28b605d8	3	our $VERSION = '1.00';
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
	24	object1 C<line numbers>
	25	object2 C<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[tO]>
	68
69	(Internal) debug options, probably only useful if C<-r> included.
70	The C<t> option prints the object on the top of the stack as it's
71	being tracked. The C<O> option prints each operator as it's being
72	processed in the execution order of the program.
73
74	=back
75
76	=head1 BUGS
77
78	Non-lexical variables are quite difficult to track through a program.
79	Sometimes the type of a non-lexical variable's use is impossible to
80	determine. Introductions of non-lexical non-scalars don't seem to be
81	reported properly.
82
83	=head1 AUTHOR
84
85	Malcolm Beattie, mbeattie@sable.ox.ac.uk.
86
87	=cut
88
89	use strict;
18228111	90	use Config;
4c1f658f	91	use B qw(peekop class comppadlist main_start svref_2object walksymtable
	92	OPpLVAL_INTRO SVf_POK
	93	);
a798dbf2	94
	95	sub UNKNOWN { ["?", "?", "?"] }
	96
	97	my @pad; # lexicals in current pad
	98	# as ["(lexical)", type, name]
	99	my %done; # keyed by $$op: set when each $op is done
	100	my $top = UNKNOWN; # shadows top element of stack as
	101	# [pack, type, name] (pack can be "(lexical)")
	102	my $file; # shadows current filename
	103	my $line; # shadows current line number
	104	my $subname; # shadows current sub name
	105	my %table; # Multi-level hash to record all uses etc.
	106	my @todo = (); # List of CVs that need processing
	107
	108	my %code = (intro => "i", used => "",
	109	subdef => "s", subused => "&",
	110	formdef => "f", meth => "->");
	111
	112
	113	# Options
	114	my ($debug_op, $debug_top, $nodefs, $raw);
	115
	116	sub process {
	117	my ($var, $event) = @_;
	118	my ($pack, $type, $name) = @$var;
	119	if ($type eq "*") {
	120	if ($event eq "used") {
	121	return;
	122	} elsif ($event eq "subused") {
	123	$type = "&";
	124	}
	125	}
	126	$type =~ s/(.)\*$/$1/g;
	127	if ($raw) {
	128	printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
	129	$file, $subname, $line, $pack, $type, $name, $event;
	130	} else {
	131	# Wheee
	132	push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
	133	$line);
	134	}
	135	}
	136
	137	sub load_pad {
	138	my $padlist = shift;
18228111	139	my ($namelistav, $vallistav, @namelist, $ix);
a798dbf2	140	@pad = ();
a798dbf2	141	return if class($padlist) eq "SPECIAL";
18228111	142	($namelistav,$vallistav) = $padlist->ARRAY;
a798dbf2	143	@namelist = $namelistav->ARRAY;
	144	for ($ix = 1; $ix < @namelist; $ix++) {
	145	my $namesv = $namelist[$ix];
	146	next if class($namesv) eq "SPECIAL";
51e5a3db	147	my ($type, $name) = $namesv->PV =~ /^(.)([^\0])(\0.)?$/;
a798dbf2	148	$pad[$ix] = ["(lexical)", $type, $name];
a798dbf2	149	}
18228111	150	if ($Config{useithreads}) {
	151	my (@vallist);
	152	@vallist = $vallistav->ARRAY;
	153	for ($ix = 1; $ix < @vallist; $ix++) {
	154	my $valsv = $vallist[$ix];
	155	next unless class($valsv) eq "GV";
	156	# these pad GVs don't have corresponding names, so same @pad
	157	# array can be used without collisions
	158	$pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
	159	}
	160	}
a798dbf2	161	}
	162
	163	sub xref {
	164	my $start = shift;
	165	my $op;
	166	for ($op = $start; $$op; $op = $op->next) {
	167	last if $done{$$op}++;
	168	warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
	169	warn peekop($op), "\n" if $debug_op;
3f872cb9	170	my $opname = $op->name;
3f872cb9	171	if ($opname =~ /^(or\|and\|mapwhile\|grepwhile\|range\|cond_expr)$/) {
a798dbf2	172	xref($op->other);
3f872cb9	173	} elsif ($opname eq "match" \|\| $opname eq "subst") {
a798dbf2	174	xref($op->pmreplstart);
3f872cb9	175	} elsif ($opname eq "substcont") {
a798dbf2	176	xref($op->other->pmreplstart);
	177	$op = $op->other;
	178	redo;
3f872cb9	179	} elsif ($opname eq "enterloop") {
a798dbf2	180	xref($op->redoop);
	181	xref($op->nextop);
	182	xref($op->lastop);
3f872cb9	183	} elsif ($opname eq "subst") {
a798dbf2	184	xref($op->pmreplstart);
	185	} else {
	186	no strict 'refs';
3f872cb9	187	my $ppname = "pp_$opname";
a798dbf2	188	&$ppname($op) if defined(&$ppname);
	189	}
	190	}
	191	}
	192
	193	sub xref_cv {
	194	my $cv = shift;
	195	my $pack = $cv->GV->STASH->NAME;
	196	$subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
	197	load_pad($cv->PADLIST);
	198	xref($cv->START);
	199	$subname = "(main)";
	200	}
	201
	202	sub xref_object {
	203	my $cvref = shift;
	204	xref_cv(svref_2object($cvref));
	205	}
	206
	207	sub xref_main {
	208	$subname = "(main)";
	209	load_pad(comppadlist);
	210	xref(main_start);
	211	while (@todo) {
	212	xref_cv(shift @todo);
	213	}
	214	}
	215
	216	sub pp_nextstate {
	217	my $op = shift;
57843af0	218	$file = $op->file;
a798dbf2	219	$line = $op->line;
	220	$top = UNKNOWN;
	221	}
	222
	223	sub pp_padsv {
	224	my $op = shift;
	225	$top = $pad[$op->targ];
	226	process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
	227	}
	228
	229	sub pp_padav { pp_padsv(@_) }
	230	sub pp_padhv { pp_padsv(@_) }
	231
	232	sub deref {
	233	my ($var, $as) = @_;
	234	$var->[1] = $as . $var->[1];
	235	process($var, "used");
	236	}
	237
	238	sub pp_rv2cv { deref($top, "&"); }
	239	sub pp_rv2hv { deref($top, "%"); }
	240	sub pp_rv2sv { deref($top, "\$"); }
	241	sub pp_rv2av { deref($top, "\@"); }
	242	sub pp_rv2gv { deref($top, "*"); }
	243
	244	sub pp_gvsv {
	245	my $op = shift;
18228111	246	my $gv;
	247	if ($Config{useithreads}) {
	248	$top = $pad[$op->padix];
	249	$top = UNKNOWN unless $top;
	250	$top->[1] = '$';
	251	}
	252	else {
	253	$gv = $op->gv;
	254	$top = [$gv->STASH->NAME, '$', $gv->NAME];
	255	}
a798dbf2	256	process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
	257	}
	258
	259	sub pp_gv {
	260	my $op = shift;
18228111	261	my $gv;
	262	if ($Config{useithreads}) {
	263	$top = $pad[$op->padix];
	264	$top = UNKNOWN unless $top;
	265	$top->[1] = '*';
	266	}
	267	else {
	268	$gv = $op->gv;
	269	$top = [$gv->STASH->NAME, "*", $gv->NAME];
	270	}
a798dbf2	271	process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
	272	}
	273
	274	sub pp_const {
	275	my $op = shift;
	276	my $sv = $op->sv;
18228111	277	# constant could be in the pad (under useithreads)
	278	if ($$sv) {
	279	$top = ["?", "",
	280	(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
	281	}
	282	else {
	283	$top = $pad[$op->targ];
fdf1c2a9	284	$top = UNKNOWN unless $top;
18228111	285	}
a798dbf2	286	}
	287
	288	sub pp_method {
	289	my $op = shift;
	290	$top = ["(method)", "->".$top->[1], $top->[2]];
	291	}
	292
	293	sub pp_entersub {
	294	my $op = shift;
	295	if ($top->[1] eq "m") {
	296	process($top, "meth");
	297	} else {
	298	process($top, "subused");
	299	}
	300	$top = UNKNOWN;
	301	}
	302
	303	#
	304	# Stuff for cross referencing definitions of variables and subs
	305	#
	306
	307	sub B::GV::xref {
	308	my $gv = shift;
	309	my $cv = $gv->CV;
	310	if ($$cv) {
	311	#return if $done{$$cv}++;
b195d487	312	$file = $gv->FILE;
a798dbf2	313	$line = $gv->LINE;
	314	process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
	315	push(@todo, $cv);
	316	}
	317	my $form = $gv->FORM;
	318	if ($$form) {
	319	return if $done{$$form}++;
b195d487	320	$file = $gv->FILE;
a798dbf2	321	$line = $gv->LINE;
	322	process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
	323	}
	324	}
	325
	326	sub xref_definitions {
	327	my ($pack, %exclude);
	328	return if $nodefs;
	329	$subname = "(definitions)";
595f3c5f	330	foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
a798dbf2	331	strict vars FileHandle Exporter Carp)) {
	332	$exclude{$pack."::"} = 1;
	333	}
	334	no strict qw(vars refs);
	335	walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
	336	}
	337
	338	sub output {
	339	return if $raw;
	340	my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
	341	$perpack, $pername, $perev);
	342	foreach $file (sort(keys(%table))) {
	343	$perfile = $table{$file};
	344	print "File $file\n";
	345	foreach $subname (sort(keys(%$perfile))) {
	346	$persubname = $perfile->{$subname};
	347	print " Subroutine $subname\n";
	348	foreach $pack (sort(keys(%$persubname))) {
	349	$perpack = $persubname->{$pack};
	350	print " Package $pack\n";
	351	foreach $name (sort(keys(%$perpack))) {
	352	$pername = $perpack->{$name};
	353	my @lines;
	354	foreach $ev (qw(intro formdef subdef meth subused used)) {
	355	$perev = $pername->{$ev};
	356	if (defined($perev) && @$perev) {
	357	my $code = $code{$ev};
	358	push(@lines, map("$code$_", @$perev));
	359	}
	360	}
	361	printf " %-16s %s\n", $name, join(", ", @lines);
	362	}
	363	}
	364	}
	365	}
	366	}
	367
	368	sub compile {
	369	my @options = @_;
	370	my ($option, $opt, $arg);
	371	OPTION:
	372	while ($option = shift @options) {
	373	if ($option =~ /^-(.)(.*)/) {
	374	$opt = $1;
	375	$arg = $2;
	376	} else {
	377	unshift @options, $option;
	378	last OPTION;
	379	}
	380	if ($opt eq "-" && $arg eq "-") {
	381	shift @options;
	382	last OPTION;
	383	} elsif ($opt eq "o") {
	384	$arg \|\|= shift @options;
	385	open(STDOUT, ">$arg") or return "$arg: $!\n";
	386	} elsif ($opt eq "d") {
	387	$nodefs = 1;
	388	} elsif ($opt eq "r") {
	389	$raw = 1;
	390	} elsif ($opt eq "D") {
	391	$arg \|\|= shift @options;
	392	foreach $arg (split(//, $arg)) {
	393	if ($arg eq "o") {
	394	B->debug(1);
395	} elsif ($arg eq "O") {
396	$debug_op = 1;
397	} elsif ($arg eq "t") {
398	$debug_top = 1;
399	}
400	}
401	}
402	}
403	if (@options) {
404	return sub {
405	my $objname;
406	xref_definitions();
407	foreach $objname (@options) {
408	$objname = "main::$objname" unless $objname =~ /::/;
409	eval "xref_object(\\&$objname)";
410	die "xref_object(\\&$objname) failed: $@" if $@;
411	}
412	output();
413	}
414	} else {
415	return sub {
416	xref_definitions();
417	xref_main();
418	output();
419	}
420	}
421	}
422
423	1;