X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FXref.pm;h=f727dc766b53085c6fec391b57ff20dff1ea371e;hb=bb7c595be2e30a806b95ad83e9d3613aeb95c384;hp=854db71189249d37427a8e5e3fade35b70ae9f10;hpb=51e5a3db028f084837c4480c0accdebfa7a6e623;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm index 854db71..f727dc7 100644 --- a/ext/B/B/Xref.pm +++ b/ext/B/B/Xref.pm @@ -1,5 +1,7 @@ package B::Xref; +our $VERSION = '1.01'; + =head1 NAME B::Xref - Generates cross reference reports for Perl programs @@ -19,8 +21,8 @@ The report generated is in the following format: File filename1 Subroutine subname1 Package package1 - object1 C - object2 C + object1 line numbers + object2 line numbers ... Package package2 ... @@ -62,6 +64,10 @@ Directs output to C instead of standard output. 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. @@ -85,8 +91,9 @@ 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 + OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring ); sub UNKNOWN { ["?", "?", "?"] } @@ -133,16 +140,27 @@ sub process { sub load_pad { my $padlist = shift; - my ($namelistav, @namelist, $ix); + my ($namelistav, $vallistav, @namelist, $ix); @pad = (); return if class($padlist) eq "SPECIAL"; - ($namelistav) = $padlist->ARRAY; + ($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]; + $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]; + } } } @@ -153,28 +171,24 @@ sub xref { last if $done{$$op}++; warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; warn peekop($op), "\n" if $debug_op; - my $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { + my $opname = $op->name; + if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { xref($op->other); - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($opname eq "match" || $opname eq "subst") { xref($op->pmreplstart); - } elsif ($ppname eq "pp_substcont") { + } elsif ($opname eq "substcont") { xref($op->other->pmreplstart); $op = $op->other; redo; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - xref($op->true); - $op = $op->false; - redo; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($opname eq "enterloop") { xref($op->redoop); xref($op->nextop); xref($op->lastop); - } elsif ($ppname eq "pp_subst") { + } elsif ($opname eq "subst") { xref($op->pmreplstart); } else { no strict 'refs'; + my $ppname = "pp_$opname"; &$ppname($op) if defined(&$ppname); } } @@ -205,7 +219,7 @@ sub xref_main { sub pp_nextstate { my $op = shift; - $file = $op->filegv->SV->PV; + $file = $op->file; $line = $op->line; $top = UNKNOWN; } @@ -220,36 +234,61 @@ sub pp_padav { pp_padsv(@_) } sub pp_padhv { pp_padsv(@_) } sub deref { - my ($var, $as) = @_; + my ($op, $var, $as) = @_; $var->[1] = $as . $var->[1]; - process($var, "used"); + process($var, $op->private & OPpOUR_INTRO ? "intro" : "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_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 = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->NAME]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); + 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 = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->NAME]; + 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; - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + # 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 { @@ -276,7 +315,7 @@ sub B::GV::xref { my $cv = $gv->CV; if ($$cv) { #return if $done{$$cv}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); push(@todo, $cv); @@ -284,7 +323,7 @@ sub B::GV::xref { my $form = $gv->FORM; if ($$form) { return if $done{$$form}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); } @@ -294,8 +333,9 @@ sub xref_definitions { my ($pack, %exclude); return if $nodefs; $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS - strict vars FileHandle Exporter Carp)) { + 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);