use Exporter (); # use #5
-our $VERSION = "0.67";
+our $VERSION = "0.992";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
# 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" =>
"(*( )*)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" =>
"gt_#seq ",
"(?(#seq)?)#noise#arg(?([#targarg])?)"],
"debug" =>
- ["#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"
+ ["#class (#addr)\n\top_next\t\t#nextaddr\n\t(?(op_other\t#otheraddr\n\t)?)"
+ . "op_sibling\t#sibaddr\n\t"
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\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",
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
my $codeobj = svref_2object($coderef);
return concise_stashref(@_)
- unless ref $codeobj eq 'B::CV';
+ unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
concise_cv_obj($order, $codeobj, $name);
}
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 $@;
}
}
[" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
);
+my @render_packs; # collect -stash=<packages>
sub compileOpts {
# set rendering state from options and args
} elsif ($o eq "-littleendian") {
$big_endian = 0;
}
+ # miscellaneous, presentation
elsif ($o eq "-nobanner") {
$banner = 0;
} elsif ($o eq "-banner") {
$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)}) {
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") ?
}
else {
# convert function names to subrefs
- my $objref;
if (ref $objname) {
print $walkHandle "B::Concise::compile($objname)\n"
if $banner;
- $objref = $objname;
+ concise_subref($order, ($objname)x2);
+ next;
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
no strict 'refs';
- unless (exists &$objname) {
+ my $glob = \*$objname;
+ unless (*$glob{CODE} || *$glob{FORMAT}) {
+ print $walkHandle "$objname:\n" if $banner;
print $walkHandle "err: unknown function ($objname)\n";
return;
}
- $objref = \&$objname;
+ if (my $objref = *$glob{CODE}) {
+ print $walkHandle "$objname:\n" if $banner;
+ concise_subref($order, $objref, $objname);
+ }
+ if (my $objref = *$glob{FORMAT}) {
+ print $walkHandle "$objname (FORMAT):\n"
+ if $banner;
+ concise_subref($order, $objref, $objname);
+ }
}
- 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);
}
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
push @$targ, $ar;
push @todo, [$op->pmreplstart, $ar];
} elsif ($name =~ /^enter(loop|iter)$/) {
- if ($] > 5.009) {
- $labels{${$op->nextop}} = "NEXT";
- $labels{${$op->lastop}} = "LAST";
- $labels{${$op->redoop}} = "REDO";
- } else {
- $labels{$op->nextop->seq} = "NEXT";
- $labels{$op->lastop->seq} = "LAST";
- $labels{$op->redoop->seq} = "REDO";
- }
+ $labels{${$op->nextop}} = "NEXT";
+ $labels{${$op->lastop}} = "LAST";
+ $labels{${$op->redoop}} = "REDO";
}
}
}
$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
}
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");
-$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
-$priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = "PHASH" if $] < 5.009;
-$priv{"sassign"}{64} = "BKWARD";
-$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
-@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
- "COMPL", "GROWS");
-$priv{"repeat"}{64} = "DOLIST";
-$priv{"leaveloop"}{64} = "CONT";
-@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
- for (qw(rv2gv rv2sv padsv aelem helem));
-@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
-@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
-$priv{"gv"}{32} = "EARLYCV";
-$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
-$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
- "enteriter");
+ for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen
+ aelem helem aslice hslice padsv padav padhv enteriter entersub
+ padrange pushmark);
+$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite);
+$priv{$_}{128} = "LV" for qw(leave leaveloop);
+@{$priv{aassign}}{32,64} = qw(STATE COMMON);
+@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV);
+$priv{$_}{64} = "RTIME" for qw(match subst substcont qr);
+@{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS)
+ for qw(trans transr);
+$priv{repeat}{64} = "DOLIST";
+$priv{leaveloop}{64} = "CONT";
+@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV)
+ for qw(rv2gv rv2sv padsv aelem helem);
+$priv{$_}{16} = "STATE" for qw(padav padhv padsv);
+@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE);
+@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF);
+@{$priv{rv2cv}}{64,8,128} = qw(CONST AMPER NO());
+$priv{gv}{32} = "EARLYCV";
+$priv{$_}{16} = "LVDEFER" for qw(aelem helem);
+$priv{$_}{16} = "OURINTR" for qw(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{$_}{4} = "SLICEWARN"
+ for qw(rv2hv rv2av padav padhv hslice aslice);
+@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv);
+$priv{substr}{16} = "REPL1ST";
$priv{$_}{16} = "TARGMY"
- for (map(($_,"s$_"),"chop", "chomp"),
- map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
- "add", "subtract", "negate"), "pow", "concat", "stringify",
- "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
- "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
- "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
- "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
- "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
- "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
- "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{"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{"threadsv"}{64} = "SVREFd";
-@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
- for ("open", "backtick");
-$priv{"exit"}{128} = "VMS";
+ for map(($_,"s$_"), qw(chop chomp)),
+ map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add
+ subtract negate)),
+ qw(pow concat stringify left_shift right_shift bit_and bit_xor
+ bit_or complement atan2 sin cos rand exp log sqrt int hex oct
+ abs length index rindex sprintf ord chr crypt quotemeta join
+ push unshift flock chdir chown chroot unlink chmod utime rename
+ link symlink mkdir rmdir wait waitpid system exec kill getppid
+ getpgrp setpgrp getpriority setpriority time sleep);
+$priv{$_}{4} = "REVERSED" for qw(enteriter iter);
+@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE);
+$priv{$_}{64} = "LINENUM" for qw(flip flop);
+$priv{list}{64} = "GUESSED";
+$priv{delete}{64} = "SLICE";
+$priv{exists}{64} = "SUB";
+@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE);
+$priv{reverse}{8} = "INPLACE";
+$priv{threadsv}{64} = "SVREFd";
+@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR)
+ for qw(open backtick);
+$priv{$_}{32} = "HUSH" for qw(nextstate dbstate);
$priv{$_}{2} = "FTACCESS"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
-$priv{"entereval"}{2} = "HAS_HH";
-if ($] >= 5.009) {
- # Stacked filetests are post 5.8.x
- $priv{$_}{4} = "FTSTACKED"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
- "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
- "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
- "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
- "ftbinary");
- # Lexical $_ is post 5.8.x
- $priv{$_}{2} = "GREPLEX"
- for ("mapwhile", "mapstart", "grepwhile", "grepstart");
-}
-
-sub private_flags {
- my($name, $x) = @_;
+ for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec);
+@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH);
+@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt)
+ for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned
+ ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr
+ ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty
+ fttext ftbinary);
+$priv{$_}{2} = "GREPLEX"
+ for qw(mapwhile mapstart grepwhile grepstart);
+$priv{$_}{128} = "+1" for qw(caller wantarray runcv);
+@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK);
+$priv{$_}{128} = "UTF" for qw(last redo next goto dump);
+$priv{split}{128} = "IMPLIM";
+
+our %hints; # used to display each COP's op_hints values
+
+# strict refs, subs, vars
+@hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
+# 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);
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;
+ my $stash = $gv->STASH;
+ if (class($stash) eq "SPECIAL") {
+ $stash = "<none>";
+ }
+ else {
+ $stash = $stash->NAME;
+ }
if ($stash eq "main") {
$stash = "";
} else {
$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];
- } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+ } elsif ($preferpv
+ && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
$hr->{svval} .= cstring($sv->PV);
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
$hr->{svval} .= $sv->int_value;
- } elsif ($sv->FLAGS & SVf_POK) {
+ } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
$hr->{svval} .= cstring($sv->PV);
} elsif (class($sv) eq "HV") {
$hr->{svval} .= 'HASH';
}
}
+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;
$h{targarglife} = $h{targarg} = "$h{targ} $refs";
}
} elsif ($h{targ}) {
- my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
- if (defined $padname and class($padname) ne "SPECIAL") {
- $h{targarg} = $padname->PVX;
- if ($padname->FLAGS & SVf_FAKE) {
- if ($] < 5.009) {
- $h{targarglife} = "$h{targarg}:FAKE";
- } else {
+ my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+ my (@targarg, @targarglife);
+ for my $i (0..$count-1) {
+ my ($targarg, $targarglife);
+ my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
+ if (defined $padname and class($padname) ne "SPECIAL") {
+ $targarg = $padname->PVX;
+ if ($padname->FLAGS & SVf_FAKE) {
# 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;
- $h{targarglife} = "$h{targarg}:FAKE:$fake";
+ $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;
+ $targarglife = "$targarg:FAKE:$fake";
}
+ else {
+ 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;
+ $targarglife = "$targarg:$intro,$finish";
+ }
+ } else {
+ $targarglife = $targarg = "t" . ($h{targ}+$i);
}
- else {
- my $intro = $padname->NVX - $cop_seq_base;
- my $finish = int($padname->IVX) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $h{targarglife} = "$h{targarg}:$intro,$finish";
- }
- } else {
- $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ push @targarg, $targarg;
+ push @targarglife, $targarglife;
}
+ $h{targarg} = join '; ', @targarg;
+ $h{targarglife} = join '; ', @targarglife;
}
$h{arg} = "";
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
+ my $extra = '';
my $precomp = $op->precomp;
if (defined $precomp) {
$precomp = cstring($precomp); # Escape literal control sequences
} else {
$precomp = "";
}
- my $pmreplroot = $op->pmreplroot;
- my $pmreplstart;
- if (ref($pmreplroot) eq "B::GV") {
+ if ($op->name eq 'subst') {
+ if (class($op->pmreplstart) ne "NULL") {
+ undef $lastnext;
+ $extra = " replstart->" . seq($op->pmreplstart);
+ }
+ }
+ elsif ($op->name eq 'pushre') {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in /pat/'s pmreplroot.
- $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
- } elsif (!ref($pmreplroot) and $pmreplroot) {
- # same as the last case, except the value is actually a
- # pad offset for where the GV is kept (this happens under
- # ithreads)
- my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
- $h{arg} = "($precomp => \@" . $gv->NAME . ")";
- } elsif ($ {$op->pmreplstart}) {
- undef $lastnext;
- $pmreplstart = "replstart->" . seq($op->pmreplstart);
- $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
- } else {
- $h{arg} = "($precomp)";
+ my $gv = $op->pmreplroot;
+ if (!ref($gv)) {
+ # threaded: the value is actually a pad offset for where
+ # the GV is kept (op_pmtargetoff)
+ if ($gv) {
+ $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
+ }
+ }
+ else {
+ # unthreaded: its a GV (if it exists)
+ $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
+ }
+ $extra = " => \@$gv" if $gv;
}
- } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+ $h{arg} = "($precomp$extra)";
+ } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
$h{arg} = '("' . $op->pv . '")';
$h{svval} = '"' . $op->pv . '"';
} elsif ($h{class} eq "COP") {
$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) . ")";
} elsif ($h{class} eq "LOGOP") {
undef $lastnext;
$h{arg} = "(other->" . seq($op->other) . ")";
+ $h{otheraddr} = sprintf("%#x", $ {$op->other});
}
elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
}
$h{seq} = $h{hyphseq} = seq($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;
- $h{label} = $labels{$op->seq};
- }
+ $h{opt} = $op->opt;
+ $h{label} = $labels{$$op};
$h{next} = $op->next;
$h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
$h{nextaddr} = sprintf("%#x", $ {$op->next});
$h{flags} = op_flags($op->flags);
$h{privval} = $op->private;
$h{private} = private_flags($h{name}, $op->private);
+ if ($op->folded) {
+ $h{private} &&= "$h{private},";
+ $h{private} .= "FOLD";
+ }
+ 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];
=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<BEGIN>,
+subroutines or formats 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<BEGIN>, C<UNITCHECK>,
C<CHECK>, C<INIT>, or C<END> 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
=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
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
+ x$ explicit use/no strict refs
+ x& explicit use/no strict subs
+ x* explicit use/no 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.
=item B<#opt>
-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.
+Whether or not the op has been optimized by the peephole optimizer.
Only available in 5.9 and later.
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
C<linenoise>, C<debug>, C<env>, 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
another open filehandle, or into a string passed as a ref (unless
you've built perl with -Uuseperlio).
- my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
- walk_output(\my $buf);
- $walker->(); # 1 renders -terse
- set_style_standard('concise'); # 2
- $walker->(); # 2 renders -concise
- $walker->(@new); # 3 renders whatever
- print "3 different renderings: terse, concise, and @new: $buf\n";
+ my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
+ walk_output(\my $buf);
+ $walker->(); # 1 renders -terse
+ set_style_standard('concise'); # 2
+ $walker->(); # 2 renders -concise
+ $walker->(@new); # 3 renders whatever
+ print "3 different renderings: terse, concise, and @new: $buf\n";
When $walker is called, it traverses the subroutines supplied when it
was created, and renders them using the current style. You can change
https://perl5.git.perl.org / perl5.git / blobdiff