ext/B/B/Concise.pm

   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.003";
  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 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