X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a59118671308b89f1214a83fc0db2e393a19affb..3324ed9f6472f4fa8368f84762b440be0b7392b0:/ext/B/B/Concise.pm diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index b2179a7..8ab7e00 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "0.68"; +our $VERSION = "0.86"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -28,7 +28,7 @@ our %EXPORT_TAGS = # use #6 use B qw(class ppname main_start main_root main_cv cstring svref_2object SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL - CVf_ANON); + CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK); my %style = ("terse" => @@ -37,8 +37,8 @@ my %style = "(*( )*)goto #class (#addr)\n", "#class pp_#name"], "concise" => - ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " - . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n" + ["#hyphseq2 (*( (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)" + . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n" , " (*( )*) goto #seq\n", "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], "linenoise" => @@ -49,7 +49,7 @@ my %style = ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n") - . "\top_flags\t#flagval\n\top_private\t#privval\n" + . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n" . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" . "(?(\top_sv\t\t#svaddr\n)?)", " GOTO #addr\n", @@ -74,6 +74,7 @@ my $big_endian = 1; # more display my $tree_style = 0; # tree-order details my $banner = 1; # print banner before optree is traversed my $do_main = 0; # force printing of main routine +my $show_src; # show source code # another factor: can affect all styles! our @callbacks; # allow external management @@ -142,15 +143,17 @@ sub concise_subref { sub concise_stashref { my($order, $h) = @_; + local *s; foreach my $k (sort keys %$h) { - local *s = $h->{$k}; + next unless defined $h->{$k}; + *s = $h->{$k}; my $coderef = *s{CODE} or next; reset_sequence(); print "FUNC: ", *s, "\n"; my $codeobj = svref_2object($coderef); next unless ref $codeobj eq 'B::CV'; - eval { concise_cv_obj($order, $codeobj) } - or warn "err $@ on $codeobj"; + eval { concise_cv_obj($order, $codeobj, $k) }; + warn "err $@ on $codeobj" if $@; } } @@ -244,6 +247,7 @@ my @tree_decorations = [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], ); +my @render_packs; # collect -stash= sub compileOpts { # set rendering state from options and args @@ -279,6 +283,7 @@ sub compileOpts { } elsif ($o eq "-littleendian") { $big_endian = 0; } + # miscellaneous, presentation elsif ($o eq "-nobanner") { $banner = 0; } elsif ($o eq "-banner") { @@ -288,6 +293,25 @@ sub compileOpts { $do_main = 1; } elsif ($o eq "-nomain") { $do_main = 0; + } elsif ($o eq "-src") { + $show_src = 1; + } + elsif ($o =~ /^-stash=(.*)/) { + my $pkg = $1; + no strict 'refs'; + if (! %{$pkg.'::'}) { + eval "require $pkg"; + } else { + require Config; + if (!$Config::Config{usedl} + && keys %{$pkg.'::'} == 1 + && $pkg->can('bootstrap')) { + # It is something that we're statically linked to, but hasn't + # yet been used. + eval "require $pkg"; + } + } + push @render_packs, $pkg; } # line-style options elsif (exists $style{substr($o, 1)}) { @@ -321,6 +345,10 @@ sub compile { concise_specials("CHECK", $order, B::check_av->isa("B::AV") ? B::check_av->ARRAY : ()); + } elsif ($objname eq "UNITCHECK") { + concise_specials("UNITCHECK", $order, + B::unitcheck_av->isa("B::AV") ? + B::unitcheck_av->ARRAY : ()); } elsif ($objname eq "END") { concise_specials("END", $order, B::end_av->isa("B::AV") ? @@ -346,7 +374,12 @@ sub compile { concise_subref($order, $objref, $objname); } } - if (!@args or $do_main) { + for my $pkg (@render_packs) { + no strict 'refs'; + concise_stashref($order, \%{$pkg.'::'}); + } + + if (!@args or $do_main or @render_packs) { print $walkHandle "main program:\n" if $do_main; concise_main($order); } @@ -429,7 +462,7 @@ sub walk_topdown { walk_topdown($kid, $sub, $level + 1); } } - elsif (class($op) eq "PMOP") { + if (class($op) eq "PMOP") { my $maybe_root = $op->pmreplroot; if (ref($maybe_root) and $maybe_root->isa("B::OP")) { # It really is the root of the replacement, not something @@ -549,8 +582,11 @@ sub fmt_line { # generate text-line for op. $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes + + $text = "# $hr->{src}\n$text" if $show_src and $hr->{src}; + chomp $text; - return "$text\n" if $text ne ""; + return "$text\n" if $text ne "" and $order ne "tree"; return $text; # suppress empty lines } @@ -559,26 +595,32 @@ our %priv; # used to display each opcode's BASEOP.op_private values $priv{$_}{128} = "LVINTRO" for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", - "padav", "padhv", "enteriter"); + "padav", "padhv", "enteriter", "entersub"); $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); $priv{"aassign"}{64} = "COMMON"; -$priv{"aassign"}{32} = "PHASH" if $] < 5.009; +$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE"; $priv{"sassign"}{32} = "STATE"; $priv{"sassign"}{64} = "BKWARD"; +$priv{"sassign"}{128}= "CV2GV"; $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr"); @{$priv{"trans"}}{1,2,4,8,16,64} = ("UTF", "IDENT", "SQUASH", "DEL", "COMPL", "GROWS"); +$priv{transr} = $priv{trans}; $priv{"repeat"}{64} = "DOLIST"; $priv{"leaveloop"}{64} = "CONT"; +$priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv)); @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") for (qw(rv2gv rv2sv padsv aelem helem)); $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv"); -@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD"); -@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); +$priv{rv2gv}{4} = "NOINIT"; +@{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF ); +@{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()"); $priv{"gv"}{32} = "EARLYCV"; $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv", "enteriter"); +$priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem + aslice hslice av2arylen keys rkeys substr pos vec); $priv{$_}{16} = "TARGMY" for (map(($_,"s$_"),"chop", "chomp"), map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", @@ -592,12 +634,13 @@ $priv{$_}{16} = "TARGMY" "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", "setpriority", "time", "sleep"); $priv{$_}{4} = "REVERSED" for ("enteriter", "iter"); -@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN"); +@{$priv{"const"}}{4,8,16,64,128} = ("SHORT","STRICT","ENTERED","BARE","WARN"); $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; $priv{"list"}{64} = "GUESSED"; $priv{"delete"}{64} = "SLICE"; $priv{"exists"}{64} = "SUB"; @{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE"); +$priv{"reverse"}{8} = "INPLACE"; $priv{"threadsv"}{64} = "SVREFd"; @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR") for ("open", "backtick"); @@ -607,7 +650,7 @@ $priv{$_}{2} = "FTACCESS" $priv{"entereval"}{2} = "HAS_HH"; if ($] >= 5.009) { # Stacked filetests are post 5.8.x - $priv{$_}{4} = "FTSTACKED" + @{$priv{$_}}{4,8} = ("FTSTACKED","FTSTACKING") for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec", "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime", "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir", @@ -617,20 +660,47 @@ if ($] >= 5.009) { $priv{$_}{2} = "GREPLEX" for ("mapwhile", "mapstart", "grepwhile", "grepstart"); } - -sub private_flags { - my($name, $x) = @_; +$priv{$_}{128} = '+1' for qw "caller wantarray"; +@{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK'); + +our %hints; # used to display each COP's op_hints values + +# strict refs, subs, vars +@hints{2,512,1024} = ('$', '&', '*'); +# integers, locale, bytes +@hints{1,4,8,16} = ('i', 'l', 'b'); +# block scope, localise %^H, $^OPEN (in), $^OPEN (out) +@hints{256,131072,262144,524288} = ('{','%','<','>'); +# overload new integer, float, binary, string, re +@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R'); +# taint and eval +@hints{1048576,2097152} = ('T', 'E'); +# filetest access, UTF-8 +@hints{4194304,8388608} = ('X', 'U'); + +sub _flags { + my($hash, $x) = @_; my @s; - for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { - if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { + for my $flag (sort {$b <=> $a} keys %$hash) { + if ($hash->{$flag} and $x & $flag and $x >= $flag) { $x -= $flag; - push @s, $priv{$name}{$flag}; + push @s, $hash->{$flag}; } } push @s, $x if $x; return join(",", @s); } +sub private_flags { + my($name, $x) = @_; + _flags($priv{$name}, $x); +} + +sub hints_flags { + my($x) = @_; + _flags(\%hints, $x); +} + sub concise_sv { my($sv, $hr, $preferpv) = @_; $hr->{svclass} = class($sv); @@ -638,10 +708,9 @@ sub concise_sv { if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV; Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv; $hr->{svaddr} = sprintf("%#x", $$sv); - if ($hr->{svclass} eq "GV") { + if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) { my $gv = $sv; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { + my $stash = $gv->STASH->NAME; if ($stash eq "main") { $stash = ""; } else { $stash = $stash . "::"; @@ -649,9 +718,16 @@ sub concise_sv { $hr->{svval} = "*$stash" . $gv->SAFENAME; return "*$stash" . $gv->SAFENAME; } else { - while (class($sv) eq "RV") { - $hr->{svval} .= "\\"; - $sv = $sv->RV; + if ($] >= 5.011) { + while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) { + $hr->{svval} .= "\\"; + $sv = $sv->RV; + } + } else { + while (class($sv) eq "RV") { + $hr->{svval} .= "\\"; + $sv = $sv->RV; + } } if (class($sv) eq "SPECIAL") { $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; @@ -673,6 +749,23 @@ sub concise_sv { } } +my %srclines; + +sub fill_srclines { + my $fullnm = shift; + if ($fullnm eq '-e') { + $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ]; + return; + } + open (my $fh, '<', $fullnm) + or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n" + and return; + my @l = <$fh>; + chomp @l; + unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1 + $srclines{$fullnm} = \@l; +} + sub concise_op { my ($op, $level, $format) = @_; my %h; @@ -702,15 +795,18 @@ sub concise_op { # These changes relate to the jumbo closure fix. # See changes 19939 and 20005 my $fake = ''; - $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON - $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI - $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON; + $fake .= 'a' + if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON; + $fake .= 'm' + if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI; + $fake .= ':' . $padname->PARENT_PAD_INDEX + if $curcv->CvFLAGS & CVf_ANON; $h{targarglife} = "$h{targarg}:FAKE:$fake"; } } else { - my $intro = $padname->NVX - $cop_seq_base; - my $finish = int($padname->IVX) - $cop_seq_base; + my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base; + my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base; $finish = "end" if $finish == 999999999 - $cop_seq_base; $h{targarglife} = "$h{targarg}:$intro,$finish"; } @@ -747,7 +843,7 @@ sub concise_op { } else { $h{arg} = "($precomp)"; } - } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { + } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') { $h{arg} = '("' . $op->pv . '")'; $h{svval} = '"' . $op->pv . '"'; } elsif ($h{class} eq "COP") { @@ -755,12 +851,20 @@ sub concise_op { $h{coplabel} = $label; $label = $label ? "$label: " : ""; my $loc = $op->file; + my $pathnm = $loc; $loc =~ s[.*/][]; - $loc .= ":" . $op->line; + my $ln = $op->line; + $loc .= ":$ln"; my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); - my $arybase = $op->arybase; - $arybase = $arybase ? ' $[=' . $arybase : ""; - $h{arg} = "($label$stash $cseq $loc$arybase)"; + $h{arg} = "($label$stash $cseq $loc)"; + if ($show_src) { + fill_srclines($pathnm) unless exists $srclines{$pathnm}; + # Would love to retain Jim's use of // but this code needs to be + # portable to 5.8.x + my $line = $srclines{$pathnm}[$ln]; + $line = "-src unavailable under -e" unless defined $line; + $h{src} = "$ln: $line"; + } } elsif ($h{class} eq "LOOP") { $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) . " redo->" . seq($op->redoop) . ")"; @@ -785,7 +889,6 @@ sub concise_op { $h{seq} = "" if $h{seq} eq "-"; if ($] > 5.009) { $h{opt} = $op->opt; - $h{static} = $op->static; $h{label} = $labels{$$op}; } else { $h{seqnum} = $op->seq; @@ -803,6 +906,12 @@ sub concise_op { $h{flags} = op_flags($op->flags); $h{privval} = $op->private; $h{private} = private_flags($h{name}, $op->private); + if ($op->can("hints")) { + $h{hintsval} = $op->hints; + $h{hints} = hints_flags($h{hintsval}); + } else { + $h{hintsval} = $h{hints} = ''; + } $h{addr} = sprintf("%#x", $$op); $h{typenum} = $op->type; $h{noise} = $linenoise[$op->type]; @@ -1017,11 +1126,11 @@ on threaded and un-threaded perls. =head1 OPTIONS Arguments that don't start with a hyphen are taken to be the names of -subroutines to print the OPs of; if no such functions are specified, -the main body of the program (outside any subroutines, and not -including use'd or require'd files) is rendered. Passing C, +subroutines to render; if no such functions are specified, the main +body of the program (outside any subroutines, and not including use'd +or require'd files) is rendered. Passing C, C, C, C, or C will cause all of the corresponding -special blocks to be printed. +special blocks to be printed. Arguments must follow options. Options affect how things are rendered (ie printed). They're presented here by their visual effect, 1st being strongest. They're grouped @@ -1150,14 +1259,49 @@ usual convention for Arabic numerals, and the default. =item B<-littleendian> -Print seqence numbers with the least significant digit first. This is +Print sequence numbers with the least significant digit first. This is obviously mutually exclusive with bigendian. =back =head2 Other options -These are pairwise exclusive. +=over 4 + +=item B<-src> + +With this option, the rendering of each statement (starting with the +nextstate OP) will be preceded by the 1st line of source code that +generates it. For example: + + 1 <0> enter + # 1: my $i; + 2 <;> nextstate(main 1 junk.pl:1) v:{ + 3 <0> padsv[$i:1,10] vM/LVINTRO + # 3: for $i (0..9) { + 4 <;> nextstate(main 3 junk.pl:3) v:{ + 5 <0> pushmark s + 6 <$> const[IV 0] s + 7 <$> const[IV 9] s + 8 <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS + k <0> iter s + l <|> and(other->9) vK/1 + # 4: print "line "; + 9 <;> nextstate(main 2 junk.pl:4) v + a <0> pushmark s + b <$> const[PV "line "] s + c <@> print vK + # 5: print "$i\n"; + ... + +=item B<-stash="somepackage"> + +With this, "somepackage" will be required, then the stash is +inspected, and each function is rendered. + +=back + +The following options are pairwise exclusive. =over 4 @@ -1393,6 +1537,36 @@ The OP's flags, abbreviated as a series of symbols. The numeric value of the OP's flags. +=item B<#hints> + +The COP's hint flags, rendered with abbreviated names if possible. An empty +string if this is not a COP. Here are the symbols used: + + $ strict refs + & strict subs + * strict vars + i integers + l locale + b bytes + { block scope + % localise %^H + < open in + > open out + I overload int + F overload float + B overload binary + S overload string + R overload re + T taint + E eval + X filetest access + U utf-8 + +=item B<#hintsval> + +The numeric value of the COP's hint flags, or an empty string if this is not +a COP. + =item B<#hyphseq> The sequence number of the OP, or a hyphen if it doesn't have one. @@ -1454,13 +1628,6 @@ Whether or not the op has been optimised by the peephole optimiser. Only available in 5.9 and later. -=item B<#static> - -Whether or not the op is statically defined. This flag is used by the -B::C compiler backend and indicates that the op should not be freed. - -Only available in 5.9 and later. - =item B<#sibaddr> The address of the OP's next youngest sibling, in hexadecimal. @@ -1530,7 +1697,14 @@ This is B similar to previous, only the first two ops differ. This subroutine rendering is more representative, insofar as a single main program will have many subs. +=item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()' +This renders all functions in the B::Concise package with the source +lines. It eschews the O framework so that the stashref can be passed +directly to B::Concise::compile(). See -stash option for a more +convenient way to render a package. + +=back =head1 Using B::Concise outside of the O framework @@ -1573,14 +1747,14 @@ This restores one of the standard line-styles: C, C, C, C, C, into effect. It also accepts style names previously defined with add_style(). -=head2 add_style() +=head2 add_style () This subroutine accepts a new style name and three style arguments as above, and creates, registers, and selects the newly named style. It is an error to re-add a style; call set_style_standard() to switch between several styles. -=head2 add_callback() +=head2 add_callback () If your newly minted styles refer to any new #variables, you'll need to define a callback subroutine that will populate (or modify) those