"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/B/Concise.pm" (7 Mar 2020, 60514 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package B::Concise;
    2 # Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
    3 # This program is free software; you can redistribute and/or modify it
    4 # under the same terms as Perl itself.
    5 
    6 # Note: we need to keep track of how many use declarations/BEGIN
    7 # blocks this module uses, so we can avoid printing them when user
    8 # asks for the BEGIN blocks in her program. Update the comments and
    9 # the count in concise_specials if you add or delete one. The
   10 # -MO=Concise counts as use #1.
   11 
   12 use strict; # use #2
   13 use warnings; # uses #3 and #4, since warnings uses Carp
   14 
   15 use Exporter (); # use #5
   16 
   17 our $VERSION   = "1.004";
   18 our @ISA       = qw(Exporter);
   19 our @EXPORT_OK = qw( set_style set_style_standard add_callback
   20              concise_subref concise_cv concise_main
   21              add_style walk_output compile reset_sequence );
   22 our %EXPORT_TAGS =
   23     ( io    => [qw( walk_output compile reset_sequence )],
   24       style => [qw( add_style set_style_standard )],
   25       cb    => [qw( add_callback )],
   26       mech  => [qw( concise_subref concise_cv concise_main )],  );
   27 
   28 # use #6
   29 use B qw(class ppname main_start main_root main_cv cstring svref_2object
   30      SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
   31          OPf_STACKED
   32          OPpSPLIT_ASSIGN OPpSPLIT_LEX
   33      CVf_ANON CVf_LEXICAL CVf_NAMED
   34      PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
   35 
   36 my %style =
   37   ("terse" =>
   38    ["(?(#label =>\n)?)(*(    )*)#class (#addr) #name (?([#targ])?) "
   39     . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
   40     "(*(    )*)goto #class (#addr)\n",
   41     "#class pp_#name"],
   42    "concise" =>
   43    ["#hyphseq2 (*(   (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)"
   44     . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n"
   45     , "  (*(    )*)     goto #seq\n",
   46     "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
   47    "linenoise" =>
   48    ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
   49     "gt_#seq ",
   50     "(?(#seq)?)#noise#arg(?([#targarg])?)"],
   51    "debug" =>
   52    ["#class (#addr)\n\top_next\t\t#nextaddr\n\t(?(op_other\t#otheraddr\n\t)?)"
   53     . "op_sibling\t#sibaddr\n\t"
   54     . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
   55     . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
   56     . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
   57     . "(?(\top_sv\t\t#svaddr\n)?)",
   58     "    GOTO #addr\n",
   59     "#addr"],
   60    "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
   61          $ENV{B_CONCISE_TREE_FORMAT}],
   62   );
   63 
   64 # Renderings, ie how Concise prints, is controlled by these vars
   65 # primary:
   66 our $stylename;     # selects current style from %style
   67 my $order = "basic";    # how optree is walked & printed: basic, exec, tree
   68 
   69 # rendering mechanics:
   70 # these 'formats' are the line-rendering templates
   71 # they're updated from %style when $stylename changes
   72 my ($format, $gotofmt, $treefmt);
   73 
   74 # lesser players:
   75 my $base = 36;      # how <sequence#> is displayed
   76 my $big_endian = 1; # more <sequence#> display
   77 my $tree_style = 0; # tree-order details
   78 my $banner = 1;     # print banner before optree is traversed
   79 my $do_main = 0;    # force printing of main routine
   80 my $show_src;       # show source code
   81 
   82 # another factor: can affect all styles!
   83 our @callbacks;     # allow external management
   84 
   85 set_style_standard("concise");
   86 
   87 my $curcv;
   88 my $cop_seq_base;
   89 
   90 sub set_style {
   91     ($format, $gotofmt, $treefmt) = @_;
   92     #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
   93     die "expecting 3 style-format args\n" unless @_ == 3;
   94 }
   95 
   96 sub add_style {
   97     my ($newstyle,@args) = @_;
   98     die "style '$newstyle' already exists, choose a new name\n"
   99     if exists $style{$newstyle};
  100     die "expecting 3 style-format args\n" unless @args == 3;
  101     $style{$newstyle} = [@args];
  102     $stylename = $newstyle; # update rendering state
  103 }
  104 
  105 sub set_style_standard {
  106     ($stylename) = @_; # update rendering state
  107     die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
  108     set_style(@{$style{$stylename}});
  109 }
  110 
  111 sub add_callback {
  112     push @callbacks, @_;
  113 }
  114 
  115 # output handle, used with all Concise-output printing
  116 our $walkHandle;    # public for your convenience
  117 BEGIN { $walkHandle = \*STDOUT }
  118 
  119 sub walk_output { # updates $walkHandle
  120     my $handle = shift;
  121     return $walkHandle unless $handle; # allow use as accessor
  122 
  123     if (ref $handle eq 'SCALAR') {
  124     require Config;
  125     die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
  126         unless $Config::Config{useperlio};
  127     # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
  128     open my $tmp, '>', $handle; # but cant re-set existing STDOUT
  129     $walkHandle = $tmp;     # so use my $tmp as intermediate var
  130     return $walkHandle;
  131     }
  132     my $iotype = ref $handle;
  133     die "expecting argument/object that can print\n"
  134     unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
  135     $walkHandle = $handle;
  136 }
  137 
  138 sub concise_subref {
  139     my($order, $coderef, $name) = @_;
  140     my $codeobj = svref_2object($coderef);
  141 
  142     return concise_stashref(@_)
  143     unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
  144     concise_cv_obj($order, $codeobj, $name);
  145 }
  146 
  147 sub concise_stashref {
  148     my($order, $h) = @_;
  149     my $name = svref_2object($h)->NAME;
  150     foreach my $k (sort keys %$h) {
  151     next unless defined $h->{$k};
  152     my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k}
  153             : ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next
  154             : next;
  155     reset_sequence();
  156     print "FUNC: *", $name, "::", $k, "\n";
  157     my $codeobj = svref_2object($coderef);
  158     next unless ref $codeobj eq 'B::CV';
  159     eval { concise_cv_obj($order, $codeobj, $k) };
  160     warn "err $@ on $codeobj" if $@;
  161     }
  162 }
  163 
  164 # This should have been called concise_subref, but it was exported
  165 # under this name in versions before 0.56
  166 *concise_cv = \&concise_subref;
  167 
  168 sub concise_cv_obj {
  169     my ($order, $cv, $name) = @_;
  170     # name is either a string, or a CODE ref (copy of $cv arg??)
  171 
  172     $curcv = $cv;
  173 
  174     if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
  175     print $walkHandle "$name is a constant sub, optimized to a $1\n";
  176     return;
  177     }
  178     if ($cv->XSUB) {
  179     print $walkHandle "$name is XS code\n";
  180     return;
  181     }
  182     if (class($cv->START) eq "NULL") {
  183     no strict 'refs';
  184     if (ref $name eq 'CODE') {
  185         print $walkHandle "coderef $name has no START\n";
  186     }
  187     elsif (exists &$name) {
  188         print $walkHandle "$name exists in stash, but has no START\n";
  189     }
  190     else {
  191         print $walkHandle "$name not in symbol table\n";
  192     }
  193     return;
  194     }
  195     sequence($cv->START);
  196     if ($order eq "exec") {
  197     walk_exec($cv->START);
  198     }
  199     elsif ($order eq "basic") {
  200     # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
  201     my $root = $cv->ROOT;
  202     unless (ref $root eq 'B::NULL') {
  203         walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
  204     } else {
  205         print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
  206     }
  207     } else {
  208     print $walkHandle tree($cv->ROOT, 0);
  209     }
  210 }
  211 
  212 sub concise_main {
  213     my($order) = @_;
  214     sequence(main_start);
  215     $curcv = main_cv;
  216     if ($order eq "exec") {
  217     return if class(main_start) eq "NULL";
  218     walk_exec(main_start);
  219     } elsif ($order eq "tree") {
  220     return if class(main_root) eq "NULL";
  221     print $walkHandle tree(main_root, 0);
  222     } elsif ($order eq "basic") {
  223     return if class(main_root) eq "NULL";
  224     walk_topdown(main_root,
  225              sub { $_[0]->concise($_[1]) }, 0);
  226     }
  227 }
  228 
  229 sub concise_specials {
  230     my($name, $order, @cv_s) = @_;
  231     my $i = 1;
  232     if ($name eq "BEGIN") {
  233     splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
  234     } elsif ($name eq "CHECK") {
  235     pop @cv_s; # skip the CHECK block that calls us
  236     }
  237     for my $cv (@cv_s) {
  238     print $walkHandle "$name $i:\n";
  239     $i++;
  240     concise_cv_obj($order, $cv, $name);
  241     }
  242 }
  243 
  244 my $start_sym = "\e(0"; # "\cN" sometimes also works
  245 my $end_sym   = "\e(B"; # "\cO" respectively
  246 
  247 my @tree_decorations =
  248   (["  ", "--", "+-", "|-", "| ", "`-", "-", 1],
  249    [" ", "-", "+", "+", "|", "`", "", 0],
  250    ["  ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
  251    [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
  252   );
  253 
  254 my @render_packs; # collect -stash=<packages>
  255 
  256 sub compileOpts {
  257     # set rendering state from options and args
  258     my (@options,@args);
  259     if (@_) {
  260     @options = grep(/^-/, @_);
  261     @args = grep(!/^-/, @_);
  262     }
  263     for my $o (@options) {
  264     # mode/order
  265     if ($o eq "-basic") {
  266         $order = "basic";
  267     } elsif ($o eq "-exec") {
  268         $order = "exec";
  269     } elsif ($o eq "-tree") {
  270         $order = "tree";
  271     }
  272     # tree-specific
  273     elsif ($o eq "-compact") {
  274         $tree_style |= 1;
  275     } elsif ($o eq "-loose") {
  276         $tree_style &= ~1;
  277     } elsif ($o eq "-vt") {
  278         $tree_style |= 2;
  279     } elsif ($o eq "-ascii") {
  280         $tree_style &= ~2;
  281     }
  282     # sequence numbering
  283     elsif ($o =~ /^-base(\d+)$/) {
  284         $base = $1;
  285     } elsif ($o eq "-bigendian") {
  286         $big_endian = 1;
  287     } elsif ($o eq "-littleendian") {
  288         $big_endian = 0;
  289     }
  290     # miscellaneous, presentation
  291     elsif ($o eq "-nobanner") {
  292         $banner = 0;
  293     } elsif ($o eq "-banner") {
  294         $banner = 1;
  295     }
  296     elsif ($o eq "-main") {
  297         $do_main = 1;
  298     } elsif ($o eq "-nomain") {
  299         $do_main = 0;
  300     } elsif ($o eq "-src") {
  301         $show_src = 1;
  302     }
  303     elsif ($o =~ /^-stash=(.*)/) {
  304         my $pkg = $1;
  305         no strict 'refs';
  306         if (! %{$pkg.'::'}) {
  307         eval "require $pkg";
  308         } else {
  309         require Config;
  310         if (!$Config::Config{usedl}
  311             && keys %{$pkg.'::'} == 1
  312             && $pkg->can('bootstrap')) {
  313             # It is something that we're statically linked to, but hasn't
  314             # yet been used.
  315             eval "require $pkg";
  316         }
  317         }
  318         push @render_packs, $pkg;
  319     }
  320     # line-style options
  321     elsif (exists $style{substr($o, 1)}) {
  322         $stylename = substr($o, 1);
  323         set_style_standard($stylename);
  324     } else {
  325         warn "Option $o unrecognized";
  326     }
  327     }
  328     return (@args);
  329 }
  330 
  331 sub compile {
  332     my (@args) = compileOpts(@_);
  333     return sub {
  334     my @newargs = compileOpts(@_); # accept new rendering options
  335     warn "disregarding non-options: @newargs\n" if @newargs;
  336 
  337     for my $objname (@args) {
  338         next unless $objname; # skip null args to avoid noisy responses
  339 
  340         if ($objname eq "BEGIN") {
  341         concise_specials("BEGIN", $order,
  342                  B::begin_av->isa("B::AV") ?
  343                  B::begin_av->ARRAY : ());
  344         } elsif ($objname eq "INIT") {
  345         concise_specials("INIT", $order,
  346                  B::init_av->isa("B::AV") ?
  347                  B::init_av->ARRAY : ());
  348         } elsif ($objname eq "CHECK") {
  349         concise_specials("CHECK", $order,
  350                  B::check_av->isa("B::AV") ?
  351                  B::check_av->ARRAY : ());
  352         } elsif ($objname eq "UNITCHECK") {
  353         concise_specials("UNITCHECK", $order,
  354                  B::unitcheck_av->isa("B::AV") ?
  355                  B::unitcheck_av->ARRAY : ());
  356         } elsif ($objname eq "END") {
  357         concise_specials("END", $order,
  358                  B::end_av->isa("B::AV") ?
  359                  B::end_av->ARRAY : ());
  360         }
  361         else {
  362         # convert function names to subrefs
  363         if (ref $objname) {
  364             print $walkHandle "B::Concise::compile($objname)\n"
  365             if $banner;
  366             concise_subref($order, ($objname)x2);
  367             next;
  368         } else {
  369             $objname = "main::" . $objname unless $objname =~ /::/;
  370             no strict 'refs';
  371             my $glob = \*$objname;
  372             unless (*$glob{CODE} || *$glob{FORMAT}) {
  373             print $walkHandle "$objname:\n" if $banner;
  374             print $walkHandle "err: unknown function ($objname)\n";
  375             return;
  376             }
  377             if (my $objref = *$glob{CODE}) {
  378             print $walkHandle "$objname:\n" if $banner;
  379             concise_subref($order, $objref, $objname);
  380             }
  381             if (my $objref = *$glob{FORMAT}) {
  382             print $walkHandle "$objname (FORMAT):\n"
  383                 if $banner;
  384             concise_subref($order, $objref, $objname);
  385             }
  386         }
  387         }
  388     }
  389     for my $pkg (@render_packs) {
  390         no strict 'refs';
  391         concise_stashref($order, \%{$pkg.'::'});
  392     }
  393 
  394     if (!@args or $do_main or @render_packs) {
  395         print $walkHandle "main program:\n" if $do_main;
  396         concise_main($order);
  397     }
  398     return @args;   # something
  399     }
  400 }
  401 
  402 my %labels;
  403 my $lastnext;   # remembers op-chain, used to insert gotos
  404 
  405 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
  406            'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
  407            'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
  408            'METHOP' => '.', UNOP_AUX => '+');
  409 
  410 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
  411 my @linenoise =
  412   qw'#  () sc (  @? 1  $* gv *{ m$ m@ m% m? p/ *$ $  $# & a& pt \\ s\\ rf bl
  413      `  *? <> ?? ?/ r/ c/ // qr s/ /c y/ =  @= C  sC Cp sp df un BM po +1 +I
  414      -1 -I 1+ I+ 1- I- ** *  i* /  i/ %$ i% x  +  i+ -  i- .  "  << >> <  i<
  415      >  i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
  416      !  ~  a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
  417      uf lf uc lc qm @  [f [  @[ eh vl ky dl ex %  ${ @{ uk pk st jn )  )[ a@
  418      a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
  419      v} ca wa di rs ;; ;  ;d }{ {  }  {} f{ it {l l} rt }l }n }r dm }g }e ^o
  420      ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
  421      ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
  422      -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
  423      co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
  424      g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
  425      e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
  426      Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
  427 
  428 my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
  429 
  430 sub op_flags { # common flags (see BASOP.op_flags in op.h)
  431     my($x) = @_;
  432     my(@v);
  433     push @v, "v" if ($x & 3) == 1;
  434     push @v, "s" if ($x & 3) == 2;
  435     push @v, "l" if ($x & 3) == 3;
  436     push @v, "K" if $x & 4;
  437     push @v, "P" if $x & 8;
  438     push @v, "R" if $x & 16;
  439     push @v, "M" if $x & 32;
  440     push @v, "S" if $x & 64;
  441     push @v, "*" if $x & 128;
  442     return join("", @v);
  443 }
  444 
  445 sub base_n {
  446     my $x = shift;
  447     return "-" . base_n(-$x) if $x < 0;
  448     my $str = "";
  449     do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
  450     $str = reverse $str if $big_endian;
  451     return $str;
  452 }
  453 
  454 my %sequence_num;
  455 my $seq_max = 1;
  456 
  457 sub reset_sequence {
  458     # reset the sequence
  459     %sequence_num = ();
  460     $seq_max = 1;
  461     $lastnext = 0;
  462 }
  463 
  464 sub seq {
  465     my($op) = @_;
  466     return "-" if not exists $sequence_num{$$op};
  467     return base_n($sequence_num{$$op});
  468 }
  469 
  470 sub walk_topdown {
  471     my($op, $sub, $level) = @_;
  472     $sub->($op, $level);
  473     if ($op->flags & OPf_KIDS) {
  474     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
  475         walk_topdown($kid, $sub, $level + 1);
  476     }
  477     }
  478     if (class($op) eq "PMOP") {
  479     my $maybe_root = $op->code_list;
  480     if ( ref($maybe_root) and $maybe_root->isa("B::OP")
  481      and not $op->flags & OPf_KIDS) {
  482         walk_topdown($maybe_root, $sub, $level + 1);
  483     }
  484     $maybe_root = $op->pmreplroot;
  485     if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
  486         # It really is the root of the replacement, not something
  487         # else stored here for lack of space elsewhere
  488         walk_topdown($maybe_root, $sub, $level + 1);
  489     }
  490     }
  491 }
  492 
  493 sub walklines {
  494     my($ar, $level) = @_;
  495     for my $l (@$ar) {
  496     if (ref($l) eq "ARRAY") {
  497         walklines($l, $level + 1);
  498     } else {
  499         $l->concise($level);
  500     }
  501     }
  502 }
  503 
  504 sub walk_exec {
  505     my($top, $level) = @_;
  506     my %opsseen;
  507     my @lines;
  508     my @todo = ([$top, \@lines]);
  509     while (@todo and my($op, $targ) = @{shift @todo}) {
  510     for (; $$op; $op = $op->next) {
  511         last if $opsseen{$$op}++;
  512         push @$targ, $op;
  513         my $name = $op->name;
  514         if (class($op) eq "LOGOP") {
  515         my $ar = [];
  516         push @$targ, $ar;
  517         push @todo, [$op->other, $ar];
  518         } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
  519         my $ar = [];
  520         push @$targ, $ar;
  521         push @todo, [$op->pmreplstart, $ar];
  522         } elsif ($name =~ /^enter(loop|iter)$/) {
  523         $labels{${$op->nextop}} = "NEXT";
  524         $labels{${$op->lastop}} = "LAST";
  525         $labels{${$op->redoop}} = "REDO";
  526         }
  527     }
  528     }
  529     walklines(\@lines, 0);
  530 }
  531 
  532 # The structure of this routine is purposely modeled after op.c's peep()
  533 sub sequence {
  534     my($op) = @_;
  535     my $oldop = 0;
  536     return if class($op) eq "NULL" or exists $sequence_num{$$op};
  537     for (; $$op; $op = $op->next) {
  538     last if exists $sequence_num{$$op};
  539     my $name = $op->name;
  540     $sequence_num{$$op} = $seq_max++;
  541     if (class($op) eq "LOGOP") {
  542         sequence($op->other);
  543     } elsif (class($op) eq "LOOP") {
  544         sequence($op->redoop);
  545         sequence( $op->nextop);
  546         sequence($op->lastop);
  547     } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
  548         sequence($op->pmreplstart);
  549     }
  550     $oldop = $op;
  551     }
  552 }
  553 
  554 sub fmt_line {    # generate text-line for op.
  555     my($hr, $op, $text, $level) = @_;
  556 
  557     $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
  558 
  559     return '' if $hr->{SKIP};   # suppress line if a callback said so
  560     return '' if $hr->{goto} and $hr->{goto} eq '-';    # no goto nowhere
  561 
  562     # spec: (?(text1#varText2)?)
  563     $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
  564     $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
  565 
  566     # spec: (x(exec_text;basic_text)x)
  567     $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
  568 
  569     # spec: (*(text)*)
  570     $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
  571 
  572     # spec: (*(text1;text2)*)
  573     $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
  574 
  575     # convert #Var to tag=>val form: Var\t#var
  576     $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
  577 
  578     # spec: #varN
  579     $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
  580 
  581     $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg;  # populate #var's
  582     $text =~ s/[ \t]*~+[ \t]*/ /g;      # squeeze tildes
  583 
  584     $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
  585 
  586     chomp $text;
  587     return "$text\n" if $text ne "" and $order ne "tree";
  588     return $text; # suppress empty lines
  589 }
  590 
  591 
  592 
  593 # use require rather than use here to avoid disturbing tests that dump
  594 # BEGIN blocks
  595 require B::Op_private;
  596 
  597 
  598 
  599 our %hints; # used to display each COP's op_hints values
  600 
  601 # strict refs, subs, vars
  602 @hints{0x2,0x200,0x400,0x20,0x40,0x80} = ('$', '&', '*', 'x$', 'x&', 'x*');
  603 # integers, locale, bytes
  604 @hints{0x1,0x4,0x8,0x10} = ('i', 'l', 'b');
  605 # block scope, localise %^H, $^OPEN (in), $^OPEN (out)
  606 @hints{0x100,0x20000,0x40000,0x80000} = ('{','%','<','>');
  607 # overload new integer, float, binary, string, re
  608 @hints{0x1000,0x2000,0x4000,0x8000,0x10000} = ('I', 'F', 'B', 'S', 'R');
  609 # taint and eval
  610 @hints{0x100000,0x200000} = ('T', 'E');
  611 # filetest access, use utf8, unicode_strings feature
  612 @hints{0x400000,0x800000,0x800} = ('X', 'U', 'us');
  613 
  614 # pick up the feature hints constants.
  615 # Note that we're relying on non-API parts of feature.pm,
  616 # but its less naughty than just blindly copying those constants into
  617 # this src file.
  618 #
  619 require feature;
  620 
  621 sub hints_flags {
  622     my($x) = @_;
  623     my @s;
  624     for my $flag (sort {$b <=> $a} keys %hints) {
  625     if ($hints{$flag} and $x & $flag and $x >= $flag) {
  626         $x -= $flag;
  627         push @s, $hints{$flag};
  628     }
  629     }
  630     if ($x & $feature::hint_mask) {
  631         push @s, "fea=" . (($x & $feature::hint_mask) >> $feature::hint_shift);
  632         $x &= ~$feature::hint_mask;
  633     }
  634     push @s, sprintf "0x%x", $x if $x;
  635     return join(",", @s);
  636 }
  637 
  638 
  639 # return a string like 'LVINTRO,1' for the op $name with op_private
  640 # value $x
  641 
  642 sub private_flags {
  643     my($name, $x) = @_;
  644     my $entry = $B::Op_private::bits{$name};
  645     return $x ? "$x" : '' unless $entry;
  646 
  647     my @flags;
  648     my $bit;
  649     for ($bit = 7; $bit >= 0; $bit--) {
  650         next unless exists $entry->{$bit};
  651         my $e = $entry->{$bit};
  652         if (ref($e) eq 'HASH') {
  653             # bit field
  654 
  655             my ($bitmin, $bitmax, $bitmask, $enum, $label) =
  656                     @{$e}{qw(bitmin bitmax bitmask enum label)};
  657             $bit = $bitmin;
  658             next if defined $label && $label eq '-'; # display as raw number
  659 
  660             my $val = $x & $bitmask;
  661             $x &= ~$bitmask;
  662             $val >>= $bitmin;
  663 
  664             if (defined $enum) {
  665                 # try to convert numeric $val into symbolic
  666                 my @enum = @$enum;
  667                 while (@enum) {
  668                     my $ix    = shift @enum;
  669                     my $name  = shift @enum;
  670                     my $label = shift @enum;
  671                     if ($val == $ix) {
  672                         $val = $label;
  673                         last;
  674                     }
  675                 }
  676             }
  677             next if $val eq '0'; # don't display anonymous zero values
  678             push @flags, defined $label ? "$label=$val" : $val;
  679 
  680         }
  681         else {
  682             # flag bit
  683             my $label = $B::Op_private::labels{$e};
  684             next if defined $label && $label eq '-'; # display as raw number
  685             if ($x & (1<<$bit)) {
  686                 $x -= (1<<$bit);
  687                 push @flags, $label;
  688             }
  689         }
  690     }
  691 
  692     push @flags, $x if $x; # display unknown bits numerically
  693     return join ",", @flags;
  694 }
  695 
  696 sub concise_sv {
  697     my($sv, $hr, $preferpv) = @_;
  698     $hr->{svclass} = class($sv);
  699     $hr->{svclass} = "UV"
  700       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
  701     Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
  702     $hr->{svaddr} = sprintf("%#x", $$sv);
  703     if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
  704     my $gv = $sv;
  705     my $stash = $gv->STASH;
  706     if (class($stash) eq "SPECIAL") {
  707         $stash = "<none>";
  708     }
  709     else {
  710         $stash = $stash->NAME;
  711     }
  712     if ($stash eq "main") {
  713         $stash = "";
  714     } else {
  715         $stash = $stash . "::";
  716     }
  717     $hr->{svval} = "*$stash" . $gv->SAFENAME;
  718     return "*$stash" . $gv->SAFENAME;
  719     } else {
  720     while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
  721         $hr->{svval} .= "\\";
  722         $sv = $sv->RV;
  723     }
  724     if (class($sv) eq "SPECIAL") {
  725         $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no",
  726                              '', '', '', "sv_zero"]->[$$sv];
  727     } elsif ($preferpv
  728           && ($sv->FLAGS & SVf_POK)) {
  729         $hr->{svval} .= cstring($sv->PV);
  730     } elsif ($sv->FLAGS & SVf_NOK) {
  731         $hr->{svval} .= $sv->NV;
  732     } elsif ($sv->FLAGS & SVf_IOK) {
  733         $hr->{svval} .= $sv->int_value;
  734     } elsif ($sv->FLAGS & SVf_POK) {
  735         $hr->{svval} .= cstring($sv->PV);
  736     } elsif (class($sv) eq "HV") {
  737         $hr->{svval} .= 'HASH';
  738     } elsif (class($sv) eq "AV") {
  739         $hr->{svval} .= 'ARRAY';
  740     } elsif (class($sv) eq "CV") {
  741         if ($sv->CvFLAGS & CVf_ANON) {
  742         $hr->{svval} .= 'CODE';
  743         } elsif ($sv->CvFLAGS & CVf_NAMED) {
  744         $hr->{svval} .= "&";
  745         unless ($sv->CvFLAGS & CVf_LEXICAL) {
  746             my $stash = $sv->STASH;
  747             unless (class($stash) eq "SPECIAL") {
  748             $hr->{svval} .= $stash->NAME . "::";
  749             }
  750         }
  751         $hr->{svval} .= $sv->NAME_HEK;
  752         } else {
  753         $hr->{svval} .= "&";
  754         $sv = $sv->GV;
  755         my $stash = $sv->STASH;
  756         unless (class($stash) eq "SPECIAL") {
  757             $hr->{svval} .= $stash->NAME . "::";
  758         }
  759         $hr->{svval} .= $sv->SAFENAME;
  760         }
  761     }
  762 
  763     $hr->{svval} = 'undef' unless defined $hr->{svval};
  764     my $out = $hr->{svclass};
  765     return $out .= " $hr->{svval}" ; 
  766     }
  767 }
  768 
  769 my %srclines;
  770 
  771 sub fill_srclines {
  772     my $fullnm = shift;
  773     if ($fullnm eq '-e') {
  774     $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
  775     return;
  776     }
  777     open (my $fh, '<', $fullnm)
  778     or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
  779     and return;
  780     my @l = <$fh>;
  781     chomp @l;
  782     unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
  783     $srclines{$fullnm} = \@l;
  784 }
  785 
  786 # Given a pad target, return the pad var's name and cop range /
  787 # fakeness, or failing that, its target number.
  788 # e.g.
  789 #   ('$i', '$i:5,7')
  790 # or
  791 #   ('$i', '$i:fake:a')
  792 # or
  793 #   ('t5', 't5')
  794 
  795 sub padname {
  796     my ($targ) = @_;
  797 
  798     my ($targarg, $targarglife);
  799     my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ];
  800     if (defined $padname and class($padname) ne "SPECIAL" and
  801         $padname->LEN)
  802     {
  803         $targarg  = $padname->PVX;
  804         if ($padname->FLAGS & SVf_FAKE) {
  805             # These changes relate to the jumbo closure fix.
  806             # See changes 19939 and 20005
  807             my $fake = '';
  808             $fake .= 'a'
  809                 if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
  810             $fake .= 'm'
  811                 if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
  812             $fake .= ':' . $padname->PARENT_PAD_INDEX
  813                 if $curcv->CvFLAGS & CVf_ANON;
  814             $targarglife = "$targarg:FAKE:$fake";
  815         }
  816         else {
  817             my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
  818             my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
  819             $finish = "end" if $finish == 999999999 - $cop_seq_base;
  820             $targarglife = "$targarg:$intro,$finish";
  821         }
  822     } else {
  823         $targarglife = $targarg = "t" . $targ;
  824     }
  825     return $targarg, $targarglife;
  826 }
  827 
  828 
  829 
  830 sub concise_op {
  831     my ($op, $level, $format) = @_;
  832     my %h;
  833     $h{exname} = $h{name} = $op->name;
  834     $h{NAME} = uc $h{name};
  835     $h{class} = class($op);
  836     $h{extarg} = $h{targ} = $op->targ;
  837     $h{extarg} = "" unless $h{extarg};
  838     $h{privval} = $op->private;
  839     # for null ops, targ holds the old type
  840     my $origname = $h{name} eq "null" && $h{targ}
  841       ? substr(ppname($h{targ}), 3)
  842       : $h{name};
  843     $h{private} = private_flags($origname, $op->private);
  844     if ($op->folded) {
  845       $h{private} &&= "$h{private},";
  846       $h{private} .= "FOLD";
  847     }
  848 
  849     if ($h{name} ne $origname) { # a null op
  850     $h{exname} = "ex-$origname";
  851     $h{extarg} = "";
  852     } elsif ($h{private} =~ /\bREFC\b/) {
  853     # targ holds a reference count
  854         my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
  855         $h{targarglife} = $h{targarg} = "$h{targ} $refs";
  856     } elsif ($h{targ}) {
  857     my $count = $h{name} eq 'padrange'
  858             ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'})
  859             : 1;
  860     my (@targarg, @targarglife);
  861     for my $i (0..$count-1) {
  862         my ($targarg, $targarglife) = padname($h{targ} + $i);
  863         push @targarg,     $targarg;
  864         push @targarglife, $targarglife;
  865     }
  866     $h{targarg}     = join '; ', @targarg;
  867     $h{targarglife} = join '; ', @targarglife;
  868     }
  869 
  870     $h{arg} = "";
  871     $h{svclass} = $h{svaddr} = $h{svval} = "";
  872     if ($h{class} eq "PMOP") {
  873     my $extra = '';
  874     my $precomp = $op->precomp;
  875     if (defined $precomp) {
  876         $precomp = cstring($precomp); # Escape literal control sequences
  877         $precomp = "/$precomp/";
  878     } else {
  879         $precomp = "";
  880     }
  881     if ($op->name eq 'subst') {
  882         if (class($op->pmreplstart) ne "NULL") {
  883         undef $lastnext;
  884         $extra = " replstart->" . seq($op->pmreplstart);
  885         }
  886     }
  887     elsif ($op->name eq 'split') {
  888             if (    ($op->private & OPpSPLIT_ASSIGN) # @array  = split
  889                  && (not $op->flags & OPf_STACKED))  # @{expr} = split
  890             {
  891                 # with C<@array = split(/pat/, str);>,
  892                 #  array is stored in /pat/'s pmreplroot; either
  893                 # as an integer index into the pad (for a lexical array)
  894                 # or as GV for a package array (which will be a pad index
  895                 # on threaded builds)
  896 
  897                 if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) {
  898                     my $off = $op->pmreplroot; # union with op_pmtargetoff
  899                     my ($name, $full) = padname($off);
  900                     $extra = " => $full";
  901                 }
  902                 else {
  903                     # union with op_pmtargetoff, op_pmtargetgv
  904                     my $gv = $op->pmreplroot;
  905                     if (!ref($gv)) {
  906                         # the value is actually a pad offset
  907                         $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
  908                     }
  909                     else {
  910                         # unthreaded: its a GV
  911                         $gv = $gv->NAME;
  912                     }
  913                     $extra = " => \@$gv";
  914                 }
  915             }
  916     }
  917     $h{arg} = "($precomp$extra)";
  918     } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
  919     $h{arg} = '("' . $op->pv . '")';
  920     $h{svval} = '"' . $op->pv . '"';
  921     } elsif ($h{class} eq "COP") {
  922     my $label = $op->label;
  923     $h{coplabel} = $label;
  924     $label = $label ? "$label: " : "";
  925     my $loc = $op->file;
  926     my $pathnm = $loc;
  927     $loc =~ s[.*/][];
  928     my $ln = $op->line;
  929     $loc .= ":$ln";
  930     my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
  931     $h{arg} = "($label$stash $cseq $loc)";
  932     if ($show_src) {
  933         fill_srclines($pathnm) unless exists $srclines{$pathnm};
  934         my $line = $srclines{$pathnm}[$ln] // "-src unavailable under -e";
  935         $h{src} = "$ln: $line";
  936     }
  937     } elsif ($h{class} eq "LOOP") {
  938     $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
  939       . " redo->" . seq($op->redoop) . ")";
  940     } elsif ($h{class} eq "LOGOP") {
  941     undef $lastnext;
  942     $h{arg} = "(other->" . seq($op->other) . ")";
  943     $h{otheraddr} = sprintf("%#x", $ {$op->other});
  944         if ($h{name} eq "argdefelem") {
  945             # targ used for element index
  946             $h{targarglife} = $h{targarg} = "";
  947             $h{arg} .= "[" . $op->targ . "]";
  948         }
  949     }
  950     elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
  951     unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
  952         my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
  953         if ($h{class} eq "PADOP" or !${$op->sv}) {
  954         my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
  955         $h{arg} = "[" . concise_sv($sv, \%h, 0) . "]";
  956         $h{targarglife} = $h{targarg} = "";
  957         } else {
  958         $h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")";
  959         }
  960     }
  961     }
  962     elsif ($h{class} eq "METHOP") {
  963         my $prefix = '';
  964         if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') {
  965             my $rclass_sv = $op->rclass;
  966             $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv]
  967                 unless ref $rclass_sv;
  968             $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", ';
  969         }
  970         if ($h{name} ne "method") {
  971             if (${$op->meth_sv}) {
  972                 $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")";
  973             } else {
  974                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
  975                 $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]";
  976                 $h{targarglife} = $h{targarg} = "";
  977             }
  978         }
  979     }
  980     elsif ($h{class} eq "UNOP_AUX") {
  981         $h{arg} = "(" . $op->string($curcv) . ")";
  982     }
  983 
  984     $h{seq} = $h{hyphseq} = seq($op);
  985     $h{seq} = "" if $h{seq} eq "-";
  986     $h{opt} = $op->opt;
  987     $h{label} = $labels{$$op};
  988     $h{next} = $op->next;
  989     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
  990     $h{nextaddr} = sprintf("%#x", $ {$op->next});
  991     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
  992     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
  993     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
  994 
  995     $h{classsym} = $opclass{$h{class}};
  996     $h{flagval} = $op->flags;
  997     $h{flags} = op_flags($op->flags);
  998     if ($op->can("hints")) {
  999       $h{hintsval} = $op->hints;
 1000       $h{hints} = hints_flags($h{hintsval});
 1001     } else {
 1002       $h{hintsval} = $h{hints} = '';
 1003     }
 1004     $h{addr} = sprintf("%#x", $$op);
 1005     $h{typenum} = $op->type;
 1006     $h{noise} = $linenoise[$op->type];
 1007 
 1008     return fmt_line(\%h, $op, $format, $level);
 1009 }
 1010 
 1011 sub B::OP::concise {
 1012     my($op, $level) = @_;
 1013     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 1014     # insert a 'goto' line
 1015     my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
 1016              "addr" => sprintf("%#x", $$lastnext),
 1017              "goto" => seq($lastnext), # simplify goto '-' removal
 1018          };
 1019     print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
 1020     }
 1021     $lastnext = $op->next;
 1022     print $walkHandle concise_op($op, $level, $format);
 1023 }
 1024 
 1025 # B::OP::terse (see Terse.pm) now just calls this
 1026 sub b_terse {
 1027     my($op, $level) = @_;
 1028 
 1029     # This isn't necessarily right, but there's no easy way to get
 1030     # from an OP to the right CV. This is a limitation of the
 1031     # ->terse() interface style, and there isn't much to do about
 1032     # it. In particular, we can die in concise_op if the main pad
 1033     # isn't long enough, or has the wrong kind of entries, compared to
 1034     # the pad a sub was compiled with. The fix for that would be to
 1035     # make a backwards compatible "terse" format that never even
 1036     # looked at the pad, just like the old B::Terse. I don't think
 1037     # that's worth the effort, though.
 1038     $curcv = main_cv unless $curcv;
 1039 
 1040     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 1041     # insert a 'goto'
 1042     my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
 1043          "addr" => sprintf("%#x", $$lastnext)};
 1044     print # $walkHandle
 1045         fmt_line($h, $op, $style{"terse"}[1], $level+1);
 1046     }
 1047     $lastnext = $op->next;
 1048     print # $walkHandle 
 1049     concise_op($op, $level, $style{"terse"}[0]);
 1050 }
 1051 
 1052 sub tree {
 1053     my $op = shift;
 1054     my $level = shift;
 1055     my $style = $tree_decorations[$tree_style];
 1056     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
 1057     my $name = concise_op($op, $level, $treefmt);
 1058     if (not $op->flags & OPf_KIDS) {
 1059     return $name . "\n";
 1060     }
 1061     my @lines;
 1062     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
 1063     push @lines, tree($kid, $level+1);
 1064     }
 1065     my $i;
 1066     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
 1067     $lines[$i] = $space . $lines[$i];
 1068     }
 1069     if ($i > 0) {
 1070     $lines[$i] = $last . $lines[$i];
 1071     while ($i-- > 1) {
 1072         if (substr($lines[$i], 0, 1) eq " ") {
 1073         $lines[$i] = $nokid . $lines[$i];
 1074         } else {
 1075         $lines[$i] = $kid . $lines[$i];
 1076         }
 1077     }
 1078     $lines[$i] = $kids . $lines[$i];
 1079     } else {
 1080     $lines[0] = $single . $lines[0];
 1081     }
 1082     return("$name$lead" . shift @lines,
 1083            map(" " x (length($name)+$size) . $_, @lines));
 1084 }
 1085 
 1086 # *** Warning: fragile kludge ahead ***
 1087 # Because the B::* modules run in the same interpreter as the code
 1088 # they're compiling, their presence tends to distort the view we have of
 1089 # the code we're looking at. In particular, perl gives sequence numbers
 1090 # to COPs. If the program we're looking at were run on its own, this
 1091 # would start at 1. Because all of B::Concise and all the modules it
 1092 # uses are compiled first, though, by the time we get to the user's
 1093 # program the sequence number is already pretty high, which could be
 1094 # distracting if you're trying to tell OPs apart. Therefore we'd like to
 1095 # subtract an offset from all the sequence numbers we display, to
 1096 # restore the simpler view of the world. The trick is to know what that
 1097 # offset will be, when we're still compiling B::Concise!  If we
 1098 # hardcoded a value, it would have to change every time B::Concise or
 1099 # other modules we use do. To help a little, what we do here is compile
 1100 # a little code at the end of the module, and compute the base sequence
 1101 # number for the user's program as being a small offset later, so all we
 1102 # have to worry about are changes in the offset.
 1103 
 1104 # When you say "perl -MO=Concise -e '$a'", the output should look like:
 1105 
 1106 # 4  <@> leave[t1] vKP/REFC ->(end)
 1107 # 1     <0> enter ->2
 1108  #^ smallest OP sequence number should be 1
 1109 # 2     <;> nextstate(main 1 -e:1) v ->3
 1110  #                         ^ smallest COP sequence number should be 1
 1111 # -     <1> ex-rv2sv vK/1 ->4
 1112 # 3        <$> gvsv(*a) s ->4
 1113 
 1114 # If the second of the marked numbers there isn't 1, it means you need
 1115 # to update the corresponding magic number in the next line.
 1116 # Remember, this needs to stay the last things in the module.
 1117 
 1118 my $cop_seq_mnum = 12;
 1119 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
 1120 
 1121 1;
 1122 
 1123 __END__
 1124 
 1125 =head1 NAME
 1126 
 1127 B::Concise - Walk Perl syntax tree, printing concise info about ops
 1128 
 1129 =head1 SYNOPSIS
 1130 
 1131     perl -MO=Concise[,OPTIONS] foo.pl
 1132 
 1133     use B::Concise qw(set_style add_callback);
 1134 
 1135 =head1 DESCRIPTION
 1136 
 1137 This compiler backend prints the internal OPs of a Perl program's syntax
 1138 tree in one of several space-efficient text formats suitable for debugging
 1139 the inner workings of perl or other compiler backends. It can print OPs in
 1140 the order they appear in the OP tree, in the order they will execute, or
 1141 in a text approximation to their tree structure, and the format of the
 1142 information displayed is customizable. Its function is similar to that of
 1143 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
 1144 sophisticated and flexible.
 1145 
 1146 =head1 EXAMPLE
 1147 
 1148 Here's two outputs (or 'renderings'), using the -exec and -basic
 1149 (i.e. default) formatting conventions on the same code snippet.
 1150 
 1151     % perl -MO=Concise,-exec -e '$a = $b + 42'
 1152     1  <0> enter
 1153     2  <;> nextstate(main 1 -e:1) v
 1154     3  <#> gvsv[*b] s
 1155     4  <$> const[IV 42] s
 1156  *  5  <2> add[t3] sK/2
 1157     6  <#> gvsv[*a] s
 1158     7  <2> sassign vKS/2
 1159     8  <@> leave[1 ref] vKP/REFC
 1160 
 1161 In this -exec rendering, each opcode is executed in the order shown.
 1162 The add opcode, marked with '*', is discussed in more detail.
 1163 
 1164 The 1st column is the op's sequence number, starting at 1, and is
 1165 displayed in base 36 by default.  Here they're purely linear; the
 1166 sequences are very helpful when looking at code with loops and
 1167 branches.
 1168 
 1169 The symbol between angle brackets indicates the op's type, for
 1170 example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
 1171 used in threaded perls. (see L</"OP class abbreviations">).
 1172 
 1173 The opname, as in B<'add[t1]'>, may be followed by op-specific
 1174 information in parentheses or brackets (ex B<'[t1]'>).
 1175 
 1176 The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
 1177 abbreviations">).
 1178 
 1179     % perl -MO=Concise -e '$a = $b + 42'
 1180     8  <@> leave[1 ref] vKP/REFC ->(end)
 1181     1     <0> enter ->2
 1182     2     <;> nextstate(main 1 -e:1) v ->3
 1183     7     <2> sassign vKS/2 ->8
 1184  *  5        <2> add[t1] sK/2 ->6
 1185     -           <1> ex-rv2sv sK/1 ->4
 1186     3              <$> gvsv(*b) s ->4
 1187     4           <$> const(IV 42) s ->5
 1188     -        <1> ex-rv2sv sKRM*/1 ->7
 1189     6           <$> gvsv(*a) s ->7
 1190 
 1191 The default rendering is top-down, so they're not in execution order.
 1192 This form reflects the way the stack is used to parse and evaluate
 1193 expressions; the add operates on the two terms below it in the tree.
 1194 
 1195 Nullops appear as C<ex-opname>, where I<opname> is an op that has been
 1196 optimized away by perl.  They're displayed with a sequence-number of
 1197 '-', because they are not executed (they don't appear in previous
 1198 example), they're printed here because they reflect the parse.
 1199 
 1200 The arrow points to the sequence number of the next op; they're not
 1201 displayed in -exec mode, for obvious reasons.
 1202 
 1203 Note that because this rendering was done on a non-threaded perl, the
 1204 PADOPs in the previous examples are now SVOPs, and some (but not all)
 1205 of the square brackets have been replaced by round ones.  This is a
 1206 subtle feature to provide some visual distinction between renderings
 1207 on threaded and un-threaded perls.
 1208 
 1209 
 1210 =head1 OPTIONS
 1211 
 1212 Arguments that don't start with a hyphen are taken to be the names of
 1213 subroutines or formats to render; if no
 1214 such functions are specified, the main
 1215 body of the program (outside any subroutines, and not including use'd
 1216 or require'd files) is rendered.  Passing C<BEGIN>, C<UNITCHECK>,
 1217 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
 1218 special blocks to be printed.  Arguments must follow options.
 1219 
 1220 Options affect how things are rendered (ie printed).  They're presented
 1221 here by their visual effect, 1st being strongest.  They're grouped
 1222 according to how they interrelate; within each group the options are
 1223 mutually exclusive (unless otherwise stated).
 1224 
 1225 =head2 Options for Opcode Ordering
 1226 
 1227 These options control the 'vertical display' of opcodes.  The display
 1228 'order' is also called 'mode' elsewhere in this document.
 1229 
 1230 =over 4
 1231 
 1232 =item B<-basic>
 1233 
 1234 Print OPs in the order they appear in the OP tree (a preorder
 1235 traversal, starting at the root). The indentation of each OP shows its
 1236 level in the tree, and the '->' at the end of the line indicates the
 1237 next opcode in execution order.  This mode is the default, so the flag
 1238 is included simply for completeness.
 1239 
 1240 =item B<-exec>
 1241 
 1242 Print OPs in the order they would normally execute (for the majority
 1243 of constructs this is a postorder traversal of the tree, ending at the
 1244 root). In most cases the OP that usually follows a given OP will
 1245 appear directly below it; alternate paths are shown by indentation. In
 1246 cases like loops when control jumps out of a linear path, a 'goto'
 1247 line is generated.
 1248 
 1249 =item B<-tree>
 1250 
 1251 Print OPs in a text approximation of a tree, with the root of the tree
 1252 at the left and 'left-to-right' order of children transformed into
 1253 'top-to-bottom'. Because this mode grows both to the right and down,
 1254 it isn't suitable for large programs (unless you have a very wide
 1255 terminal).
 1256 
 1257 =back
 1258 
 1259 =head2 Options for Line-Style
 1260 
 1261 These options select the line-style (or just style) used to render
 1262 each opcode, and dictates what info is actually printed into each line.
 1263 
 1264 =over 4
 1265 
 1266 =item B<-concise>
 1267 
 1268 Use the author's favorite set of formatting conventions. This is the
 1269 default, of course.
 1270 
 1271 =item B<-terse>
 1272 
 1273 Use formatting conventions that emulate the output of B<B::Terse>. The
 1274 basic mode is almost indistinguishable from the real B<B::Terse>, and the
 1275 exec mode looks very similar, but is in a more logical order and lacks
 1276 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
 1277 is only vaguely reminiscent of B<B::Terse>.
 1278 
 1279 =item B<-linenoise>
 1280 
 1281 Use formatting conventions in which the name of each OP, rather than being
 1282 written out in full, is represented by a one- or two-character abbreviation.
 1283 This is mainly a joke.
 1284 
 1285 =item B<-debug>
 1286 
 1287 Use formatting conventions reminiscent of CPAN module B<B::Debug>; these aren't
 1288 very concise at all.
 1289 
 1290 =item B<-env>
 1291 
 1292 Use formatting conventions read from the environment variables
 1293 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
 1294 
 1295 =back
 1296 
 1297 =head2 Options for tree-specific formatting
 1298 
 1299 =over 4
 1300 
 1301 =item B<-compact>
 1302 
 1303 Use a tree format in which the minimum amount of space is used for the
 1304 lines connecting nodes (one character in most cases). This squeezes out
 1305 a few precious columns of screen real estate.
 1306 
 1307 =item B<-loose>
 1308 
 1309 Use a tree format that uses longer edges to separate OP nodes. This format
 1310 tends to look better than the compact one, especially in ASCII, and is
 1311 the default.
 1312 
 1313 =item B<-vt>
 1314 
 1315 Use tree connecting characters drawn from the VT100 line-drawing set.
 1316 This looks better if your terminal supports it.
 1317 
 1318 =item B<-ascii>
 1319 
 1320 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
 1321 look as clean as the VT100 characters, but they'll work with almost any
 1322 terminal (or the horizontal scrolling mode of less(1)) and are suitable
 1323 for text documentation or email. This is the default.
 1324 
 1325 =back
 1326 
 1327 These are pairwise exclusive, i.e. compact or loose, vt or ascii.
 1328 
 1329 =head2 Options controlling sequence numbering
 1330 
 1331 =over 4
 1332 
 1333 =item B<-base>I<n>
 1334 
 1335 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
 1336 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
 1337 for 37 will be 'A', and so on until 62. Values greater than 62 are not
 1338 currently supported. The default is 36.
 1339 
 1340 =item B<-bigendian>
 1341 
 1342 Print sequence numbers with the most significant digit first. This is the
 1343 usual convention for Arabic numerals, and the default.
 1344 
 1345 =item B<-littleendian>
 1346 
 1347 Print sequence numbers with the least significant digit first.  This is
 1348 obviously mutually exclusive with bigendian.
 1349 
 1350 =back
 1351 
 1352 =head2 Other options
 1353 
 1354 =over 4
 1355 
 1356 =item B<-src>
 1357 
 1358 With this option, the rendering of each statement (starting with the
 1359 nextstate OP) will be preceded by the 1st line of source code that
 1360 generates it.  For example:
 1361 
 1362     1  <0> enter
 1363     # 1: my $i;
 1364     2  <;> nextstate(main 1 junk.pl:1) v:{
 1365     3  <0> padsv[$i:1,10] vM/LVINTRO
 1366     # 3: for $i (0..9) {
 1367     4  <;> nextstate(main 3 junk.pl:3) v:{
 1368     5  <0> pushmark s
 1369     6  <$> const[IV 0] s
 1370     7  <$> const[IV 9] s
 1371     8  <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS
 1372     k  <0> iter s
 1373     l  <|> and(other->9) vK/1
 1374     # 4:     print "line ";
 1375     9      <;> nextstate(main 2 junk.pl:4) v
 1376     a      <0> pushmark s
 1377     b      <$> const[PV "line "] s
 1378     c      <@> print vK
 1379     # 5:     print "$i\n";
 1380     ...
 1381 
 1382 =item B<-stash="somepackage">
 1383 
 1384 With this, "somepackage" will be required, then the stash is
 1385 inspected, and each function is rendered.
 1386 
 1387 =back
 1388 
 1389 The following options are pairwise exclusive.
 1390 
 1391 =over 4
 1392 
 1393 =item B<-main>
 1394 
 1395 Include the main program in the output, even if subroutines were also
 1396 specified.  This rendering is normally suppressed when a subroutine
 1397 name or reference is given.
 1398 
 1399 =item B<-nomain>
 1400 
 1401 This restores the default behavior after you've changed it with '-main'
 1402 (it's not normally needed).  If no subroutine name/ref is given, main is
 1403 rendered, regardless of this flag.
 1404 
 1405 =item B<-nobanner>
 1406 
 1407 Renderings usually include a banner line identifying the function name
 1408 or stringified subref.  This suppresses the printing of the banner.
 1409 
 1410 TBC: Remove the stringified coderef; while it provides a 'cookie' for
 1411 each function rendered, the cookies used should be 1,2,3.. not a
 1412 random hex-address.  It also complicates string comparison of two
 1413 different trees.
 1414 
 1415 =item B<-banner>
 1416 
 1417 restores default banner behavior.
 1418 
 1419 =item B<-banneris> => subref
 1420 
 1421 TBC: a hookpoint (and an option to set it) for a user-supplied
 1422 function to produce a banner appropriate for users needs.  It's not
 1423 ideal, because the rendering-state variables, which are a natural
 1424 candidate for use in concise.t, are unavailable to the user.
 1425 
 1426 =back
 1427 
 1428 =head2 Option Stickiness
 1429 
 1430 If you invoke Concise more than once in a program, you should know that
 1431 the options are 'sticky'.  This means that the options you provide in
 1432 the first call will be remembered for the 2nd call, unless you
 1433 re-specify or change them.
 1434 
 1435 =head1 ABBREVIATIONS
 1436 
 1437 The concise style uses symbols to convey maximum info with minimal
 1438 clutter (like hex addresses).  With just a little practice, you can
 1439 start to see the flowers, not just the branches, in the trees.
 1440 
 1441 =head2 OP class abbreviations
 1442 
 1443 These symbols appear before the op-name, and indicate the
 1444 B:: namespace that represents the ops in your Perl code.
 1445 
 1446     0      OP (aka BASEOP)  An OP with no children
 1447     1      UNOP             An OP with one child
 1448     +      UNOP_AUX         A UNOP with auxillary fields
 1449     2      BINOP            An OP with two children
 1450     |      LOGOP            A control branch OP
 1451     @      LISTOP           An OP that could have lots of children
 1452     /      PMOP             An OP with a regular expression
 1453     $      SVOP             An OP with an SV
 1454     "      PVOP             An OP with a string
 1455     {      LOOP             An OP that holds pointers for a loop
 1456     ;      COP              An OP that marks the start of a statement
 1457     #      PADOP            An OP with a GV on the pad
 1458     .      METHOP           An OP with method call info
 1459 
 1460 =head2 OP flags abbreviations
 1461 
 1462 OP flags are either public or private.  The public flags alter the
 1463 behavior of each opcode in consistent ways, and are represented by 0
 1464 or more single characters.
 1465 
 1466     v      OPf_WANT_VOID    Want nothing (void context)
 1467     s      OPf_WANT_SCALAR  Want single value (scalar context)
 1468     l      OPf_WANT_LIST    Want list of any length (list context)
 1469                             Want is unknown
 1470     K      OPf_KIDS         There is a firstborn child.
 1471     P      OPf_PARENS       This operator was parenthesized.
 1472                              (Or block needs explicit scope entry.)
 1473     R      OPf_REF          Certified reference.
 1474                              (Return container, not containee).
 1475     M      OPf_MOD          Will modify (lvalue).
 1476     S      OPf_STACKED      Some arg is arriving on the stack.
 1477     *      OPf_SPECIAL      Do something weird for this op (see op.h)
 1478 
 1479 Private flags, if any are set for an opcode, are displayed after a '/'
 1480 
 1481     8  <@> leave[1 ref] vKP/REFC ->(end)
 1482     7     <2> sassign vKS/2 ->8
 1483 
 1484 They're opcode specific, and occur less often than the public ones, so
 1485 they're represented by short mnemonics instead of single-chars; see
 1486 B::Op_private and F<regen/op_private> for more details.
 1487 
 1488 =head1 FORMATTING SPECIFICATIONS
 1489 
 1490 For each line-style ('concise', 'terse', 'linenoise', etc.) there are
 1491 3 format-specs which control how OPs are rendered.
 1492 
 1493 The first is the 'default' format, which is used in both basic and exec
 1494 modes to print all opcodes.  The 2nd, goto-format, is used in exec
 1495 mode when branches are encountered.  They're not real opcodes, and are
 1496 inserted to look like a closing curly brace.  The tree-format is tree
 1497 specific.
 1498 
 1499 When a line is rendered, the correct format-spec is copied and scanned
 1500 for the following items; data is substituted in, and other
 1501 manipulations like basic indenting are done, for each opcode rendered.
 1502 
 1503 There are 3 kinds of items that may be populated; special patterns,
 1504 #vars, and literal text, which is copied verbatim.  (Yes, it's a set
 1505 of s///g steps.)
 1506 
 1507 =head2 Special Patterns
 1508 
 1509 These items are the primitives used to perform indenting, and to
 1510 select text from amongst alternatives.
 1511 
 1512 =over 4
 1513 
 1514 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
 1515 
 1516 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
 1517 
 1518 =item B<(*(>I<text>B<)*)>
 1519 
 1520 Generates one copy of I<text> for each indentation level.
 1521 
 1522 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
 1523 
 1524 Generates one fewer copies of I<text1> than the indentation level, followed
 1525 by one copy of I<text2> if the indentation level is more than 0.
 1526 
 1527 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
 1528 
 1529 If the value of I<var> is true (not empty or zero), generates the
 1530 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
 1531 nothing.
 1532 
 1533 =item B<~>
 1534 
 1535 Any number of tildes and surrounding whitespace will be collapsed to
 1536 a single space.
 1537 
 1538 =back
 1539 
 1540 =head2 # Variables
 1541 
 1542 These #vars represent opcode properties that you may want as part of
 1543 your rendering.  The '#' is intended as a private sigil; a #var's
 1544 value is interpolated into the style-line, much like "read $this".
 1545 
 1546 These vars take 3 forms:
 1547 
 1548 =over 4
 1549 
 1550 =item B<#>I<var>
 1551 
 1552 A property named 'var' is assumed to exist for the opcodes, and is
 1553 interpolated into the rendering.
 1554 
 1555 =item B<#>I<var>I<N>
 1556 
 1557 Generates the value of I<var>, left justified to fill I<N> spaces.
 1558 Note that this means while you can have properties 'foo' and 'foo2',
 1559 you cannot render 'foo2', but you could with 'foo2a'.  You would be
 1560 wise not to rely on this behavior going forward ;-)
 1561 
 1562 =item B<#>I<Var>
 1563 
 1564 This ucfirst form of #var generates a tag-value form of itself for
 1565 display; it converts '#Var' into a 'Var => #var' style, which is then
 1566 handled as described above.  (Imp-note: #Vars cannot be used for
 1567 conditional-fills, because the => #var transform is done after the check
 1568 for #Var's value).
 1569 
 1570 =back
 1571 
 1572 The following variables are 'defined' by B::Concise; when they are
 1573 used in a style, their respective values are plugged into the
 1574 rendering of each opcode.
 1575 
 1576 Only some of these are used by the standard styles, the others are
 1577 provided for you to delve into optree mechanics, should you wish to
 1578 add a new style (see L</add_style> below) that uses them.  You can
 1579 also add new ones using L</add_callback>.
 1580 
 1581 =over 4
 1582 
 1583 =item B<#addr>
 1584 
 1585 The address of the OP, in hexadecimal.
 1586 
 1587 =item B<#arg>
 1588 
 1589 The OP-specific information of the OP (such as the SV for an SVOP, the
 1590 non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
 1591 
 1592 =item B<#class>
 1593 
 1594 The B-determined class of the OP, in all caps.
 1595 
 1596 =item B<#classsym>
 1597 
 1598 A single symbol abbreviating the class of the OP.
 1599 
 1600 =item B<#coplabel>
 1601 
 1602 The label of the statement or block the OP is the start of, if any.
 1603 
 1604 =item B<#exname>
 1605 
 1606 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
 1607 
 1608 =item B<#extarg>
 1609 
 1610 The target of the OP, or nothing for a nulled OP.
 1611 
 1612 =item B<#firstaddr>
 1613 
 1614 The address of the OP's first child, in hexadecimal.
 1615 
 1616 =item B<#flags>
 1617 
 1618 The OP's flags, abbreviated as a series of symbols.
 1619 
 1620 =item B<#flagval>
 1621 
 1622 The numeric value of the OP's flags.
 1623 
 1624 =item B<#hints>
 1625 
 1626 The COP's hint flags, rendered with abbreviated names if possible. An empty
 1627 string if this is not a COP. Here are the symbols used:
 1628 
 1629     $ strict refs
 1630     & strict subs
 1631     * strict vars
 1632    x$ explicit use/no strict refs
 1633    x& explicit use/no strict subs
 1634    x* explicit use/no strict vars
 1635     i integers
 1636     l locale
 1637     b bytes
 1638     { block scope
 1639     % localise %^H
 1640     < open in
 1641     > open out
 1642     I overload int
 1643     F overload float
 1644     B overload binary
 1645     S overload string
 1646     R overload re
 1647     T taint
 1648     E eval
 1649     X filetest access
 1650     U utf-8
 1651 
 1652     us      use feature 'unicode_strings'
 1653     fea=NNN feature bundle number
 1654 
 1655 =item B<#hintsval>
 1656 
 1657 The numeric value of the COP's hint flags, or an empty string if this is not
 1658 a COP.
 1659 
 1660 =item B<#hyphseq>
 1661 
 1662 The sequence number of the OP, or a hyphen if it doesn't have one.
 1663 
 1664 =item B<#label>
 1665 
 1666 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
 1667 mode, or empty otherwise.
 1668 
 1669 =item B<#lastaddr>
 1670 
 1671 The address of the OP's last child, in hexadecimal.
 1672 
 1673 =item B<#name>
 1674 
 1675 The OP's name.
 1676 
 1677 =item B<#NAME>
 1678 
 1679 The OP's name, in all caps.
 1680 
 1681 =item B<#next>
 1682 
 1683 The sequence number of the OP's next OP.
 1684 
 1685 =item B<#nextaddr>
 1686 
 1687 The address of the OP's next OP, in hexadecimal.
 1688 
 1689 =item B<#noise>
 1690 
 1691 A one- or two-character abbreviation for the OP's name.
 1692 
 1693 =item B<#private>
 1694 
 1695 The OP's private flags, rendered with abbreviated names if possible.
 1696 
 1697 =item B<#privval>
 1698 
 1699 The numeric value of the OP's private flags.
 1700 
 1701 =item B<#seq>
 1702 
 1703 The sequence number of the OP. Note that this is a sequence number
 1704 generated by B::Concise.
 1705 
 1706 =item B<#opt>
 1707 
 1708 Whether or not the op has been optimized by the peephole optimizer.
 1709 
 1710 =item B<#sibaddr>
 1711 
 1712 The address of the OP's next youngest sibling, in hexadecimal.
 1713 
 1714 =item B<#svaddr>
 1715 
 1716 The address of the OP's SV, if it has an SV, in hexadecimal.
 1717 
 1718 =item B<#svclass>
 1719 
 1720 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
 1721 
 1722 =item B<#svval>
 1723 
 1724 The value of the OP's SV, if it has one, in a short human-readable format.
 1725 
 1726 =item B<#targ>
 1727 
 1728 The numeric value of the OP's targ.
 1729 
 1730 =item B<#targarg>
 1731 
 1732 The name of the variable the OP's targ refers to, if any, otherwise the
 1733 letter t followed by the OP's targ in decimal.
 1734 
 1735 =item B<#targarglife>
 1736 
 1737 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
 1738 the variable's lifetime (or 'end' for a variable in an open scope) for a
 1739 variable.
 1740 
 1741 =item B<#typenum>
 1742 
 1743 The numeric value of the OP's type, in decimal.
 1744 
 1745 =back
 1746 
 1747 =head1 One-Liner Command tips
 1748 
 1749 =over 4
 1750 
 1751 =item perl -MO=Concise,bar foo.pl
 1752 
 1753 Renders only bar() from foo.pl.  To see main, drop the ',bar'.  To see
 1754 both, add ',-main'
 1755 
 1756 =item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
 1757 
 1758 Identifies md5 as an XS function.  The export is needed so that BC can
 1759 find it in main.
 1760 
 1761 =item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
 1762 
 1763 Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
 1764 Although POSIX isn't entirely consistent across platforms, this is
 1765 likely to be present in virtually all of them.
 1766 
 1767 =item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
 1768 
 1769 This renders a print statement, which includes a call to the function.
 1770 It's identical to rendering a file with a use call and that single
 1771 statement, except for the filename which appears in the nextstate ops.
 1772 
 1773 =item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
 1774 
 1775 This is B<very> similar to previous, only the first two ops differ.  This
 1776 subroutine rendering is more representative, insofar as a single main
 1777 program will have many subs.
 1778 
 1779 =item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
 1780 
 1781 This renders all functions in the B::Concise package with the source
 1782 lines.  It eschews the O framework so that the stashref can be passed
 1783 directly to B::Concise::compile().  See -stash option for a more
 1784 convenient way to render a package.
 1785 
 1786 =back
 1787 
 1788 =head1 Using B::Concise outside of the O framework
 1789 
 1790 The common (and original) usage of B::Concise was for command-line
 1791 renderings of simple code, as given in EXAMPLE.  But you can also use
 1792 B<B::Concise> from your code, and call compile() directly, and
 1793 repeatedly.  By doing so, you can avoid the compile-time only
 1794 operation of O.pm, and even use the debugger to step through
 1795 B::Concise::compile() itself.
 1796 
 1797 Once you're doing this, you may alter Concise output by adding new
 1798 rendering styles, and by optionally adding callback routines which
 1799 populate new variables, if such were referenced from those (just
 1800 added) styles.  
 1801 
 1802 =head2 Example: Altering Concise Renderings
 1803 
 1804     use B::Concise qw(set_style add_callback);
 1805     add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
 1806     add_callback
 1807       ( sub {
 1808             my ($h, $op, $format, $level, $stylename) = @_;
 1809             $h->{variable} = some_func($op);
 1810         });
 1811     $walker = B::Concise::compile(@options,@subnames,@subrefs);
 1812     $walker->();
 1813 
 1814 =head2 set_style()
 1815 
 1816 B<set_style> accepts 3 arguments, and updates the three format-specs
 1817 comprising a line-style (basic-exec, goto, tree).  It has one minor
 1818 drawback though; it doesn't register the style under a new name.  This
 1819 can become an issue if you render more than once and switch styles.
 1820 Thus you may prefer to use add_style() and/or set_style_standard()
 1821 instead.
 1822 
 1823 =head2 set_style_standard($name)
 1824 
 1825 This restores one of the standard line-styles: C<terse>, C<concise>,
 1826 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
 1827 names previously defined with add_style().
 1828 
 1829 =head2 add_style ()
 1830 
 1831 This subroutine accepts a new style name and three style arguments as
 1832 above, and creates, registers, and selects the newly named style.  It is
 1833 an error to re-add a style; call set_style_standard() to switch between
 1834 several styles.
 1835 
 1836 =head2 add_callback ()
 1837 
 1838 If your newly minted styles refer to any new #variables, you'll need
 1839 to define a callback subroutine that will populate (or modify) those
 1840 variables.  They are then available for use in the style you've
 1841 chosen.
 1842 
 1843 The callbacks are called for each opcode visited by Concise, in the
 1844 same order as they are added.  Each subroutine is passed five
 1845 parameters.
 1846 
 1847   1. A hashref, containing the variable names and values which are
 1848      populated into the report-line for the op
 1849   2. the op, as a B<B::OP> object
 1850   3. a reference to the format string
 1851   4. the formatting (indent) level
 1852   5. the selected stylename
 1853 
 1854 To define your own variables, simply add them to the hash, or change
 1855 existing values if you need to.  The level and format are passed in as
 1856 references to scalars, but it is unlikely that they will need to be
 1857 changed or even used.
 1858 
 1859 =head2 Running B::Concise::compile()
 1860 
 1861 B<compile> accepts options as described above in L</OPTIONS>, and
 1862 arguments, which are either coderefs, or subroutine names.
 1863 
 1864 It constructs and returns a $treewalker coderef, which when invoked,
 1865 traverses, or walks, and renders the optrees of the given arguments to
 1866 STDOUT.  You can reuse this, and can change the rendering style used
 1867 each time; thereafter the coderef renders in the new style.
 1868 
 1869 B<walk_output> lets you change the print destination from STDOUT to
 1870 another open filehandle, or into a string passed as a ref (unless
 1871 you've built perl with -Uuseperlio).
 1872 
 1873   my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
 1874   walk_output(\my $buf);
 1875   $walker->();                  # 1 renders -terse
 1876   set_style_standard('concise');    # 2
 1877   $walker->();                  # 2 renders -concise
 1878   $walker->(@new);          # 3 renders whatever
 1879   print "3 different renderings: terse, concise, and @new: $buf\n";
 1880 
 1881 When $walker is called, it traverses the subroutines supplied when it
 1882 was created, and renders them using the current style.  You can change
 1883 the style afterwards in several different ways:
 1884 
 1885   1. call C<compile>, altering style or mode/order
 1886   2. call C<set_style_standard>
 1887   3. call $walker, passing @new options
 1888 
 1889 Passing new options to the $walker is the easiest way to change
 1890 amongst any pre-defined styles (the ones you add are automatically
 1891 recognized as options), and is the only way to alter rendering order
 1892 without calling compile again.  Note however that rendering state is
 1893 still shared amongst multiple $walker objects, so they must still be
 1894 used in a coordinated manner.
 1895 
 1896 =head2 B::Concise::reset_sequence()
 1897 
 1898 This function (not exported) lets you reset the sequence numbers (note
 1899 that they're numbered arbitrarily, their goal being to be human
 1900 readable).  Its purpose is mostly to support testing, i.e. to compare
 1901 the concise output from two identical anonymous subroutines (but
 1902 different instances).  Without the reset, B::Concise, seeing that
 1903 they're separate optrees, generates different sequence numbers in
 1904 the output.
 1905 
 1906 =head2 Errors
 1907 
 1908 Errors in rendering (non-existent function-name, non-existent coderef)
 1909 are written to the STDOUT, or wherever you've set it via
 1910 walk_output().
 1911 
 1912 Errors using the various *style* calls, and bad args to walk_output(),
 1913 result in die().  Use an eval if you wish to catch these errors and
 1914 continue processing.
 1915 
 1916 =head1 AUTHOR
 1917 
 1918 Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
 1919 
 1920 =cut