diff options
Diffstat (limited to 'chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Xref.pm')
| -rw-r--r-- | chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Xref.pm | 430 |
1 files changed, 0 insertions, 430 deletions
diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Xref.pm b/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Xref.pm deleted file mode 100644 index f727dc766b5..00000000000 --- a/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Xref.pm +++ /dev/null @@ -1,430 +0,0 @@ -package B::Xref; - -our $VERSION = '1.01'; - -=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"; - # 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; |