[perl5.git] / ext / B / B / Xref.pm

package B::Xref;

=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];
    }
}

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