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         if ($] >= 5.011) {
 721             while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
 722                 $hr->{svval} .= "\\";
 723                 $sv = $sv->RV;
 724             }
 725         } else {
 726             while (class($sv) eq "RV") {
 727                 $hr->{svval} .= "\\";
 728                 $sv = $sv->RV;
 729             }
 730         }
 731         if (class($sv) eq "SPECIAL") {
 732             $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no",
 733                              '', '', '', "sv_zero"]->[$$sv];
 734         } elsif ($preferpv
 735               && ($sv->FLAGS & SVf_POK)) {
 736             $hr->{svval} .= cstring($sv->PV);
 737         } elsif ($sv->FLAGS & SVf_NOK) {
 738             $hr->{svval} .= $sv->NV;
 739         } elsif ($sv->FLAGS & SVf_IOK) {
 740             $hr->{svval} .= $sv->int_value;
 741         } elsif ($sv->FLAGS & SVf_POK) {
 742             $hr->{svval} .= cstring($sv->PV);
 743         } elsif (class($sv) eq "HV") {
 744             $hr->{svval} .= 'HASH';
 745         } elsif (class($sv) eq "AV") {
 746             $hr->{svval} .= 'ARRAY';
 747         } elsif (class($sv) eq "CV") {
 748             if ($sv->CvFLAGS & CVf_ANON) {
 749                 $hr->{svval} .= 'CODE';
 750             } elsif ($sv->CvFLAGS & CVf_NAMED) {
 751                 $hr->{svval} .= "&";
 752                 unless ($sv->CvFLAGS & CVf_LEXICAL) {
 753                     my $stash = $sv->STASH;
 754                     unless (class($stash) eq "SPECIAL") {
 755                         $hr->{svval} .= $stash->NAME . "::";
 756                     }
 757                 }
 758                 $hr->{svval} .= $sv->NAME_HEK;
 759             } else {
 760                 $hr->{svval} .= "&";
 761                 $sv = $sv->GV;
 762                 my $stash = $sv->STASH;
 763                 unless (class($stash) eq "SPECIAL") {
 764                     $hr->{svval} .= $stash->NAME . "::";
 765                 }
 766                 $hr->{svval} .= $sv->SAFENAME;
 767             }
 768         }
 769
 770         $hr->{svval} = 'undef' unless defined $hr->{svval};
 771         my $out = $hr->{svclass};
 772         return $out .= " $hr->{svval}" ;
 773     }
 774 }
 775
 776 my %srclines;
 777
 778 sub fill_srclines {
 779     my $fullnm = shift;
 780     if ($fullnm eq '-e') {
 781         $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
 782         return;
 783     }
 784     open (my $fh, '<', $fullnm)
 785         or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
 786         and return;
 787     my @l = <$fh>;
 788     chomp @l;
 789     unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
 790     $srclines{$fullnm} = \@l;
 791 }
 792
 793 # Given a pad target, return the pad var's name and cop range /
 794 # fakeness, or failing that, its target number.
 795 # e.g.
 796 #   ('$i', '$i:5,7')
 797 # or
 798 #   ('$i', '$i:fake:a')
 799 # or
 800 #   ('t5', 't5')
 801
 802 sub padname {
 803     my ($targ) = @_;
 804
 805     my ($targarg, $targarglife);
 806     my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ];
 807     if (defined $padname and class($padname) ne "SPECIAL" and
 808         $padname->LEN)
 809     {
 810         $targarg  = $padname->PVX;
 811         if ($padname->FLAGS & SVf_FAKE) {
 812             # These changes relate to the jumbo closure fix.
 813             # See changes 19939 and 20005
 814             my $fake = '';
 815             $fake .= 'a'
 816                 if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
 817             $fake .= 'm'
 818                 if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
 819             $fake .= ':' . $padname->PARENT_PAD_INDEX
 820                 if $curcv->CvFLAGS & CVf_ANON;
 821             $targarglife = "$targarg:FAKE:$fake";
 822         }
 823         else {
 824             my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
 825             my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
 826             $finish = "end" if $finish == 999999999 - $cop_seq_base;
 827             $targarglife = "$targarg:$intro,$finish";
 828         }
 829     } else {
 830         $targarglife = $targarg = "t" . $targ;
 831     }
 832     return $targarg, $targarglife;
 833 }
 834
 835
 836
 837 sub concise_op {
 838     my ($op, $level, $format) = @_;
 839     my %h;
 840     $h{exname} = $h{name} = $op->name;
 841     $h{NAME} = uc $h{name};
 842     $h{class} = class($op);
 843     $h{extarg} = $h{targ} = $op->targ;
 844     $h{extarg} = "" unless $h{extarg};
 845     $h{privval} = $op->private;
 846     # for null ops, targ holds the old type
 847     my $origname = $h{name} eq "null" && $h{targ}
 848       ? substr(ppname($h{targ}), 3)
 849       : $h{name};
 850     $h{private} = private_flags($origname, $op->private);
 851     if ($op->folded) {
 852       $h{private} &&= "$h{private},";
 853       $h{private} .= "FOLD";
 854     }
 855
 856     if ($h{name} ne $origname) { # a null op
 857         $h{exname} = "ex-$origname";
 858         $h{extarg} = "";
 859     } elsif ($h{private} =~ /\bREFC\b/) {
 860         # targ holds a reference count
 861         my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
 862         $h{targarglife} = $h{targarg} = "$h{targ} $refs";
 863     } elsif ($h{targ}) {
 864         my $count = $h{name} eq 'padrange'
 865             ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'})
 866             : 1;
 867         my (@targarg, @targarglife);
 868         for my $i (0..$count-1) {
 869             my ($targarg, $targarglife) = padname($h{targ} + $i);
 870             push @targarg,     $targarg;
 871             push @targarglife, $targarglife;
 872         }
 873         $h{targarg}     = join '; ', @targarg;
 874         $h{targarglife} = join '; ', @targarglife;
 875     }
 876
 877     $h{arg} = "";
 878     $h{svclass} = $h{svaddr} = $h{svval} = "";
 879     if ($h{class} eq "PMOP") {
 880         my $extra = '';
 881         my $precomp = $op->precomp;
 882         if (defined $precomp) {
 883             $precomp = cstring($precomp); # Escape literal control sequences
 884             $precomp = "/$precomp/";
 885         } else {
 886             $precomp = "";
 887         }
 888         if ($op->name eq 'subst') {
 889             if (class($op->pmreplstart) ne "NULL") {
 890                 undef $lastnext;
 891                 $extra = " replstart->" . seq($op->pmreplstart);
 892             }
 893         }
 894         elsif ($op->name eq 'split') {
 895             if (    ($op->private & OPpSPLIT_ASSIGN) # @array  = split
 896                  && (not $op->flags & OPf_STACKED))  # @{expr} = split
 897             {
 898                 # with C<@array = split(/pat/, str);>,
 899                 #  array is stored in /pat/'s pmreplroot; either
 900                 # as an integer index into the pad (for a lexical array)
 901                 # or as GV for a package array (which will be a pad index
 902                 # on threaded builds)
 903
 904                 if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) {
 905                     my $off = $op->pmreplroot; # union with op_pmtargetoff
 906                     my ($name, $full) = padname($off);
 907                     $extra = " => $full";
 908                 }
 909                 else {
 910                     # union with op_pmtargetoff, op_pmtargetgv
 911                     my $gv = $op->pmreplroot;
 912                     if (!ref($gv)) {
 913                         # the value is actually a pad offset
 914                         $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
 915                     }
 916                     else {
 917                         # unthreaded: its a GV
 918                         $gv = $gv->NAME;
 919                     }
 920                     $extra = " => \@$gv";
 921                 }
 922             }
 923         }
 924         $h{arg} = "($precomp$extra)";
 925     } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
 926         $h{arg} = '("' . $op->pv . '")';
 927         $h{svval} = '"' . $op->pv . '"';
 928     } elsif ($h{class} eq "COP") {
 929         my $label = $op->label;
 930         $h{coplabel} = $label;
 931         $label = $label ? "$label: " : "";
 932         my $loc = $op->file;
 933         my $pathnm = $loc;
 934         $loc =~ s[.*/][];
 935         my $ln = $op->line;
 936         $loc .= ":$ln";
 937         my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
 938         $h{arg} = "($label$stash $cseq $loc)";
 939         if ($show_src) {
 940             fill_srclines($pathnm) unless exists $srclines{$pathnm};
 941             # Would love to retain Jim's use of // but this code needs to be
 942             # portable to 5.8.x
 943             my $line = $srclines{$pathnm}[$ln];
 944             $line = "-src unavailable under -e" unless defined $line;
 945             $h{src} = "$ln: $line";
 946         }
 947     } elsif ($h{class} eq "LOOP") {
 948         $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
 949           . " redo->" . seq($op->redoop) . ")";
 950     } elsif ($h{class} eq "LOGOP") {
 951         undef $lastnext;
 952         $h{arg} = "(other->" . seq($op->other) . ")";
 953         $h{otheraddr} = sprintf("%#x", $ {$op->other});
 954         if ($h{name} eq "argdefelem") {
 955             # targ used for element index
 956             $h{targarglife} = $h{targarg} = "";
 957             $h{arg} .= "[" . $op->targ . "]";
 958         }
 959     }
 960     elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
 961         unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
 962             my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
 963             if ($h{class} eq "PADOP" or !${$op->sv}) {
 964                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
 965                 $h{arg} = "[" . concise_sv($sv, \%h, 0) . "]";
 966                 $h{targarglife} = $h{targarg} = "";
 967             } else {
 968                 $h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")";
 969             }
 970         }
 971     }
 972     elsif ($h{class} eq "METHOP") {
 973         my $prefix = '';
 974         if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') {
 975             my $rclass_sv = $op->rclass;
 976             $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv]
 977                 unless ref $rclass_sv;
 978             $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", ';
 979         }
 980         if ($h{name} ne "method") {
 981             if (${$op->meth_sv}) {
 982                 $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")";
 983             } else {
 984                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
 985                 $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]";
 986                 $h{targarglife} = $h{targarg} = "";
 987             }
 988         }
 989     }
 990     elsif ($h{class} eq "UNOP_AUX") {
 991         $h{arg} = "(" . $op->string($curcv) . ")";
 992     }
 993
 994     $h{seq} = $h{hyphseq} = seq($op);
 995     $h{seq} = "" if $h{seq} eq "-";
 996     $h{opt} = $op->opt;
 997     $h{label} = $labels{$$op};
 998     $h{next} = $op->next;
 999     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
1000     $h{nextaddr} = sprintf("%#x", $ {$op->next});
1001     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
1002     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
1003     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
1004
1005     $h{classsym} = $opclass{$h{class}};
1006     $h{flagval} = $op->flags;
1007     $h{flags} = op_flags($op->flags);
1008     if ($op->can("hints")) {
1009       $h{hintsval} = $op->hints;
1010       $h{hints} = hints_flags($h{hintsval});
1011     } else {
1012       $h{hintsval} = $h{hints} = '';
1013     }
1014     $h{addr} = sprintf("%#x", $$op);
1015     $h{typenum} = $op->type;
1016     $h{noise} = $linenoise[$op->type];
1017
1018     return fmt_line(\%h, $op, $format, $level);
1019 }
1020
1021 sub B::OP::concise {
1022     my($op, $level) = @_;
1023     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
1024         # insert a 'goto' line
1025         my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
1026                      "addr" => sprintf("%#x", $$lastnext),
1027                      "goto" => seq($lastnext), # simplify goto '-' removal
1028              };
1029         print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
1030     }
1031     $lastnext = $op->next;
1032     print $walkHandle concise_op($op, $level, $format);
1033 }
1034
1035 # B::OP::terse (see Terse.pm) now just calls this
1036 sub b_terse {
1037     my($op, $level) = @_;
1038
1039     # This isn't necessarily right, but there's no easy way to get
1040     # from an OP to the right CV. This is a limitation of the
1041     # ->terse() interface style, and there isn't much to do about
1042     # it. In particular, we can die in concise_op if the main pad
1043     # isn't long enough, or has the wrong kind of entries, compared to
1044     # the pad a sub was compiled with. The fix for that would be to
1045     # make a backwards compatible "terse" format that never even
1046     # looked at the pad, just like the old B::Terse. I don't think
1047     # that's worth the effort, though.
1048     $curcv = main_cv unless $curcv;
1049
1050     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
1051         # insert a 'goto'
1052         my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
1053                  "addr" => sprintf("%#x", $$lastnext)};
1054         print # $walkHandle
1055             fmt_line($h, $op, $style{"terse"}[1], $level+1);
1056     }
1057     $lastnext = $op->next;
1058     print # $walkHandle
1059         concise_op($op, $level, $style{"terse"}[0]);
1060 }
1061
1062 sub tree {
1063     my $op = shift;
1064     my $level = shift;
1065     my $style = $tree_decorations[$tree_style];
1066     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
1067     my $name = concise_op($op, $level, $treefmt);
1068     if (not $op->flags & OPf_KIDS) {
1069         return $name . "\n";
1070     }
1071     my @lines;
1072     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
1073         push @lines, tree($kid, $level+1);
1074     }
1075     my $i;
1076     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
1077         $lines[$i] = $space . $lines[$i];
1078     }
1079     if ($i > 0) {
1080         $lines[$i] = $last . $lines[$i];
1081         while ($i-- > 1) {
1082             if (substr($lines[$i], 0, 1) eq " ") {
1083                 $lines[$i] = $nokid . $lines[$i];
1084             } else {
1085                 $lines[$i] = $kid . $lines[$i];
1086             }
1087         }
1088         $lines[$i] = $kids . $lines[$i];
1089     } else {
1090         $lines[0] = $single . $lines[0];
1091     }
1092     return("$name$lead" . shift @lines,
1093            map(" " x (length($name)+$size) . $_, @lines));
1094 }
1095
1096 # *** Warning: fragile kludge ahead ***
1097 # Because the B::* modules run in the same interpreter as the code
1098 # they're compiling, their presence tends to distort the view we have of
1099 # the code we're looking at. In particular, perl gives sequence numbers
1100 # to COPs. If the program we're looking at were run on its own, this
1101 # would start at 1. Because all of B::Concise and all the modules it
1102 # uses are compiled first, though, by the time we get to the user's
1103 # program the sequence number is already pretty high, which could be
1104 # distracting if you're trying to tell OPs apart. Therefore we'd like to
1105 # subtract an offset from all the sequence numbers we display, to
1106 # restore the simpler view of the world. The trick is to know what that
1107 # offset will be, when we're still compiling B::Concise!  If we
1108 # hardcoded a value, it would have to change every time B::Concise or
1109 # other modules we use do. To help a little, what we do here is compile
1110 # a little code at the end of the module, and compute the base sequence
1111 # number for the user's program as being a small offset later, so all we
1112 # have to worry about are changes in the offset.
1113
1114 # [For 5.8.x and earlier perl is generating sequence numbers for all ops,
1115 #  and using them to reference labels]
1116
1117
1118 # When you say "perl -MO=Concise -e '$a'", the output should look like:
1119
1120 # 4  <@> leave[t1] vKP/REFC ->(end)
1121 # 1     <0> enter ->2
1122  #^ smallest OP sequence number should be 1
1123 # 2     <;> nextstate(main 1 -e:1) v ->3
1124  #                         ^ smallest COP sequence number should be 1
1125 # -     <1> ex-rv2sv vK/1 ->4
1126 # 3        <$> gvsv(*a) s ->4
1127
1128 # If the second of the marked numbers there isn't 1, it means you need
1129 # to update the corresponding magic number in the next line.
1130 # Remember, this needs to stay the last things in the module.
1131
1132 my $cop_seq_mnum = 12;
1133 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
1134
1135 1;
1136
1137 __END__
1138
1139 =head1 NAME
1140
1141 B::Concise - Walk Perl syntax tree, printing concise info about ops
1142
1143 =head1 SYNOPSIS
1144
1145     perl -MO=Concise[,OPTIONS] foo.pl
1146
1147     use B::Concise qw(set_style add_callback);
1148
1149 =head1 DESCRIPTION
1150
1151 This compiler backend prints the internal OPs of a Perl program's syntax
1152 tree in one of several space-efficient text formats suitable for debugging
1153 the inner workings of perl or other compiler backends. It can print OPs in
1154 the order they appear in the OP tree, in the order they will execute, or
1155 in a text approximation to their tree structure, and the format of the
1156 information displayed is customizable. Its function is similar to that of
1157 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
1158 sophisticated and flexible.
1159
1160 =head1 EXAMPLE
1161
1162 Here's two outputs (or 'renderings'), using the -exec and -basic
1163 (i.e. default) formatting conventions on the same code snippet.
1164
1165     % perl -MO=Concise,-exec -e '$a = $b + 42'
1166     1  <0> enter
1167     2  <;> nextstate(main 1 -e:1) v
1168     3  <#> gvsv[*b] s
1169     4  <$> const[IV 42] s
1170  *  5  <2> add[t3] sK/2
1171     6  <#> gvsv[*a] s
1172     7  <2> sassign vKS/2
1173     8  <@> leave[1 ref] vKP/REFC
1174
1175 In this -exec rendering, each opcode is executed in the order shown.
1176 The add opcode, marked with '*', is discussed in more detail.
1177
1178 The 1st column is the op's sequence number, starting at 1, and is
1179 displayed in base 36 by default.  Here they're purely linear; the
1180 sequences are very helpful when looking at code with loops and
1181 branches.
1182
1183 The symbol between angle brackets indicates the op's type, for
1184 example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
1185 used in threaded perls. (see L</"OP class abbreviations">).
1186
1187 The opname, as in B<'add[t1]'>, may be followed by op-specific
1188 information in parentheses or brackets (ex B<'[t1]'>).
1189
1190 The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
1191 abbreviations">).
1192
1193     % perl -MO=Concise -e '$a = $b + 42'
1194     8  <@> leave[1 ref] vKP/REFC ->(end)
1195     1     <0> enter ->2
1196     2     <;> nextstate(main 1 -e:1) v ->3
1197     7     <2> sassign vKS/2 ->8
1198  *  5        <2> add[t1] sK/2 ->6
1199     -           <1> ex-rv2sv sK/1 ->4
1200     3              <$> gvsv(*b) s ->4
1201     4           <$> const(IV 42) s ->5
1202     -        <1> ex-rv2sv sKRM*/1 ->7
1203     6           <$> gvsv(*a) s ->7
1204
1205 The default rendering is top-down, so they're not in execution order.
1206 This form reflects the way the stack is used to parse and evaluate
1207 expressions; the add operates on the two terms below it in the tree.
1208
1209 Nullops appear as C<ex-opname>, where I<opname> is an op that has been
1210 optimized away by perl.  They're displayed with a sequence-number of
1211 '-', because they are not executed (they don't appear in previous
1212 example), they're printed here because they reflect the parse.
1213
1214 The arrow points to the sequence number of the next op; they're not
1215 displayed in -exec mode, for obvious reasons.
1216
1217 Note that because this rendering was done on a non-threaded perl, the
1218 PADOPs in the previous examples are now SVOPs, and some (but not all)
1219 of the square brackets have been replaced by round ones.  This is a
1220 subtle feature to provide some visual distinction between renderings
1221 on threaded and un-threaded perls.
1222
1223
1224 =head1 OPTIONS
1225
1226 Arguments that don't start with a hyphen are taken to be the names of
1227 subroutines or formats to render; if no
1228 such functions are specified, the main
1229 body of the program (outside any subroutines, and not including use'd
1230 or require'd files) is rendered.  Passing C<BEGIN>, C<UNITCHECK>,
1231 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
1232 special blocks to be printed.  Arguments must follow options.
1233
1234 Options affect how things are rendered (ie printed).  They're presented
1235 here by their visual effect, 1st being strongest.  They're grouped
1236 according to how they interrelate; within each group the options are
1237 mutually exclusive (unless otherwise stated).
1238
1239 =head2 Options for Opcode Ordering
1240
1241 These options control the 'vertical display' of opcodes.  The display
1242 'order' is also called 'mode' elsewhere in this document.
1243
1244 =over 4
1245
1246 =item B<-basic>
1247
1248 Print OPs in the order they appear in the OP tree (a preorder
1249 traversal, starting at the root). The indentation of each OP shows its
1250 level in the tree, and the '->' at the end of the line indicates the
1251 next opcode in execution order.  This mode is the default, so the flag
1252 is included simply for completeness.
1253
1254 =item B<-exec>
1255
1256 Print OPs in the order they would normally execute (for the majority
1257 of constructs this is a postorder traversal of the tree, ending at the
1258 root). In most cases the OP that usually follows a given OP will
1259 appear directly below it; alternate paths are shown by indentation. In
1260 cases like loops when control jumps out of a linear path, a 'goto'
1261 line is generated.
1262
1263 =item B<-tree>
1264
1265 Print OPs in a text approximation of a tree, with the root of the tree
1266 at the left and 'left-to-right' order of children transformed into
1267 'top-to-bottom'. Because this mode grows both to the right and down,
1268 it isn't suitable for large programs (unless you have a very wide
1269 terminal).
1270
1271 =back
1272
1273 =head2 Options for Line-Style
1274
1275 These options select the line-style (or just style) used to render
1276 each opcode, and dictates what info is actually printed into each line.
1277
1278 =over 4
1279
1280 =item B<-concise>
1281
1282 Use the author's favorite set of formatting conventions. This is the
1283 default, of course.
1284
1285 =item B<-terse>
1286
1287 Use formatting conventions that emulate the output of B<B::Terse>. The
1288 basic mode is almost indistinguishable from the real B<B::Terse>, and the
1289 exec mode looks very similar, but is in a more logical order and lacks
1290 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
1291 is only vaguely reminiscent of B<B::Terse>.
1292
1293 =item B<-linenoise>
1294
1295 Use formatting conventions in which the name of each OP, rather than being
1296 written out in full, is represented by a one- or two-character abbreviation.
1297 This is mainly a joke.
1298
1299 =item B<-debug>
1300
1301 Use formatting conventions reminiscent of B<B::Debug>; these aren't
1302 very concise at all.
1303
1304 =item B<-env>
1305
1306 Use formatting conventions read from the environment variables
1307 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
1308
1309 =back
1310
1311 =head2 Options for tree-specific formatting
1312
1313 =over 4
1314
1315 =item B<-compact>
1316
1317 Use a tree format in which the minimum amount of space is used for the
1318 lines connecting nodes (one character in most cases). This squeezes out
1319 a few precious columns of screen real estate.
1320
1321 =item B<-loose>
1322
1323 Use a tree format that uses longer edges to separate OP nodes. This format
1324 tends to look better than the compact one, especially in ASCII, and is
1325 the default.
1326
1327 =item B<-vt>
1328
1329 Use tree connecting characters drawn from the VT100 line-drawing set.
1330 This looks better if your terminal supports it.
1331
1332 =item B<-ascii>
1333
1334 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
1335 look as clean as the VT100 characters, but they'll work with almost any
1336 terminal (or the horizontal scrolling mode of less(1)) and are suitable
1337 for text documentation or email. This is the default.
1338
1339 =back
1340
1341 These are pairwise exclusive, i.e. compact or loose, vt or ascii.
1342
1343 =head2 Options controlling sequence numbering
1344
1345 =over 4
1346
1347 =item B<-base>I<n>
1348
1349 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
1350 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
1351 for 37 will be 'A', and so on until 62. Values greater than 62 are not
1352 currently supported. The default is 36.
1353
1354 =item B<-bigendian>
1355
1356 Print sequence numbers with the most significant digit first. This is the
1357 usual convention for Arabic numerals, and the default.
1358
1359 =item B<-littleendian>
1360
1361 Print sequence numbers with the least significant digit first.  This is
1362 obviously mutually exclusive with bigendian.
1363
1364 =back
1365
1366 =head2 Other options
1367
1368 =over 4
1369
1370 =item B<-src>
1371
1372 With this option, the rendering of each statement (starting with the
1373 nextstate OP) will be preceded by the 1st line of source code that
1374 generates it.  For example:
1375
1376     1  <0> enter
1377     # 1: my $i;
1378     2  <;> nextstate(main 1 junk.pl:1) v:{
1379     3  <0> padsv[$i:1,10] vM/LVINTRO
1380     # 3: for $i (0..9) {
1381     4  <;> nextstate(main 3 junk.pl:3) v:{
1382     5  <0> pushmark s
1383     6  <$> const[IV 0] s
1384     7  <$> const[IV 9] s
1385     8  <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS
1386     k  <0> iter s
1387     l  <|> and(other->9) vK/1
1388     # 4:     print "line ";
1389     9      <;> nextstate(main 2 junk.pl:4) v
1390     a      <0> pushmark s
1391     b      <$> const[PV "line "] s
1392     c      <@> print vK
1393     # 5:     print "$i\n";
1394     ...
1395
1396 =item B<-stash="somepackage">
1397
1398 With this, "somepackage" will be required, then the stash is
1399 inspected, and each function is rendered.
1400
1401 =back
1402
1403 The following options are pairwise exclusive.
1404
1405 =over 4
1406
1407 =item B<-main>
1408
1409 Include the main program in the output, even if subroutines were also
1410 specified.  This rendering is normally suppressed when a subroutine
1411 name or reference is given.
1412
1413 =item B<-nomain>
1414
1415 This restores the default behavior after you've changed it with '-main'
1416 (it's not normally needed).  If no subroutine name/ref is given, main is
1417 rendered, regardless of this flag.
1418
1419 =item B<-nobanner>
1420
1421 Renderings usually include a banner line identifying the function name
1422 or stringified subref.  This suppresses the printing of the banner.
1423
1424 TBC: Remove the stringified coderef; while it provides a 'cookie' for
1425 each function rendered, the cookies used should be 1,2,3.. not a
1426 random hex-address.  It also complicates string comparison of two
1427 different trees.
1428
1429 =item B<-banner>
1430
1431 restores default banner behavior.
1432
1433 =item B<-banneris> => subref
1434
1435 TBC: a hookpoint (and an option to set it) for a user-supplied
1436 function to produce a banner appropriate for users needs.  It's not
1437 ideal, because the rendering-state variables, which are a natural
1438 candidate for use in concise.t, are unavailable to the user.
1439
1440 =back
1441
1442 =head2 Option Stickiness
1443
1444 If you invoke Concise more than once in a program, you should know that
1445 the options are 'sticky'.  This means that the options you provide in
1446 the first call will be remembered for the 2nd call, unless you
1447 re-specify or change them.
1448
1449 =head1 ABBREVIATIONS
1450
1451 The concise style uses symbols to convey maximum info with minimal
1452 clutter (like hex addresses).  With just a little practice, you can
1453 start to see the flowers, not just the branches, in the trees.
1454
1455 =head2 OP class abbreviations
1456
1457 These symbols appear before the op-name, and indicate the
1458 B:: namespace that represents the ops in your Perl code.
1459
1460     0      OP (aka BASEOP)  An OP with no children
1461     1      UNOP             An OP with one child
1462     +      UNOP_AUX         A UNOP with auxillary fields
1463     2      BINOP            An OP with two children
1464     |      LOGOP            A control branch OP
1465     @      LISTOP           An OP that could have lots of children
1466     /      PMOP             An OP with a regular expression
1467     $      SVOP             An OP with an SV
1468     "      PVOP             An OP with a string
1469     {      LOOP             An OP that holds pointers for a loop
1470     ;      COP              An OP that marks the start of a statement
1471     #      PADOP            An OP with a GV on the pad
1472     .      METHOP           An OP with method call info
1473
1474 =head2 OP flags abbreviations
1475
1476 OP flags are either public or private.  The public flags alter the
1477 behavior of each opcode in consistent ways, and are represented by 0
1478 or more single characters.
1479
1480     v      OPf_WANT_VOID    Want nothing (void context)
1481     s      OPf_WANT_SCALAR  Want single value (scalar context)
1482     l      OPf_WANT_LIST    Want list of any length (list context)
1483                             Want is unknown
1484     K      OPf_KIDS         There is a firstborn child.
1485     P      OPf_PARENS       This operator was parenthesized.
1486                              (Or block needs explicit scope entry.)
1487     R      OPf_REF          Certified reference.
1488                              (Return container, not containee).
1489     M      OPf_MOD          Will modify (lvalue).
1490     S      OPf_STACKED      Some arg is arriving on the stack.
1491     *      OPf_SPECIAL      Do something weird for this op (see op.h)
1492
1493 Private flags, if any are set for an opcode, are displayed after a '/'
1494
1495     8  <@> leave[1 ref] vKP/REFC ->(end)
1496     7     <2> sassign vKS/2 ->8
1497
1498 They're opcode specific, and occur less often than the public ones, so
1499 they're represented by short mnemonics instead of single-chars; see
1500 B::Op_private and F<regen/op_private> for more details.
1501
1502 =head1 FORMATTING SPECIFICATIONS
1503
1504 For each line-style ('concise', 'terse', 'linenoise', etc.) there are
1505 3 format-specs which control how OPs are rendered.
1506
1507 The first is the 'default' format, which is used in both basic and exec
1508 modes to print all opcodes.  The 2nd, goto-format, is used in exec
1509 mode when branches are encountered.  They're not real opcodes, and are
1510 inserted to look like a closing curly brace.  The tree-format is tree
1511 specific.
1512
1513 When a line is rendered, the correct format-spec is copied and scanned
1514 for the following items; data is substituted in, and other
1515 manipulations like basic indenting are done, for each opcode rendered.
1516
1517 There are 3 kinds of items that may be populated; special patterns,
1518 #vars, and literal text, which is copied verbatim.  (Yes, it's a set
1519 of s///g steps.)
1520
1521 =head2 Special Patterns
1522
1523 These items are the primitives used to perform indenting, and to
1524 select text from amongst alternatives.
1525
1526 =over 4
1527
1528 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
1529
1530 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
1531
1532 =item B<(*(>I<text>B<)*)>
1533
1534 Generates one copy of I<text> for each indentation level.
1535
1536 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
1537
1538 Generates one fewer copies of I<text1> than the indentation level, followed
1539 by one copy of I<text2> if the indentation level is more than 0.
1540
1541 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
1542
1543 If the value of I<var> is true (not empty or zero), generates the
1544 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
1545 nothing.
1546
1547 =item B<~>
1548
1549 Any number of tildes and surrounding whitespace will be collapsed to
1550 a single space.
1551
1552 =back
1553
1554 =head2 # Variables
1555
1556 These #vars represent opcode properties that you may want as part of
1557 your rendering.  The '#' is intended as a private sigil; a #var's
1558 value is interpolated into the style-line, much like "read $this".
1559
1560 These vars take 3 forms:
1561
1562 =over 4
1563
1564 =item B<#>I<var>
1565
1566 A property named 'var' is assumed to exist for the opcodes, and is
1567 interpolated into the rendering.
1568
1569 =item B<#>I<var>I<N>
1570
1571 Generates the value of I<var>, left justified to fill I<N> spaces.
1572 Note that this means while you can have properties 'foo' and 'foo2',
1573 you cannot render 'foo2', but you could with 'foo2a'.  You would be
1574 wise not to rely on this behavior going forward ;-)
1575
1576 =item B<#>I<Var>
1577
1578 This ucfirst form of #var generates a tag-value form of itself for
1579 display; it converts '#Var' into a 'Var => #var' style, which is then
1580 handled as described above.  (Imp-note: #Vars cannot be used for
1581 conditional-fills, because the => #var transform is done after the check
1582 for #Var's value).
1583
1584 =back
1585
1586 The following variables are 'defined' by B::Concise; when they are
1587 used in a style, their respective values are plugged into the
1588 rendering of each opcode.
1589
1590 Only some of these are used by the standard styles, the others are
1591 provided for you to delve into optree mechanics, should you wish to
1592 add a new style (see L</add_style> below) that uses them.  You can
1593 also add new ones using L</add_callback>.
1594
1595 =over 4
1596
1597 =item B<#addr>
1598
1599 The address of the OP, in hexadecimal.
1600
1601 =item B<#arg>
1602
1603 The OP-specific information of the OP (such as the SV for an SVOP, the
1604 non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
1605
1606 =item B<#class>
1607
1608 The B-determined class of the OP, in all caps.
1609
1610 =item B<#classsym>
1611
1612 A single symbol abbreviating the class of the OP.
1613
1614 =item B<#coplabel>
1615
1616 The label of the statement or block the OP is the start of, if any.
1617
1618 =item B<#exname>
1619
1620 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
1621
1622 =item B<#extarg>
1623
1624 The target of the OP, or nothing for a nulled OP.
1625
1626 =item B<#firstaddr>
1627
1628 The address of the OP's first child, in hexadecimal.
1629
1630 =item B<#flags>
1631
1632 The OP's flags, abbreviated as a series of symbols.
1633
1634 =item B<#flagval>
1635
1636 The numeric value of the OP's flags.
1637
1638 =item B<#hints>
1639
1640 The COP's hint flags, rendered with abbreviated names if possible. An empty
1641 string if this is not a COP. Here are the symbols used:
1642
1643     $ strict refs
1644     & strict subs
1645     * strict vars
1646    x$ explicit use/no strict refs
1647    x& explicit use/no strict subs
1648    x* explicit use/no strict vars
1649     i integers
1650     l locale
1651     b bytes
1652     { block scope
1653     % localise %^H
1654     < open in
1655     > open out
1656     I overload int
1657     F overload float
1658     B overload binary
1659     S overload string
1660     R overload re
1661     T taint
1662     E eval
1663     X filetest access
1664     U utf-8
1665
1666     us      use feature 'unicode_strings'
1667     fea=NNN feature bundle number
1668
1669 =item B<#hintsval>
1670
1671 The numeric value of the COP's hint flags, or an empty string if this is not
1672 a COP.
1673
1674 =item B<#hyphseq>
1675
1676 The sequence number of the OP, or a hyphen if it doesn't have one.
1677
1678 =item B<#label>
1679
1680 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
1681 mode, or empty otherwise.
1682
1683 =item B<#lastaddr>
1684
1685 The address of the OP's last child, in hexadecimal.
1686
1687 =item B<#name>
1688
1689 The OP's name.
1690
1691 =item B<#NAME>
1692
1693 The OP's name, in all caps.
1694
1695 =item B<#next>
1696
1697 The sequence number of the OP's next OP.
1698
1699 =item B<#nextaddr>
1700
1701 The address of the OP's next OP, in hexadecimal.
1702
1703 =item B<#noise>
1704
1705 A one- or two-character abbreviation for the OP's name.
1706
1707 =item B<#private>
1708
1709 The OP's private flags, rendered with abbreviated names if possible.
1710
1711 =item B<#privval>
1712
1713 The numeric value of the OP's private flags.
1714
1715 =item B<#seq>
1716
1717 The sequence number of the OP. Note that this is a sequence number
1718 generated by B::Concise.
1719
1720 =item B<#seqnum>
1721
1722 5.8.x and earlier only. 5.9 and later do not provide this.
1723
1724 The real sequence number of the OP, as a regular number and not adjusted
1725 to be relative to the start of the real program. (This will generally be
1726 a fairly large number because all of B<B::Concise> is compiled before
1727 your program is).
1728
1729 =item B<#opt>
1730
1731 Whether or not the op has been optimized by the peephole optimizer.
1732
1733 Only available in 5.9 and later.
1734
1735 =item B<#sibaddr>
1736
1737 The address of the OP's next youngest sibling, in hexadecimal.
1738
1739 =item B<#svaddr>
1740
1741 The address of the OP's SV, if it has an SV, in hexadecimal.
1742
1743 =item B<#svclass>
1744
1745 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
1746
1747 =item B<#svval>
1748
1749 The value of the OP's SV, if it has one, in a short human-readable format.
1750
1751 =item B<#targ>
1752
1753 The numeric value of the OP's targ.
1754
1755 =item B<#targarg>
1756
1757 The name of the variable the OP's targ refers to, if any, otherwise the
1758 letter t followed by the OP's targ in decimal.
1759
1760 =item B<#targarglife>
1761
1762 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
1763 the variable's lifetime (or 'end' for a variable in an open scope) for a
1764 variable.
1765
1766 =item B<#typenum>
1767
1768 The numeric value of the OP's type, in decimal.
1769
1770 =back
1771
1772 =head1 One-Liner Command tips
1773
1774 =over 4
1775
1776 =item perl -MO=Concise,bar foo.pl
1777
1778 Renders only bar() from foo.pl.  To see main, drop the ',bar'.  To see
1779 both, add ',-main'
1780
1781 =item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
1782
1783 Identifies md5 as an XS function.  The export is needed so that BC can
1784 find it in main.
1785
1786 =item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
1787
1788 Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
1789 Although POSIX isn't entirely consistent across platforms, this is
1790 likely to be present in virtually all of them.
1791
1792 =item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
1793
1794 This renders a print statement, which includes a call to the function.
1795 It's identical to rendering a file with a use call and that single
1796 statement, except for the filename which appears in the nextstate ops.
1797
1798 =item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
1799
1800 This is B<very> similar to previous, only the first two ops differ.  This
1801 subroutine rendering is more representative, insofar as a single main
1802 program will have many subs.
1803
1804 =item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
1805
1806 This renders all functions in the B::Concise package with the source
1807 lines.  It eschews the O framework so that the stashref can be passed
1808 directly to B::Concise::compile().  See -stash option for a more
1809 convenient way to render a package.
1810
1811 =back
1812
1813 =head1 Using B::Concise outside of the O framework
1814
1815 The common (and original) usage of B::Concise was for command-line
1816 renderings of simple code, as given in EXAMPLE.  But you can also use
1817 B<B::Concise> from your code, and call compile() directly, and
1818 repeatedly.  By doing so, you can avoid the compile-time only
1819 operation of O.pm, and even use the debugger to step through
1820 B::Concise::compile() itself.
1821
1822 Once you're doing this, you may alter Concise output by adding new
1823 rendering styles, and by optionally adding callback routines which
1824 populate new variables, if such were referenced from those (just
1825 added) styles.
1826
1827 =head2 Example: Altering Concise Renderings
1828
1829     use B::Concise qw(set_style add_callback);
1830     add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
1831     add_callback
1832       ( sub {
1833             my ($h, $op, $format, $level, $stylename) = @_;
1834             $h->{variable} = some_func($op);
1835         });
1836     $walker = B::Concise::compile(@options,@subnames,@subrefs);
1837     $walker->();
1838
1839 =head2 set_style()
1840
1841 B<set_style> accepts 3 arguments, and updates the three format-specs
1842 comprising a line-style (basic-exec, goto, tree).  It has one minor
1843 drawback though; it doesn't register the style under a new name.  This
1844 can become an issue if you render more than once and switch styles.
1845 Thus you may prefer to use add_style() and/or set_style_standard()
1846 instead.
1847
1848 =head2 set_style_standard($name)
1849
1850 This restores one of the standard line-styles: C<terse>, C<concise>,
1851 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
1852 names previously defined with add_style().
1853
1854 =head2 add_style ()
1855
1856 This subroutine accepts a new style name and three style arguments as
1857 above, and creates, registers, and selects the newly named style.  It is
1858 an error to re-add a style; call set_style_standard() to switch between
1859 several styles.
1860
1861 =head2 add_callback ()
1862
1863 If your newly minted styles refer to any new #variables, you'll need
1864 to define a callback subroutine that will populate (or modify) those
1865 variables.  They are then available for use in the style you've
1866 chosen.
1867
1868 The callbacks are called for each opcode visited by Concise, in the
1869 same order as they are added.  Each subroutine is passed five
1870 parameters.
1871
1872   1. A hashref, containing the variable names and values which are
1873      populated into the report-line for the op
1874   2. the op, as a B<B::OP> object
1875   3. a reference to the format string
1876   4. the formatting (indent) level
1877   5. the selected stylename
1878
1879 To define your own variables, simply add them to the hash, or change
1880 existing values if you need to.  The level and format are passed in as
1881 references to scalars, but it is unlikely that they will need to be
1882 changed or even used.
1883
1884 =head2 Running B::Concise::compile()
1885
1886 B<compile> accepts options as described above in L</OPTIONS>, and
1887 arguments, which are either coderefs, or subroutine names.
1888
1889 It constructs and returns a $treewalker coderef, which when invoked,
1890 traverses, or walks, and renders the optrees of the given arguments to
1891 STDOUT.  You can reuse this, and can change the rendering style used
1892 each time; thereafter the coderef renders in the new style.
1893
1894 B<walk_output> lets you change the print destination from STDOUT to
1895 another open filehandle, or into a string passed as a ref (unless
1896 you've built perl with -Uuseperlio).
1897
1898   my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
1899   walk_output(\my $buf);
1900   $walker->();                          # 1 renders -terse
1901   set_style_standard('concise');        # 2
1902   $walker->();                          # 2 renders -concise
1903   $walker->(@new);                      # 3 renders whatever
1904   print "3 different renderings: terse, concise, and @new: $buf\n";
1905
1906 When $walker is called, it traverses the subroutines supplied when it
1907 was created, and renders them using the current style.  You can change
1908 the style afterwards in several different ways:
1909
1910   1. call C<compile>, altering style or mode/order
1911   2. call C<set_style_standard>
1912   3. call $walker, passing @new options
1913
1914 Passing new options to the $walker is the easiest way to change
1915 amongst any pre-defined styles (the ones you add are automatically
1916 recognized as options), and is the only way to alter rendering order
1917 without calling compile again.  Note however that rendering state is
1918 still shared amongst multiple $walker objects, so they must still be
1919 used in a coordinated manner.
1920
1921 =head2 B::Concise::reset_sequence()
1922
1923 This function (not exported) lets you reset the sequence numbers (note
1924 that they're numbered arbitrarily, their goal being to be human
1925 readable).  Its purpose is mostly to support testing, i.e. to compare
1926 the concise output from two identical anonymous subroutines (but
1927 different instances).  Without the reset, B::Concise, seeing that
1928 they're separate optrees, generates different sequence numbers in
1929 the output.
1930
1931 =head2 Errors
1932
1933 Errors in rendering (non-existent function-name, non-existent coderef)
1934 are written to the STDOUT, or wherever you've set it via
1935 walk_output().
1936
1937 Errors using the various *style* calls, and bad args to walk_output(),
1938 result in die().  Use an eval if you wish to catch these errors and
1939 continue processing.
1940
1941 =head1 AUTHOR
1942
1943 Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
1944
1945 =cut