Initial Windows agent repository
This commit is contained in:
commit
a0db0c2e5b
10589 changed files with 3844063 additions and 0 deletions
1929
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Concise.pm
Normal file
1929
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Concise.pm
Normal file
File diff suppressed because it is too large
Load diff
217
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Showlex.pm
Normal file
217
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Showlex.pm
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
package B::Showlex;
|
||||
|
||||
our $VERSION = '1.05';
|
||||
|
||||
use strict;
|
||||
use B qw(svref_2object comppadlist class);
|
||||
use B::Terse ();
|
||||
use B::Concise ();
|
||||
|
||||
#
|
||||
# Invoke as
|
||||
# perl -MO=Showlex,foo bar.pl
|
||||
# to see the names of lexical variables used by &foo
|
||||
# or as
|
||||
# perl -MO=Showlex bar.pl
|
||||
# to see the names of file scope lexicals used by bar.pl
|
||||
#
|
||||
|
||||
|
||||
# borrowed from B::Concise
|
||||
our $walkHandle = \*STDOUT;
|
||||
|
||||
sub walk_output { # updates $walkHandle
|
||||
$walkHandle = B::Concise::walk_output(@_);
|
||||
#print "got $walkHandle";
|
||||
#print $walkHandle "using it";
|
||||
$walkHandle;
|
||||
}
|
||||
|
||||
sub shownamearray {
|
||||
my ($name, $av) = @_;
|
||||
my @els = $av->ARRAY;
|
||||
my $count = @els;
|
||||
my $i;
|
||||
print $walkHandle "$name has $count entries\n";
|
||||
for ($i = 0; $i < $count; $i++) {
|
||||
my $sv = $els[$i];
|
||||
if (class($sv) ne "SPECIAL") {
|
||||
printf $walkHandle "$i: (0x%lx) %s\n",
|
||||
$$sv, $sv->PVX // "undef" || "const";
|
||||
} else {
|
||||
printf $walkHandle "$i: %s\n", $sv->terse;
|
||||
#printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub showvaluearray {
|
||||
my ($name, $av) = @_;
|
||||
my @els = $av->ARRAY;
|
||||
my $count = @els;
|
||||
my $i;
|
||||
print $walkHandle "$name has $count entries\n";
|
||||
for ($i = 0; $i < $count; $i++) {
|
||||
printf $walkHandle "$i: %s\n", $els[$i]->terse;
|
||||
#print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
|
||||
}
|
||||
}
|
||||
|
||||
sub showlex {
|
||||
my ($objname, $namesav, $valsav) = @_;
|
||||
shownamearray("Pad of lexical names for $objname", $namesav);
|
||||
showvaluearray("Pad of lexical values for $objname", $valsav);
|
||||
}
|
||||
|
||||
my ($newlex, $nosp1); # rendering state vars
|
||||
|
||||
sub padname_terse {
|
||||
my $name = shift;
|
||||
return $name->terse if class($name) eq 'SPECIAL';
|
||||
my $str = $name->PVX;
|
||||
return sprintf "(0x%lx) %s",
|
||||
$$name,
|
||||
length $str ? qq'"$str"' : defined $str ? "const" : 'undef';
|
||||
}
|
||||
|
||||
sub newlex { # drop-in for showlex
|
||||
my ($objname, $names, $vals) = @_;
|
||||
my @names = $names->ARRAY;
|
||||
my @vals = $vals->ARRAY;
|
||||
my $count = @names;
|
||||
print $walkHandle "$objname Pad has $count entries\n";
|
||||
printf $walkHandle "0: %s\n", padname_terse($names[0]) unless $nosp1;
|
||||
for (my $i = 1; $i < $count; $i++) {
|
||||
printf $walkHandle "$i: %s = %s\n", padname_terse($names[$i]),
|
||||
$vals[$i]->terse,
|
||||
unless $nosp1
|
||||
and class($names[$i]) eq 'SPECIAL' || !$names[$i]->LEN;
|
||||
}
|
||||
}
|
||||
|
||||
sub showlex_obj {
|
||||
my ($objname, $obj) = @_;
|
||||
$objname =~ s/^&main::/&/;
|
||||
showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
|
||||
newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
|
||||
}
|
||||
|
||||
sub showlex_main {
|
||||
showlex("comppadlist", comppadlist->ARRAY) if !$newlex;
|
||||
newlex ("main", comppadlist->ARRAY) if $newlex;
|
||||
}
|
||||
|
||||
sub compile {
|
||||
my @options = grep(/^-/, @_);
|
||||
my @args = grep(!/^-/, @_);
|
||||
for my $o (@options) {
|
||||
$newlex = 1 if $o eq "-newlex";
|
||||
$nosp1 = 1 if $o eq "-nosp";
|
||||
}
|
||||
|
||||
return \&showlex_main unless @args;
|
||||
return sub {
|
||||
my $objref;
|
||||
foreach my $objname (@args) {
|
||||
next unless $objname; # skip nulls w/o carping
|
||||
|
||||
if (ref $objname) {
|
||||
print $walkHandle "B::Showlex::compile($objname)\n";
|
||||
$objref = $objname;
|
||||
} else {
|
||||
$objname = "main::$objname" unless $objname =~ /::/;
|
||||
print $walkHandle "$objname:\n";
|
||||
no strict 'refs';
|
||||
die "err: unknown function ($objname)\n"
|
||||
unless *{$objname}{CODE};
|
||||
$objref = \&$objname;
|
||||
}
|
||||
showlex_obj($objname, $objref);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Showlex - Show lexical variables used in functions or files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When a comma-separated list of subroutine names is given as options, Showlex
|
||||
prints the lexical variables used in those subroutines. Otherwise, it prints
|
||||
the file-scope lexicals in the file.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
Traditional form:
|
||||
|
||||
$ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
|
||||
Pad of lexical names for comppadlist has 4 entries
|
||||
0: (0x8caea4) undef
|
||||
1: (0x9db0fb0) $i
|
||||
2: (0x9db0f38) $j
|
||||
3: (0x9db0f50) $k
|
||||
Pad of lexical values for comppadlist has 5 entries
|
||||
0: SPECIAL #1 &PL_sv_undef
|
||||
1: NULL (0x9da4234)
|
||||
2: NULL (0x9db0f2c)
|
||||
3: NULL (0x9db0f44)
|
||||
4: NULL (0x9da4264)
|
||||
-e syntax OK
|
||||
|
||||
New-style form:
|
||||
|
||||
$ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
|
||||
main Pad has 4 entries
|
||||
0: (0x8caea4) undef
|
||||
1: (0xa0c4fb8) "$i" = NULL (0xa0b8234)
|
||||
2: (0xa0c4f40) "$j" = NULL (0xa0c4f34)
|
||||
3: (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
|
||||
-e syntax OK
|
||||
|
||||
New form, no specials, outside O framework:
|
||||
|
||||
$ perl -MB::Showlex -e \
|
||||
'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
|
||||
main Pad has 4 entries
|
||||
1: (0x998ffb0) "$i" = IV (0x9983234) 1
|
||||
2: (0x998ff68) "$j" = PV (0x998ff5c) "foo"
|
||||
3: (0x998ff80) "$k" = NULL (0x998ff74)
|
||||
|
||||
Note that this example shows the values of the lexicals, whereas the other
|
||||
examples did not (as they're compile-time only).
|
||||
|
||||
=head2 OPTIONS
|
||||
|
||||
The C<-newlex> option produces a more readable C<< name => value >> format,
|
||||
and is shown in the second example above.
|
||||
|
||||
The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL
|
||||
#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm
|
||||
your declared lexicals.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<B::Showlex> can also be used outside of the O framework, as in the third
|
||||
example. See L<B::Concise> for a fuller explanation of reasons.
|
||||
|
||||
=head1 TODO
|
||||
|
||||
Some of the reported info, such as hex addresses, is not particularly
|
||||
valuable. Other information would be more useful for the typical
|
||||
programmer, such as line-numbers, pad-slot reuses, etc.. Given this,
|
||||
-newlex is not a particularly good flag-name.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
|
||||
|
||||
=cut
|
||||
104
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Terse.pm
Normal file
104
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Terse.pm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
package B::Terse;
|
||||
|
||||
our $VERSION = '1.09';
|
||||
|
||||
use strict;
|
||||
use B qw(class @specialsv_name);
|
||||
use B::Concise qw(concise_subref set_style_standard);
|
||||
use Carp;
|
||||
|
||||
sub terse {
|
||||
my ($order, $subref) = @_;
|
||||
set_style_standard("terse");
|
||||
if ($order eq "exec") {
|
||||
concise_subref('exec', $subref);
|
||||
} else {
|
||||
concise_subref('basic', $subref);
|
||||
}
|
||||
}
|
||||
|
||||
sub compile {
|
||||
my @args = @_;
|
||||
my $order = @args ? shift(@args) : "";
|
||||
$order = "-exec" if $order eq "exec";
|
||||
unshift @args, $order if $order ne "";
|
||||
B::Concise::compile("-terse", @args);
|
||||
}
|
||||
|
||||
sub indent {
|
||||
my ($level) = @_ ? shift : 0;
|
||||
return " " x $level;
|
||||
}
|
||||
|
||||
|
||||
sub B::SV::terse {
|
||||
my($sv, $level) = (@_, 0);
|
||||
my %info;
|
||||
B::Concise::concise_sv($sv, \%info);
|
||||
my $s = indent($level)
|
||||
. B::Concise::fmt_line(\%info, $sv,
|
||||
"#svclass~(?((#svaddr))?)~#svval", 0);
|
||||
chomp $s;
|
||||
print "$s\n" unless defined wantarray;
|
||||
$s;
|
||||
}
|
||||
|
||||
sub B::NULL::terse {
|
||||
my ($sv, $level) = (@_, 0);
|
||||
my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
|
||||
print "$s\n" unless defined wantarray;
|
||||
$s;
|
||||
}
|
||||
|
||||
sub B::SPECIAL::terse {
|
||||
my ($sv, $level) = (@_, 0);
|
||||
my $s = indent($level)
|
||||
. sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
|
||||
print "$s\n" unless defined wantarray;
|
||||
$s;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Terse - Walk Perl syntax tree, printing terse info about ops
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MO=Terse[,OPTIONS] foo.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module prints the contents of the parse tree, but without as much
|
||||
information as CPAN module B::Debug. For comparison, C<print "Hello, world.">
|
||||
produced 96 lines of output from B::Debug, but only 6 from B::Terse.
|
||||
|
||||
This module is useful for people who are writing their own back end,
|
||||
or who are learning about the Perl internals. It's not useful to the
|
||||
average programmer.
|
||||
|
||||
This version of B::Terse is really just a wrapper that calls L<B::Concise>
|
||||
with the B<-terse> option. It is provided for compatibility with old scripts
|
||||
(and habits) but using B::Concise directly is now recommended instead.
|
||||
|
||||
For compatibility with the old B::Terse, this module also adds a
|
||||
method named C<terse> to B::OP and B::SV objects. The B::SV method is
|
||||
largely compatible with the old one, though authors of new software
|
||||
might be advised to choose a more user-friendly output format. The
|
||||
B::OP C<terse> method, however, doesn't work well. Since B::Terse was
|
||||
first written, much more information in OPs has migrated to the
|
||||
scratchpad datastructure, but the C<terse> interface doesn't have any
|
||||
way of getting to the correct pad. As a kludge, the new version will
|
||||
always use the pad for the main program, but for OPs in subroutines
|
||||
this will give the wrong answer or crash.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
The original version of B::Terse was written by Malcolm Beattie,
|
||||
E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
|
||||
McCamant, E<lt>smcc@MIT.EDUE<gt>.
|
||||
|
||||
=cut
|
||||
496
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Xref.pm
Normal file
496
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/B/Xref.pm
Normal file
|
|
@ -0,0 +1,496 @@
|
|||
package B::Xref;
|
||||
|
||||
our $VERSION = '1.07';
|
||||
|
||||
=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".
|
||||
|
||||
For instance, here's part of the report from the I<pod2man> program that
|
||||
comes with Perl:
|
||||
|
||||
Subroutine clear_noremap
|
||||
Package (lexical)
|
||||
$ready_to_print i1069, 1079
|
||||
Package main
|
||||
$& 1086
|
||||
$. 1086
|
||||
$0 1086
|
||||
$1 1087
|
||||
$2 1085, 1085
|
||||
$3 1085, 1085
|
||||
$ARGV 1086
|
||||
%HTML_Escapes 1085, 1085
|
||||
|
||||
This shows the variables used in the subroutine C<clear_noremap>. The
|
||||
variable C<$ready_to_print> is a my() (lexical) variable,
|
||||
B<i>ntroduced (first declared with my()) on line 1069, and used on
|
||||
line 1079. The variable C<$&> from the main package is used on 1086,
|
||||
and so on.
|
||||
|
||||
A line number may be prefixed by a single letter:
|
||||
|
||||
=over 4
|
||||
|
||||
=item i
|
||||
|
||||
Lexical variable introduced (declared with my()) for the first time.
|
||||
|
||||
=item &
|
||||
|
||||
Subroutine or method call.
|
||||
|
||||
=item s
|
||||
|
||||
Subroutine defined.
|
||||
|
||||
=item r
|
||||
|
||||
Format defined.
|
||||
|
||||
=back
|
||||
|
||||
The most useful option the cross referencer has is to save the report
|
||||
to a separate file. For instance, to save the report on
|
||||
I<myperlprogram> to the file I<report>:
|
||||
|
||||
$ perl -MO=Xref,-oreport myperlprogram
|
||||
|
||||
=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 SVf_ROK 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) =~ '^(?:SPECIAL|NULL)\z';
|
||||
($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_padrange {
|
||||
my $op = shift;
|
||||
my $count = $op->private & 127;
|
||||
for my $i (0..$count-1) {
|
||||
$top = $pad[$op->targ + $i];
|
||||
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
if ($gv->FLAGS & SVf_ROK) { # sub ref
|
||||
my $cv = $gv->RV;
|
||||
$top = [$cv->STASH->NAME, '*', B::safename($cv->NAME_HEK)]
|
||||
}
|
||||
else {
|
||||
$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;
|
||||
Loading…
Add table
Add a link
Reference in a new issue