summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B/Concise.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Concise.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Concise.pm1836
1 files changed, 1836 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm
new file mode 100644
index 00000000000..26996058941
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Concise.pm
@@ -0,0 +1,1836 @@
+package B::Concise;
+# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
+# This program is free software; you can redistribute and/or modify it
+# under the same terms as Perl itself.
+
+# Note: we need to keep track of how many use declarations/BEGIN
+# blocks this module uses, so we can avoid printing them when user
+# asks for the BEGIN blocks in her program. Update the comments and
+# the count in concise_specials if you add or delete one. The
+# -MO=Concise counts as use #1.
+
+use strict; # use #2
+use warnings; # uses #3 and #4, since warnings uses Carp
+
+use Exporter (); # use #5
+
+our $VERSION = "0.78";
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw( set_style set_style_standard add_callback
+ concise_subref concise_cv concise_main
+ add_style walk_output compile reset_sequence );
+our %EXPORT_TAGS =
+ ( io => [qw( walk_output compile reset_sequence )],
+ style => [qw( add_style set_style_standard )],
+ cb => [qw( add_callback )],
+ mech => [qw( 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 PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
+
+my %style =
+ ("terse" =>
+ ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
+ . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
+ "(*( )*)goto #class (#addr)\n",
+ "#class pp_#name"],
+ "concise" =>
+ ["#hyphseq2 (*( (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)"
+ . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n"
+ , " (*( )*) goto #seq\n",
+ "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
+ "linenoise" =>
+ ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
+ "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\t#hintsval\n"
+ . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
+ . "(?(\top_sv\t\t#svaddr\n)?)",
+ " GOTO #addr\n",
+ "#addr"],
+ "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
+ $ENV{B_CONCISE_TREE_FORMAT}],
+ );
+
+# Renderings, ie how Concise prints, is controlled by these vars
+# primary:
+our $stylename; # selects current style from %style
+my $order = "basic"; # how optree is walked & printed: basic, exec, tree
+
+# rendering mechanics:
+# these 'formats' are the line-rendering templates
+# they're updated from %style when $stylename changes
+my ($format, $gotofmt, $treefmt);
+
+# lesser players:
+my $base = 36; # how <sequence#> is displayed
+my $big_endian = 1; # more <sequence#> 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
+
+set_style_standard("concise");
+
+my $curcv;
+my $cop_seq_base;
+
+sub set_style {
+ ($format, $gotofmt, $treefmt) = @_;
+ #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+ die "style '$newstyle' already exists, choose a new name\n"
+ if exists $style{$newstyle};
+ die "expecting 3 style-format args\n" unless @args == 3;
+ $style{$newstyle} = [@args];
+ $stylename = $newstyle; # update rendering state
+}
+
+sub set_style_standard {
+ ($stylename) = @_; # update rendering state
+ die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
+ set_style(@{$style{$stylename}});
+}
+
+sub add_callback {
+ push @callbacks, @_;
+}
+
+# output handle, used with all Concise-output printing
+our $walkHandle; # public for your convenience
+BEGIN { $walkHandle = \*STDOUT }
+
+sub walk_output { # updates $walkHandle
+ my $handle = shift;
+ return $walkHandle unless $handle; # allow use as accessor
+
+ if (ref $handle eq 'SCALAR') {
+ require Config;
+ die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
+ unless $Config::Config{useperlio};
+ # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
+ open my $tmp, '>', $handle; # but cant re-set existing STDOUT
+ $walkHandle = $tmp; # so use my $tmp as intermediate var
+ return $walkHandle;
+ }
+ my $iotype = ref $handle;
+ die "expecting argument/object that can print\n"
+ unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
+ $walkHandle = $handle;
+}
+
+sub concise_subref {
+ my($order, $coderef, $name) = @_;
+ my $codeobj = svref_2object($coderef);
+
+ return concise_stashref(@_)
+ unless ref $codeobj eq 'B::CV';
+ concise_cv_obj($order, $codeobj, $name);
+}
+
+sub concise_stashref {
+ my($order, $h) = @_;
+ local *s;
+ foreach my $k (sort keys %$h) {
+ 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, $k) };
+ warn "err $@ on $codeobj" if $@;
+ }
+}
+
+# This should have been called concise_subref, but it was exported
+# under this name in versions before 0.56
+*concise_cv = \&concise_subref;
+
+sub concise_cv_obj {
+ my ($order, $cv, $name) = @_;
+ # name is either a string, or a CODE ref (copy of $cv arg??)
+
+ $curcv = $cv;
+
+ if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
+ print $walkHandle "$name is a constant sub, optimized to a $1\n";
+ return;
+ }
+ if ($cv->XSUB) {
+ print $walkHandle "$name is XS code\n";
+ return;
+ }
+ if (class($cv->START) eq "NULL") {
+ no strict 'refs';
+ if (ref $name eq 'CODE') {
+ print $walkHandle "coderef $name has no START\n";
+ }
+ elsif (exists &$name) {
+ print $walkHandle "$name exists in stash, but has no START\n";
+ }
+ else {
+ print $walkHandle "$name not in symbol table\n";
+ }
+ return;
+ }
+ sequence($cv->START);
+ if ($order eq "exec") {
+ walk_exec($cv->START);
+ }
+ elsif ($order eq "basic") {
+ # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+ my $root = $cv->ROOT;
+ unless (ref $root eq 'B::NULL') {
+ walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
+ } else {
+ print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
+ }
+ } else {
+ print $walkHandle tree($cv->ROOT, 0);
+ }
+}
+
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print $walkHandle tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
+sub concise_specials {
+ my($name, $order, @cv_s) = @_;
+ my $i = 1;
+ if ($name eq "BEGIN") {
+ splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
+ } elsif ($name eq "CHECK") {
+ pop @cv_s; # skip the CHECK block that calls us
+ }
+ for my $cv (@cv_s) {
+ print $walkHandle "$name $i:\n";
+ $i++;
+ concise_cv_obj($order, $cv, $name);
+ }
+}
+
+my $start_sym = "\e(0"; # "\cN" sometimes also works
+my $end_sym = "\e(B"; # "\cO" respectively
+
+my @tree_decorations =
+ ([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
+ [" ", "-", "+", "+", "|", "`", "", 0],
+ [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
+ [" ", 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
+ my (@options,@args);
+ if (@_) {
+ @options = grep(/^-/, @_);
+ @args = grep(!/^-/, @_);
+ }
+ for my $o (@options) {
+ # mode/order
+ if ($o eq "-basic") {
+ $order = "basic";
+ } elsif ($o eq "-exec") {
+ $order = "exec";
+ } elsif ($o eq "-tree") {
+ $order = "tree";
+ }
+ # tree-specific
+ elsif ($o eq "-compact") {
+ $tree_style |= 1;
+ } elsif ($o eq "-loose") {
+ $tree_style &= ~1;
+ } elsif ($o eq "-vt") {
+ $tree_style |= 2;
+ } elsif ($o eq "-ascii") {
+ $tree_style &= ~2;
+ }
+ # sequence numbering
+ elsif ($o =~ /^-base(\d+)$/) {
+ $base = $1;
+ } elsif ($o eq "-bigendian") {
+ $big_endian = 1;
+ } elsif ($o eq "-littleendian") {
+ $big_endian = 0;
+ }
+ # miscellaneous, presentation
+ elsif ($o eq "-nobanner") {
+ $banner = 0;
+ } elsif ($o eq "-banner") {
+ $banner = 1;
+ }
+ elsif ($o eq "-main") {
+ $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 staticly linked to, but hasn't
+ # yet been used.
+ eval "require $pkg";
+ }
+ }
+ push @render_packs, $pkg;
+ }
+ # line-style options
+ elsif (exists $style{substr($o, 1)}) {
+ $stylename = substr($o, 1);
+ set_style_standard($stylename);
+ } else {
+ warn "Option $o unrecognized";
+ }
+ }
+ return (@args);
+}
+
+sub compile {
+ my (@args) = compileOpts(@_);
+ return sub {
+ my @newargs = compileOpts(@_); # accept new rendering options
+ warn "disregarding non-options: @newargs\n" if @newargs;
+
+ for my $objname (@args) {
+ next unless $objname; # skip null args to avoid noisy responses
+
+ if ($objname eq "BEGIN") {
+ concise_specials("BEGIN", $order,
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
+ } elsif ($objname eq "INIT") {
+ concise_specials("INIT", $order,
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
+ } elsif ($objname eq "CHECK") {
+ 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") ?
+ B::end_av->ARRAY : ());
+ }
+ else {
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n"
+ if $banner;
+ $objref = $objname;
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ unless (exists &$objname) {
+ print $walkHandle "err: unknown function ($objname)\n";
+ return;
+ }
+ $objref = \&$objname;
+ }
+ concise_subref($order, $objref, $objname);
+ }
+ }
+ 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);
+ }
+ return @args; # something
+ }
+}
+
+my %labels;
+my $lastnext; # remembers op-chain, used to insert gotos
+
+my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
+ 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
+ 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
+
+no warnings 'qw'; # "Possible attempt to put comments..."; use #7
+my @linenoise =
+ qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
+ ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
+ -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
+ > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
+ ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
+ uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
+ a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
+ v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
+ ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
+ ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
+ -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
+ co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
+ g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
+ e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
+ Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
+
+my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+sub op_flags { # common flags (see BASOP.op_flags in op.h)
+ my($x) = @_;
+ my(@v);
+ push @v, "v" if ($x & 3) == 1;
+ push @v, "s" if ($x & 3) == 2;
+ push @v, "l" if ($x & 3) == 3;
+ push @v, "K" if $x & 4;
+ push @v, "P" if $x & 8;
+ push @v, "R" if $x & 16;
+ push @v, "M" if $x & 32;
+ push @v, "S" if $x & 64;
+ push @v, "*" if $x & 128;
+ return join("", @v);
+}
+
+sub base_n {
+ my $x = shift;
+ return "-" . base_n(-$x) if $x < 0;
+ my $str = "";
+ do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
+ $str = reverse $str if $big_endian;
+ return $str;
+}
+
+my %sequence_num;
+my $seq_max = 1;
+
+sub reset_sequence {
+ # reset the sequence
+ %sequence_num = ();
+ $seq_max = 1;
+ $lastnext = 0;
+}
+
+sub seq {
+ my($op) = @_;
+ return "-" if not exists $sequence_num{$$op};
+ return base_n($sequence_num{$$op});
+}
+
+sub walk_topdown {
+ my($op, $sub, $level) = @_;
+ $sub->($op, $level);
+ if ($op->flags & OPf_KIDS) {
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walk_topdown($kid, $sub, $level + 1);
+ }
+ }
+ elsif (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
+ # else stored here for lack of space elsewhere
+ walk_topdown($maybe_root, $sub, $level + 1);
+ }
+ }
+}
+
+sub walklines {
+ my($ar, $level) = @_;
+ for my $l (@$ar) {
+ if (ref($l) eq "ARRAY") {
+ walklines($l, $level + 1);
+ } else {
+ $l->concise($level);
+ }
+ }
+}
+
+sub walk_exec {
+ my($top, $level) = @_;
+ my %opsseen;
+ my @lines;
+ my @todo = ([$top, \@lines]);
+ while (@todo and my($op, $targ) = @{shift @todo}) {
+ for (; $$op; $op = $op->next) {
+ last if $opsseen{$$op}++;
+ push @$targ, $op;
+ my $name = $op->name;
+ if (class($op) eq "LOGOP") {
+ my $ar = [];
+ push @$targ, $ar;
+ push @todo, [$op->other, $ar];
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $ar = [];
+ 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";
+ }
+ }
+ }
+ }
+ walklines(\@lines, 0);
+}
+
+# The structure of this routine is purposely modeled after op.c's peep()
+sub sequence {
+ my($op) = @_;
+ my $oldop = 0;
+ return if class($op) eq "NULL" or exists $sequence_num{$$op};
+ for (; $$op; $op = $op->next) {
+ last if exists $sequence_num{$$op};
+ my $name = $op->name;
+ if ($name =~ /^(null|scalar|lineseq|scope)$/) {
+ next if $oldop and $ {$op->next};
+ } else {
+ $sequence_num{$$op} = $seq_max++;
+ if (class($op) eq "LOGOP") {
+ my $other = $op->other;
+ $other = $other->next while $other->name eq "null";
+ sequence($other);
+ } elsif (class($op) eq "LOOP") {
+ my $redoop = $op->redoop;
+ $redoop = $redoop->next while $redoop->name eq "null";
+ sequence($redoop);
+ my $nextop = $op->nextop;
+ $nextop = $nextop->next while $nextop->name eq "null";
+ sequence($nextop);
+ my $lastop = $op->lastop;
+ $lastop = $lastop->next while $lastop->name eq "null";
+ sequence($lastop);
+ } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+ my $replstart = $op->pmreplstart;
+ $replstart = $replstart->next while $replstart->name eq "null";
+ sequence($replstart);
+ }
+ }
+ $oldop = $op;
+ }
+}
+
+sub fmt_line { # generate text-line for op.
+ my($hr, $op, $text, $level) = @_;
+
+ $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
+
+ return '' if $hr->{SKIP}; # suppress line if a callback said so
+ return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
+
+ # spec: (?(text1#varText2)?)
+ $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
+ $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+
+ # spec: (x(exec_text;basic_text)x)
+ $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
+
+ # spec: (*(text)*)
+ $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
+
+ # spec: (*(text1;text2)*)
+ $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
+
+ # convert #Var to tag=>val form: Var\t#var
+ $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
+
+ # spec: #varN
+ $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
+
+ $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; # 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} = $] < 5.009 ? "PHASH" : "STATE";
+$priv{"sassign"}{32} = "STATE";
+$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{$_}{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{"gv"}{32} = "EARLYCV";
+$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
+$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
+ "enteriter");
+$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{"reverse"}{8} = "INPLACE";
+$priv{"threadsv"}{64} = "SVREFd";
+@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
+ for ("open", "backtick");
+$priv{"exit"}{128} = "VMS";
+$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");
+}
+
+our %hints; # used to display each COP's op_hints values
+
+# strict refs, subs, vars
+@hints{2,512,1024} = ('$', '&', '*');
+# integers, locale, bytes, arybase
+@hints{1,4,8,16,32} = ('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 (sort {$b <=> $a} keys %$hash) {
+ if ($hash->{$flag} and $x & $flag and $x >= $flag) {
+ $x -= $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);
+ $hr->{svclass} = "UV"
+ 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" && $sv->isGV_with_GP()) {
+ my $gv = $sv;
+ my $stash = $gv->STASH->NAME; if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ $hr->{svval} = "*$stash" . $gv->SAFENAME;
+ return "*$stash" . $gv->SAFENAME;
+ } else {
+ 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) {
+ $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) {
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
+ }
+
+ $hr->{svval} = 'undef' unless defined $hr->{svval};
+ my $out = $hr->{svclass};
+ return $out .= " $hr->{svval}" ;
+ }
+}
+
+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{exname} = $h{name} = $op->name;
+ $h{NAME} = uc $h{name};
+ $h{class} = class($op);
+ $h{extarg} = $h{targ} = $op->targ;
+ $h{extarg} = "" unless $h{extarg};
+ if ($h{name} eq "null" and $h{targ}) {
+ # targ holds the old type
+ $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
+ $h{extarg} = "";
+ } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
+ # targ potentially holds a reference count
+ if ($op->private & 64) {
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $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 {
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $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;
+ $h{targarglife} = "$h{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;
+ $h{targarglife} = "$h{targarg}:$intro,$finish";
+ }
+ } else {
+ $h{targarglife} = $h{targarg} = "t" . $h{targ};
+ }
+ }
+ $h{arg} = "";
+ $h{svclass} = $h{svaddr} = $h{svval} = "";
+ if ($h{class} eq "PMOP") {
+ my $precomp = $op->precomp;
+ if (defined $precomp) {
+ $precomp = cstring($precomp); # Escape literal control sequences
+ $precomp = "/$precomp/";
+ } else {
+ $precomp = "";
+ }
+ my $pmreplroot = $op->pmreplroot;
+ my $pmreplstart;
+ if (ref($pmreplroot) eq "B::GV") {
+ # 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)";
+ }
+ } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+ $h{arg} = '("' . $op->pv . '")';
+ $h{svval} = '"' . $op->pv . '"';
+ } elsif ($h{class} eq "COP") {
+ my $label = $op->label;
+ $h{coplabel} = $label;
+ $label = $label ? "$label: " : "";
+ my $loc = $op->file;
+ my $pathnm = $loc;
+ $loc =~ s[.*/][];
+ 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)";
+ 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) . ")";
+ }
+ elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
+ unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
+ my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
+ my $preferpv = $h{name} eq "method_named";
+ if ($h{class} eq "PADOP" or !${$op->sv}) {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
+ $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
+ $h{targarglife} = $h{targarg} = "";
+ } else {
+ $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
+ }
+ }
+ }
+ $h{seq} = $h{hyphseq} = seq($op);
+ $h{seq} = "" if $h{seq} eq "-";
+ if ($] > 5.009) {
+ $h{opt} = $op->opt;
+ $h{label} = $labels{$$op};
+ } else {
+ $h{seqnum} = $op->seq;
+ $h{label} = $labels{$op->seq};
+ }
+ $h{next} = $op->next;
+ $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
+ $h{nextaddr} = sprintf("%#x", $ {$op->next});
+ $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
+ $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
+ $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
+
+ $h{classsym} = $opclass{$h{class}};
+ $h{flagval} = $op->flags;
+ $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];
+
+ return fmt_line(\%h, $op, $format, $level);
+}
+
+sub B::OP::concise {
+ my($op, $level) = @_;
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto' line
+ my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext),
+ "goto" => seq($lastnext), # simplify goto '-' removal
+ };
+ print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
+ }
+ $lastnext = $op->next;
+ print $walkHandle concise_op($op, $level, $format);
+}
+
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto'
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print # $walkHandle
+ fmt_line($h, $op, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print # $walkHandle
+ concise_op($op, $level, $style{"terse"}[0]);
+}
+
+sub tree {
+ my $op = shift;
+ my $level = shift;
+ my $style = $tree_decorations[$tree_style];
+ my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
+ my $name = concise_op($op, $level, $treefmt);
+ if (not $op->flags & OPf_KIDS) {
+ return $name . "\n";
+ }
+ my @lines;
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ push @lines, tree($kid, $level+1);
+ }
+ my $i;
+ for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
+ $lines[$i] = $space . $lines[$i];
+ }
+ if ($i > 0) {
+ $lines[$i] = $last . $lines[$i];
+ while ($i-- > 1) {
+ if (substr($lines[$i], 0, 1) eq " ") {
+ $lines[$i] = $nokid . $lines[$i];
+ } else {
+ $lines[$i] = $kid . $lines[$i];
+ }
+ }
+ $lines[$i] = $kids . $lines[$i];
+ } else {
+ $lines[0] = $single . $lines[0];
+ }
+ return("$name$lead" . shift @lines,
+ map(" " x (length($name)+$size) . $_, @lines));
+}
+
+# *** Warning: fragile kludge ahead ***
+# Because the B::* modules run in the same interpreter as the code
+# they're compiling, their presence tends to distort the view we have of
+# the code we're looking at. In particular, perl gives sequence numbers
+# to COPs. If the program we're looking at were run on its own, this
+# would start at 1. Because all of B::Concise and all the modules it
+# uses are compiled first, though, by the time we get to the user's
+# program the sequence number is already pretty high, which could be
+# distracting if you're trying to tell OPs apart. Therefore we'd like to
+# subtract an offset from all the sequence numbers we display, to
+# restore the simpler view of the world. The trick is to know what that
+# offset will be, when we're still compiling B::Concise! If we
+# hardcoded a value, it would have to change every time B::Concise or
+# other modules we use do. To help a little, what we do here is compile
+# a little code at the end of the module, and compute the base sequence
+# number for the user's program as being a small offset later, so all we
+# have to worry about are changes in the offset.
+
+# [For 5.8.x and earlier perl is generating sequence numbers for all ops,
+# and using them to reference labels]
+
+
+# When you say "perl -MO=Concise -e '$a'", the output should look like:
+
+# 4 <@> leave[t1] vKP/REFC ->(end)
+# 1 <0> enter ->2
+ #^ smallest OP sequence number should be 1
+# 2 <;> nextstate(main 1 -e:1) v ->3
+ # ^ smallest COP sequence number should be 1
+# - <1> ex-rv2sv vK/1 ->4
+# 3 <$> gvsv(*a) s ->4
+
+# If the second of the marked numbers there isn't 1, it means you need
+# to update the corresponding magic number in the next line.
+# Remember, this needs to stay the last things in the module.
+
+# Why is this different for MacOS? Does it matter?
+my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
+$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Concise - Walk Perl syntax tree, printing concise info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Concise[,OPTIONS] foo.pl
+
+ use B::Concise qw(set_style add_callback);
+
+=head1 DESCRIPTION
+
+This compiler backend prints the internal OPs of a Perl program's syntax
+tree in one of several space-efficient text formats suitable for debugging
+the inner workings of perl or other compiler backends. It can print OPs in
+the order they appear in the OP tree, in the order they will execute, or
+in a text approximation to their tree structure, and the format of the
+information displayed is customizable. Its function is similar to that of
+perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
+sophisticated and flexible.
+
+=head1 EXAMPLE
+
+Here's two outputs (or 'renderings'), using the -exec and -basic
+(i.e. default) formatting conventions on the same code snippet.
+
+ % perl -MO=Concise,-exec -e '$a = $b + 42'
+ 1 <0> enter
+ 2 <;> nextstate(main 1 -e:1) v
+ 3 <#> gvsv[*b] s
+ 4 <$> const[IV 42] s
+ * 5 <2> add[t3] sK/2
+ 6 <#> gvsv[*a] s
+ 7 <2> sassign vKS/2
+ 8 <@> leave[1 ref] vKP/REFC
+
+In this -exec rendering, each opcode is executed in the order shown.
+The add opcode, marked with '*', is discussed in more detail.
+
+The 1st column is the op's sequence number, starting at 1, and is
+displayed in base 36 by default. Here they're purely linear; the
+sequences are very helpful when looking at code with loops and
+branches.
+
+The symbol between angle brackets indicates the op's type, for
+example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
+used in threaded perls. (see L</"OP class abbreviations">).
+
+The opname, as in B<'add[t1]'>, may be followed by op-specific
+information in parentheses or brackets (ex B<'[t1]'>).
+
+The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
+abbreviations">).
+
+ % perl -MO=Concise -e '$a = $b + 42'
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 1 <0> enter ->2
+ 2 <;> nextstate(main 1 -e:1) v ->3
+ 7 <2> sassign vKS/2 ->8
+ * 5 <2> add[t1] sK/2 ->6
+ - <1> ex-rv2sv sK/1 ->4
+ 3 <$> gvsv(*b) s ->4
+ 4 <$> const(IV 42) s ->5
+ - <1> ex-rv2sv sKRM*/1 ->7
+ 6 <$> gvsv(*a) s ->7
+
+The default rendering is top-down, so they're not in execution order.
+This form reflects the way the stack is used to parse and evaluate
+expressions; the add operates on the two terms below it in the tree.
+
+Nullops appear as C<ex-opname>, where I<opname> is an op that has been
+optimized away by perl. They're displayed with a sequence-number of
+'-', because they are not executed (they don't appear in previous
+example), they're printed here because they reflect the parse.
+
+The arrow points to the sequence number of the next op; they're not
+displayed in -exec mode, for obvious reasons.
+
+Note that because this rendering was done on a non-threaded perl, the
+PADOPs in the previous examples are now SVOPs, and some (but not all)
+of the square brackets have been replaced by round ones. This is a
+subtle feature to provide some visual distinction between renderings
+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 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. 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
+according to how they interrelate; within each group the options are
+mutually exclusive (unless otherwise stated).
+
+=head2 Options for Opcode Ordering
+
+These options control the 'vertical display' of opcodes. The display
+'order' is also called 'mode' elsewhere in this document.
+
+=over 4
+
+=item B<-basic>
+
+Print OPs in the order they appear in the OP tree (a preorder
+traversal, starting at the root). The indentation of each OP shows its
+level in the tree, and the '->' at the end of the line indicates the
+next opcode in execution order. This mode is the default, so the flag
+is included simply for completeness.
+
+=item B<-exec>
+
+Print OPs in the order they would normally execute (for the majority
+of constructs this is a postorder traversal of the tree, ending at the
+root). In most cases the OP that usually follows a given OP will
+appear directly below it; alternate paths are shown by indentation. In
+cases like loops when control jumps out of a linear path, a 'goto'
+line is generated.
+
+=item B<-tree>
+
+Print OPs in a text approximation of a tree, with the root of the tree
+at the left and 'left-to-right' order of children transformed into
+'top-to-bottom'. Because this mode grows both to the right and down,
+it isn't suitable for large programs (unless you have a very wide
+terminal).
+
+=back
+
+=head2 Options for Line-Style
+
+These options select the line-style (or just style) used to render
+each opcode, and dictates what info is actually printed into each line.
+
+=over 4
+
+=item B<-concise>
+
+Use the author's favorite set of formatting conventions. This is the
+default, of course.
+
+=item B<-terse>
+
+Use formatting conventions that emulate the output of B<B::Terse>. The
+basic mode is almost indistinguishable from the real B<B::Terse>, and the
+exec mode looks very similar, but is in a more logical order and lacks
+curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
+is only vaguely reminiscent of B<B::Terse>.
+
+=item B<-linenoise>
+
+Use formatting conventions in which the name of each OP, rather than being
+written out in full, is represented by a one- or two-character abbreviation.
+This is mainly a joke.
+
+=item B<-debug>
+
+Use formatting conventions reminiscent of B<B::Debug>; these aren't
+very concise at all.
+
+=item B<-env>
+
+Use formatting conventions read from the environment variables
+C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+
+=back
+
+=head2 Options for tree-specific formatting
+
+=over 4
+
+=item B<-compact>
+
+Use a tree format in which the minimum amount of space is used for the
+lines connecting nodes (one character in most cases). This squeezes out
+a few precious columns of screen real estate.
+
+=item B<-loose>
+
+Use a tree format that uses longer edges to separate OP nodes. This format
+tends to look better than the compact one, especially in ASCII, and is
+the default.
+
+=item B<-vt>
+
+Use tree connecting characters drawn from the VT100 line-drawing set.
+This looks better if your terminal supports it.
+
+=item B<-ascii>
+
+Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
+look as clean as the VT100 characters, but they'll work with almost any
+terminal (or the horizontal scrolling mode of less(1)) and are suitable
+for text documentation or email. This is the default.
+
+=back
+
+These are pairwise exclusive, i.e. compact or loose, vt or ascii.
+
+=head2 Options controlling sequence numbering
+
+=over 4
+
+=item B<-base>I<n>
+
+Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
+digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
+for 37 will be 'A', and so on until 62. Values greater than 62 are not
+currently supported. The default is 36.
+
+=item B<-bigendian>
+
+Print sequence numbers with the most significant digit first. This is the
+usual convention for Arabic numerals, and the default.
+
+=item B<-littleendian>
+
+Print seqence numbers with the least significant digit first. This is
+obviously mutually exclusive with bigendian.
+
+=back
+
+=head2 Other options
+
+=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
+
+=item B<-main>
+
+Include the main program in the output, even if subroutines were also
+specified. This rendering is normally suppressed when a subroutine
+name or reference is given.
+
+=item B<-nomain>
+
+This restores the default behavior after you've changed it with '-main'
+(it's not normally needed). If no subroutine name/ref is given, main is
+rendered, regardless of this flag.
+
+=item B<-nobanner>
+
+Renderings usually include a banner line identifying the function name
+or stringified subref. This suppresses the printing of the banner.
+
+TBC: Remove the stringified coderef; while it provides a 'cookie' for
+each function rendered, the cookies used should be 1,2,3.. not a
+random hex-address. It also complicates string comparison of two
+different trees.
+
+=item B<-banner>
+
+restores default banner behavior.
+
+=item B<-banneris> => subref
+
+TBC: a hookpoint (and an option to set it) for a user-supplied
+function to produce a banner appropriate for users needs. It's not
+ideal, because the rendering-state variables, which are a natural
+candidate for use in concise.t, are unavailable to the user.
+
+=back
+
+=head2 Option Stickiness
+
+If you invoke Concise more than once in a program, you should know that
+the options are 'sticky'. This means that the options you provide in
+the first call will be remembered for the 2nd call, unless you
+re-specify or change them.
+
+=head1 ABBREVIATIONS
+
+The concise style uses symbols to convey maximum info with minimal
+clutter (like hex addresses). With just a little practice, you can
+start to see the flowers, not just the branches, in the trees.
+
+=head2 OP class abbreviations
+
+These symbols appear before the op-name, and indicate the
+B:: namespace that represents the ops in your Perl code.
+
+ 0 OP (aka BASEOP) An OP with no children
+ 1 UNOP An OP with one child
+ 2 BINOP An OP with two children
+ | LOGOP A control branch OP
+ @ LISTOP An OP that could have lots of children
+ / PMOP An OP with a regular expression
+ $ SVOP An OP with an SV
+ " PVOP An OP with a string
+ { LOOP An OP that holds pointers for a loop
+ ; COP An OP that marks the start of a statement
+ # PADOP An OP with a GV on the pad
+
+=head2 OP flags abbreviations
+
+OP flags are either public or private. The public flags alter the
+behavior of each opcode in consistent ways, and are represented by 0
+or more single characters.
+
+ v OPf_WANT_VOID Want nothing (void context)
+ s OPf_WANT_SCALAR Want single value (scalar context)
+ l OPf_WANT_LIST Want list of any length (list context)
+ Want is unknown
+ K OPf_KIDS There is a firstborn child.
+ P OPf_PARENS This operator was parenthesized.
+ (Or block needs explicit scope entry.)
+ R OPf_REF Certified reference.
+ (Return container, not containee).
+ M OPf_MOD Will modify (lvalue).
+ S OPf_STACKED Some arg is arriving on the stack.
+ * OPf_SPECIAL Do something weird for this op (see op.h)
+
+Private flags, if any are set for an opcode, are displayed after a '/'
+
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
+ 7 <2> sassign vKS/2 ->8
+
+They're opcode specific, and occur less often than the public ones, so
+they're represented by short mnemonics instead of single-chars; see
+F<op.h> for gory details, or try this quick 2-liner:
+
+ $> perl -MB::Concise -de 1
+ DB<1> |x \%B::Concise::priv
+
+=head1 FORMATTING SPECIFICATIONS
+
+For each line-style ('concise', 'terse', 'linenoise', etc.) there are
+3 format-specs which control how OPs are rendered.
+
+The first is the 'default' format, which is used in both basic and exec
+modes to print all opcodes. The 2nd, goto-format, is used in exec
+mode when branches are encountered. They're not real opcodes, and are
+inserted to look like a closing curly brace. The tree-format is tree
+specific.
+
+When a line is rendered, the correct format-spec is copied and scanned
+for the following items; data is substituted in, and other
+manipulations like basic indenting are done, for each opcode rendered.
+
+There are 3 kinds of items that may be populated; special patterns,
+#vars, and literal text, which is copied verbatim. (Yes, it's a set
+of s///g steps.)
+
+=head2 Special Patterns
+
+These items are the primitives used to perform indenting, and to
+select text from amongst alternatives.
+
+=over 4
+
+=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
+
+Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
+
+=item B<(*(>I<text>B<)*)>
+
+Generates one copy of I<text> for each indentation level.
+
+=item B<(*(>I<text1>B<;>I<text2>B<)*)>
+
+Generates one fewer copies of I<text1> than the indentation level, followed
+by one copy of I<text2> if the indentation level is more than 0.
+
+=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
+
+If the value of I<var> is true (not empty or zero), generates the
+value of I<var> surrounded by I<text1> and I<Text2>, otherwise
+nothing.
+
+=item B<~>
+
+Any number of tildes and surrounding whitespace will be collapsed to
+a single space.
+
+=back
+
+=head2 # Variables
+
+These #vars represent opcode properties that you may want as part of
+your rendering. The '#' is intended as a private sigil; a #var's
+value is interpolated into the style-line, much like "read $this".
+
+These vars take 3 forms:
+
+=over 4
+
+=item B<#>I<var>
+
+A property named 'var' is assumed to exist for the opcodes, and is
+interpolated into the rendering.
+
+=item B<#>I<var>I<N>
+
+Generates the value of I<var>, left justified to fill I<N> spaces.
+Note that this means while you can have properties 'foo' and 'foo2',
+you cannot render 'foo2', but you could with 'foo2a'. You would be
+wise not to rely on this behavior going forward ;-)
+
+=item B<#>I<Var>
+
+This ucfirst form of #var generates a tag-value form of itself for
+display; it converts '#Var' into a 'Var => #var' style, which is then
+handled as described above. (Imp-note: #Vars cannot be used for
+conditional-fills, because the => #var transform is done after the check
+for #Var's value).
+
+=back
+
+The following variables are 'defined' by B::Concise; when they are
+used in a style, their respective values are plugged into the
+rendering of each opcode.
+
+Only some of these are used by the standard styles, the others are
+provided for you to delve into optree mechanics, should you wish to
+add a new style (see L</add_style> below) that uses them. You can
+also add new ones using L</add_callback>.
+
+=over 4
+
+=item B<#addr>
+
+The address of the OP, in hexadecimal.
+
+=item B<#arg>
+
+The OP-specific information of the OP (such as the SV for an SVOP, the
+non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
+
+=item B<#class>
+
+The B-determined class of the OP, in all caps.
+
+=item B<#classsym>
+
+A single symbol abbreviating the class of the OP.
+
+=item B<#coplabel>
+
+The label of the statement or block the OP is the start of, if any.
+
+=item B<#exname>
+
+The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
+
+=item B<#extarg>
+
+The target of the OP, or nothing for a nulled OP.
+
+=item B<#firstaddr>
+
+The address of the OP's first child, in hexadecimal.
+
+=item B<#flags>
+
+The OP's flags, abbreviated as a series of symbols.
+
+=item B<#flagval>
+
+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
+ [ arybase
+ { 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<#label>
+
+'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
+mode, or empty otherwise.
+
+=item B<#lastaddr>
+
+The address of the OP's last child, in hexadecimal.
+
+=item B<#name>
+
+The OP's name.
+
+=item B<#NAME>
+
+The OP's name, in all caps.
+
+=item B<#next>
+
+The sequence number of the OP's next OP.
+
+=item B<#nextaddr>
+
+The address of the OP's next OP, in hexadecimal.
+
+=item B<#noise>
+
+A one- or two-character abbreviation for the OP's name.
+
+=item B<#private>
+
+The OP's private flags, rendered with abbreviated names if possible.
+
+=item B<#privval>
+
+The numeric value of the OP's private flags.
+
+=item B<#seq>
+
+The sequence number of the OP. Note that this is a sequence number
+generated by B::Concise.
+
+=item B<#seqnum>
+
+5.8.x and earlier only. 5.9 and later do not provide this.
+
+The real sequence number of the OP, as a regular number and not adjusted
+to be relative to the start of the real program. (This will generally be
+a fairly large number because all of B<B::Concise> is compiled before
+your program is).
+
+=item B<#opt>
+
+Whether or not the op has been optimised by the peephole optimiser.
+
+Only available in 5.9 and later.
+
+=item B<#sibaddr>
+
+The address of the OP's next youngest sibling, in hexadecimal.
+
+=item B<#svaddr>
+
+The address of the OP's SV, if it has an SV, in hexadecimal.
+
+=item B<#svclass>
+
+The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
+
+=item B<#svval>
+
+The value of the OP's SV, if it has one, in a short human-readable format.
+
+=item B<#targ>
+
+The numeric value of the OP's targ.
+
+=item B<#targarg>
+
+The name of the variable the OP's targ refers to, if any, otherwise the
+letter t followed by the OP's targ in decimal.
+
+=item B<#targarglife>
+
+Same as B<#targarg>, but followed by the COP sequence numbers that delimit
+the variable's lifetime (or 'end' for a variable in an open scope) for a
+variable.
+
+=item B<#typenum>
+
+The numeric value of the OP's type, in decimal.
+
+=back
+
+=head1 One-Liner Command tips
+
+=over 4
+
+=item perl -MO=Concise,bar foo.pl
+
+Renders only bar() from foo.pl. To see main, drop the ',bar'. To see
+both, add ',-main'
+
+=item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
+
+Identifies md5 as an XS function. The export is needed so that BC can
+find it in main.
+
+=item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
+
+Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
+Although POSIX isn't entirely consistent across platforms, this is
+likely to be present in virtually all of them.
+
+=item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
+
+This renders a print statement, which includes a call to the function.
+It's identical to rendering a file with a use call and that single
+statement, except for the filename which appears in the nextstate ops.
+
+=item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
+
+This is B<very> 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
+
+The common (and original) usage of B::Concise was for command-line
+renderings of simple code, as given in EXAMPLE. But you can also use
+B<B::Concise> from your code, and call compile() directly, and
+repeatedly. By doing so, you can avoid the compile-time only
+operation of O.pm, and even use the debugger to step through
+B::Concise::compile() itself.
+
+Once you're doing this, you may alter Concise output by adding new
+rendering styles, and by optionally adding callback routines which
+populate new variables, if such were referenced from those (just
+added) styles.
+
+=head2 Example: Altering Concise Renderings
+
+ use B::Concise qw(set_style add_callback);
+ add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
+ add_callback
+ ( sub {
+ my ($h, $op, $format, $level, $stylename) = @_;
+ $h->{variable} = some_func($op);
+ });
+ $walker = B::Concise::compile(@options,@subnames,@subrefs);
+ $walker->();
+
+=head2 set_style()
+
+B<set_style> accepts 3 arguments, and updates the three format-specs
+comprising a line-style (basic-exec, goto, tree). It has one minor
+drawback though; it doesn't register the style under a new name. This
+can become an issue if you render more than once and switch styles.
+Thus you may prefer to use add_style() and/or set_style_standard()
+instead.
+
+=head2 set_style_standard($name)
+
+This restores one of the standard line-styles: C<terse>, C<concise>,
+C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
+names previously defined with 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 ()
+
+If your newly minted styles refer to any new #variables, you'll need
+to define a callback subroutine that will populate (or modify) those
+variables. They are then available for use in the style you've
+chosen.
+
+The callbacks are called for each opcode visited by Concise, in the
+same order as they are added. Each subroutine is passed five
+parameters.
+
+ 1. A hashref, containing the variable names and values which are
+ populated into the report-line for the op
+ 2. the op, as a B<B::OP> object
+ 3. a reference to the format string
+ 4. the formatting (indent) level
+ 5. the selected stylename
+
+To define your own variables, simply add them to the hash, or change
+existing values if you need to. The level and format are passed in as
+references to scalars, but it is unlikely that they will need to be
+changed or even used.
+
+=head2 Running B::Concise::compile()
+
+B<compile> accepts options as described above in L</OPTIONS>, and
+arguments, which are either coderefs, or subroutine names.
+
+It constructs and returns a $treewalker coderef, which when invoked,
+traverses, or walks, and renders the optrees of the given arguments to
+STDOUT. You can reuse this, and can change the rendering style used
+each time; thereafter the coderef renders in the new style.
+
+B<walk_output> lets you change the print destination from STDOUT to
+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";
+
+When $walker is called, it traverses the subroutines supplied when it
+was created, and renders them using the current style. You can change
+the style afterwards in several different ways:
+
+ 1. call C<compile>, altering style or mode/order
+ 2. call C<set_style_standard>
+ 3. call $walker, passing @new options
+
+Passing new options to the $walker is the easiest way to change
+amongst any pre-defined styles (the ones you add are automatically
+recognized as options), and is the only way to alter rendering order
+without calling compile again. Note however that rendering state is
+still shared amongst multiple $walker objects, so they must still be
+used in a coordinated manner.
+
+=head2 B::Concise::reset_sequence()
+
+This function (not exported) lets you reset the sequence numbers (note
+that they're numbered arbitrarily, their goal being to be human
+readable). Its purpose is mostly to support testing, i.e. to compare
+the concise output from two identical anonymous subroutines (but
+different instances). Without the reset, B::Concise, seeing that
+they're separate optrees, generates different sequence numbers in
+the output.
+
+=head2 Errors
+
+Errors in rendering (non-existent function-name, non-existent coderef)
+are written to the STDOUT, or wherever you've set it via
+walk_output().
+
+Errors using the various *style* calls, and bad args to walk_output(),
+result in die(). Use an eval if you wish to catch these errors and
+continue processing.
+
+=head1 AUTHOR
+
+Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
+
+=cut