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   = "0.62";
  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          CVf_ANON);
  32
  33 my %style =
  34   ("terse" =>
  35    ["(?(#label =>\n)?)(*(    )*)#class (#addr) #name (?([#targ])?) "
  36     . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
  37     "(*(    )*)goto #class (#addr)\n",
  38     "#class pp_#name"],
  39    "concise" =>
  40    ["#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
  41     . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n"
  42     , "  (*(    )*)     goto #seq\n",
  43     "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
  44    "linenoise" =>
  45    ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
  46     "gt_#seq ",
  47     "(?(#seq)?)#noise#arg(?([#targarg])?)"],
  48    "debug" =>
  49    ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
  50     . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
  51     . "\top_flags\t#flagval\n\top_private\t#privval\n"
  52     . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
  53     . "(?(\top_sv\t\t#svaddr\n)?)",
  54     "    GOTO #addr\n",
  55     "#addr"],
  56    "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
  57              $ENV{B_CONCISE_TREE_FORMAT}],
  58   );
  59
  60 # Renderings, ie how Concise prints, is controlled by these vars
  61 # primary:
  62 our $stylename;         # selects current style from %style
  63 my $order = "basic";    # how optree is walked & printed: basic, exec, tree
  64
  65 # rendering mechanics:
  66 # these 'formats' are the line-rendering templates
  67 # they're updated from %style when $stylename changes
  68 my ($format, $gotofmt, $treefmt);
  69
  70 # lesser players:
  71 my $base = 36;          # how <sequence#> is displayed
  72 my $big_endian = 1;     # more <sequence#> display
  73 my $tree_style = 0;     # tree-order details
  74 my $banner = 1;         # print banner before optree is traversed
  75 my $do_main = 0;        # force printing of main routine
  76
  77 # another factor: can affect all styles!
  78 our @callbacks;         # allow external management
  79
  80 set_style_standard("concise");
  81
  82 my $curcv;
  83 my $cop_seq_base;
  84
  85 sub set_style {
  86     ($format, $gotofmt, $treefmt) = @_;
  87     #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
  88     die "expecting 3 style-format args\n" unless @_ == 3;
  89 }
  90
  91 sub add_style {
  92     my ($newstyle,@args) = @_;
  93     die "style '$newstyle' already exists, choose a new name\n"
  94         if exists $style{$newstyle};
  95     die "expecting 3 style-format args\n" unless @args == 3;
  96     $style{$newstyle} = [@args];
  97     $stylename = $newstyle; # update rendering state
  98 }
  99
 100 sub set_style_standard {
 101     ($stylename) = @_; # update rendering state
 102     die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
 103     set_style(@{$style{$stylename}});
 104 }
 105
 106 sub add_callback {
 107     push @callbacks, @_;
 108 }
 109
 110 # output handle, used with all Concise-output printing
 111 our $walkHandle;        # public for your convenience
 112 BEGIN { $walkHandle = \*STDOUT }
 113
 114 sub walk_output { # updates $walkHandle
 115     my $handle = shift;
 116     return $walkHandle unless $handle; # allow use as accessor
 117
 118     if (ref $handle eq 'SCALAR') {
 119         require Config;
 120         die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
 121             unless $Config::Config{useperlio};
 122         # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
 123         open my $tmp, '>', $handle;     # but cant re-set existing STDOUT
 124         $walkHandle = $tmp;             # so use my $tmp as intermediate var
 125         return $walkHandle;
 126     }
 127     my $iotype = ref $handle;
 128     die "expecting argument/object that can print\n"
 129         unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
 130     $walkHandle = $handle;
 131 }
 132
 133 sub concise_subref {
 134     my($order, $coderef) = @_;
 135     my $codeobj = svref_2object($coderef);
 136
 137     return concise_stashref(@_)
 138         unless ref $codeobj eq 'B::CV';
 139     concise_cv_obj($order, $codeobj);
 140 }
 141
 142 sub concise_stashref {
 143     my($order, $h) = @_;
 144     foreach my $k (sort keys %$h) {
 145         local *s = $h->{$k};
 146         my $coderef = *s{CODE} or next;
 147         reset_sequence();
 148         print "FUNC: ", *s, "\n";
 149         my $codeobj = svref_2object($coderef);
 150         next unless ref $codeobj eq 'B::CV';
 151         eval { concise_cv_obj($order, $codeobj) }
 152         or warn "err $@ on $codeobj";
 153     }
 154 }
 155
 156 # This should have been called concise_subref, but it was exported
 157 # under this name in versions before 0.56
 158 sub concise_cv { concise_subref(@_); }
 159
 160 sub concise_cv_obj {
 161     my ($order, $cv) = @_;
 162     $curcv = $cv;
 163     die "err: coderef has no START\n" if class($cv->START) eq "NULL";
 164     sequence($cv->START);
 165     if ($order eq "exec") {
 166         walk_exec($cv->START);
 167     } elsif ($order eq "basic") {
 168         walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
 169     } else {
 170         print $walkHandle tree($cv->ROOT, 0);
 171     }
 172 }
 173
 174 sub concise_main {
 175     my($order) = @_;
 176     sequence(main_start);
 177     $curcv = main_cv;
 178     if ($order eq "exec") {
 179         return if class(main_start) eq "NULL";
 180         walk_exec(main_start);
 181     } elsif ($order eq "tree") {
 182         return if class(main_root) eq "NULL";
 183         print $walkHandle tree(main_root, 0);
 184     } elsif ($order eq "basic") {
 185         return if class(main_root) eq "NULL";
 186         walk_topdown(main_root,
 187                      sub { $_[0]->concise($_[1]) }, 0);
 188     }
 189 }
 190
 191 sub concise_specials {
 192     my($name, $order, @cv_s) = @_;
 193     my $i = 1;
 194     if ($name eq "BEGIN") {
 195         splice(@cv_s, 0, 7); # skip 7 BEGIN blocks in this file
 196     } elsif ($name eq "CHECK") {
 197         pop @cv_s; # skip the CHECK block that calls us
 198     }
 199     for my $cv (@cv_s) {
 200         print $walkHandle "$name $i:\n";
 201         $i++;
 202         concise_cv_obj($order, $cv);
 203     }
 204 }
 205
 206 my $start_sym = "\e(0"; # "\cN" sometimes also works
 207 my $end_sym   = "\e(B"; # "\cO" respectively
 208
 209 my @tree_decorations =
 210   (["  ", "--", "+-", "|-", "| ", "`-", "-", 1],
 211    [" ", "-", "+", "+", "|", "`", "", 0],
 212    ["  ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
 213    [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
 214   );
 215
 216
 217 sub compileOpts {
 218     # set rendering state from options and args
 219     my @options = grep(/^-/, @_);
 220     my @args = grep(!/^-/, @_);
 221     for my $o (@options) {
 222         # mode/order
 223         if ($o eq "-basic") {
 224             $order = "basic";
 225         } elsif ($o eq "-exec") {
 226             $order = "exec";
 227         } elsif ($o eq "-tree") {
 228             $order = "tree";
 229         }
 230         # tree-specific
 231         elsif ($o eq "-compact") {
 232             $tree_style |= 1;
 233         } elsif ($o eq "-loose") {
 234             $tree_style &= ~1;
 235         } elsif ($o eq "-vt") {
 236             $tree_style |= 2;
 237         } elsif ($o eq "-ascii") {
 238             $tree_style &= ~2;
 239         }
 240         # sequence numbering
 241         elsif ($o =~ /^-base(\d+)$/) {
 242             $base = $1;
 243         } elsif ($o eq "-bigendian") {
 244             $big_endian = 1;
 245         } elsif ($o eq "-littleendian") {
 246             $big_endian = 0;
 247         }
 248         elsif ($o eq "-nobanner") {
 249             $banner = 0;
 250         } elsif ($o eq "-banner") {
 251             $banner = 1;
 252         }
 253         elsif ($o eq "-main") {
 254             $do_main = 1;
 255         } elsif ($o eq "-nomain") {
 256             $do_main = 0;
 257         }
 258         # line-style options
 259         elsif (exists $style{substr($o, 1)}) {
 260             $stylename = substr($o, 1);
 261             set_style_standard($stylename);
 262         } else {
 263             warn "Option $o unrecognized";
 264         }
 265     }
 266     return (@args);
 267 }
 268
 269 sub compile {
 270     my (@args) = compileOpts(@_);
 271     return sub {
 272         my @newargs = compileOpts(@_); # accept new rendering options
 273         warn "disregarding non-options: @newargs\n" if @newargs;
 274
 275         for my $objname (@args) {
 276
 277             if ($objname eq "BEGIN") {
 278                 concise_specials("BEGIN", $order,
 279                                B::begin_av->isa("B::AV") ?
 280                                B::begin_av->ARRAY : ());
 281             } elsif ($objname eq "INIT") {
 282                 concise_specials("INIT", $order,
 283                                B::init_av->isa("B::AV") ?
 284                                B::init_av->ARRAY : ());
 285             } elsif ($objname eq "CHECK") {
 286                 concise_specials("CHECK", $order,
 287                                B::check_av->isa("B::AV") ?
 288                                B::check_av->ARRAY : ());
 289             } elsif ($objname eq "END") {
 290                 concise_specials("END", $order,
 291                                      B::end_av->isa("B::AV") ?
 292                                B::end_av->ARRAY : ());
 293             }
 294             else {
 295                 # convert function names to subrefs
 296                 my $objref;
 297                 if (ref $objname) {
 298                     print $walkHandle "B::Concise::compile($objname)\n"
 299                         if $banner;
 300                     $objref = $objname;
 301                 } else {
 302                     $objname = "main::" . $objname unless $objname =~ /::/;
 303                     print $walkHandle "$objname:\n";
 304                     no strict 'refs';
 305                     die "err: unknown function ($objname)\n"
 306                         unless *{$objname}{CODE};
 307                     $objref = \&$objname;
 308                 }
 309                 concise_subref($order, $objref);
 310             }
 311         }
 312         if (!@args or $do_main) {
 313             print $walkHandle "main program:\n" if $do_main;
 314             concise_main($order);
 315         }
 316         return @args;   # something
 317     }
 318 }
 319
 320 my %labels;
 321 my $lastnext;   # remembers op-chain, used to insert gotos
 322
 323 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
 324                'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
 325                'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
 326
 327 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
 328 my @linenoise =
 329   qw'#  () sc (  @? 1  $* gv *{ m$ m@ m% m? p/ *$ $  $# & a& pt \\ s\\ rf bl
 330      `  *? <> ?? ?/ r/ c/ // qr s/ /c y/ =  @= C  sC Cp sp df un BM po +1 +I
 331      -1 -I 1+ I+ 1- I- ** *  i* /  i/ %$ i% x  +  i+ -  i- .  "  << >> <  i<
 332      >  i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
 333      !  ~  a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
 334      uf lf uc lc qm @  [f [  @[ eh vl ky dl ex %  ${ @{ uk pk st jn )  )[ a@
 335      a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
 336      v} ca wa di rs ;; ;  ;d }{ {  }  {} f{ it {l l} rt }l }n }r dm }g }e ^o
 337      ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
 338      ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
 339      -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
 340      co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
 341      g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
 342      e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
 343      Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
 344
 345 my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
 346
 347 sub op_flags {
 348     my($x) = @_;
 349     my(@v);
 350     push @v, "v" if ($x & 3) == 1;
 351     push @v, "s" if ($x & 3) == 2;
 352     push @v, "l" if ($x & 3) == 3;
 353     push @v, "K" if $x & 4;
 354     push @v, "P" if $x & 8;
 355     push @v, "R" if $x & 16;
 356     push @v, "M" if $x & 32;
 357     push @v, "S" if $x & 64;
 358     push @v, "*" if $x & 128;
 359     return join("", @v);
 360 }
 361
 362 sub base_n {
 363     my $x = shift;
 364     return "-" . base_n(-$x) if $x < 0;
 365     my $str = "";
 366     do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
 367     $str = reverse $str if $big_endian;
 368     return $str;
 369 }
 370
 371 my %sequence_num;
 372 my $seq_max = 1;
 373
 374 sub reset_sequence {
 375     # reset the sequence
 376     %sequence_num = ();
 377     $seq_max = 1;
 378     $lastnext = 0;
 379 }
 380
 381 sub seq {
 382     my($op) = @_;
 383     return "-" if not exists $sequence_num{$$op};
 384     return base_n($sequence_num{$$op});
 385 }
 386
 387 sub walk_topdown {
 388     my($op, $sub, $level) = @_;
 389     $sub->($op, $level);
 390     if ($op->flags & OPf_KIDS) {
 391         for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
 392             walk_topdown($kid, $sub, $level + 1);
 393         }
 394     }
 395     if (class($op) eq "PMOP") {
 396         my $maybe_root = $op->pmreplroot;
 397         if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
 398             # It really is the root of the replacement, not something
 399             # else stored here for lack of space elsewhere
 400             walk_topdown($maybe_root, $sub, $level + 1);
 401         }
 402     }
 403 }
 404
 405 sub walklines {
 406     my($ar, $level) = @_;
 407     for my $l (@$ar) {
 408         if (ref($l) eq "ARRAY") {
 409             walklines($l, $level + 1);
 410         } else {
 411             $l->concise($level);
 412         }
 413     }
 414 }
 415
 416 sub walk_exec {
 417     my($top, $level) = @_;
 418     my %opsseen;
 419     my @lines;
 420     my @todo = ([$top, \@lines]);
 421     while (@todo and my($op, $targ) = @{shift @todo}) {
 422         for (; $$op; $op = $op->next) {
 423             last if $opsseen{$$op}++;
 424             push @$targ, $op;
 425             my $name = $op->name;
 426             if (class($op) eq "LOGOP") {
 427                 my $ar = [];
 428                 push @$targ, $ar;
 429                 push @todo, [$op->other, $ar];
 430             } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
 431                 my $ar = [];
 432                 push @$targ, $ar;
 433                 push @todo, [$op->pmreplstart, $ar];
 434             } elsif ($name =~ /^enter(loop|iter)$/) {
 435                 $labels{${$op->nextop}} = "NEXT";
 436                 $labels{${$op->lastop}} = "LAST";
 437                 $labels{${$op->redoop}} = "REDO";
 438             }
 439         }
 440     }
 441     walklines(\@lines, 0);
 442 }
 443
 444 # The structure of this routine is purposely modeled after op.c's peep()
 445 sub sequence {
 446     my($op) = @_;
 447     my $oldop = 0;
 448     return if class($op) eq "NULL" or exists $sequence_num{$$op};
 449     for (; $$op; $op = $op->next) {
 450         last if exists $sequence_num{$$op};
 451         my $name = $op->name;
 452         if ($name =~ /^(null|scalar|lineseq|scope)$/) {
 453             next if $oldop and $ {$op->next};
 454         } else {
 455             $sequence_num{$$op} = $seq_max++;
 456             if (class($op) eq "LOGOP") {
 457                 my $other = $op->other;
 458                 $other = $other->next while $other->name eq "null";
 459                 sequence($other);
 460             } elsif (class($op) eq "LOOP") {
 461                 my $redoop = $op->redoop;
 462                 $redoop = $redoop->next while $redoop->name eq "null";
 463                 sequence($redoop);
 464                 my $nextop = $op->nextop;
 465                 $nextop = $nextop->next while $nextop->name eq "null";
 466                 sequence($nextop);
 467                 my $lastop = $op->lastop;
 468                 $lastop = $lastop->next while $lastop->name eq "null";
 469                 sequence($lastop);
 470             } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
 471                 my $replstart = $op->pmreplstart;
 472                 $replstart = $replstart->next while $replstart->name eq "null";
 473                 sequence($replstart);
 474             }
 475         }
 476         $oldop = $op;
 477     }
 478 }
 479
 480 sub fmt_line {    # generate text-line for op.
 481     my($hr, $op, $text, $level) = @_;
 482
 483     $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
 484
 485     return '' if $hr->{SKIP};   # suppress line if a callback said so
 486     return '' if $hr->{goto} and $hr->{goto} eq '-';    # no goto nowhere
 487
 488     # spec: (?(text1#varText2)?)
 489     $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
 490         $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
 491
 492     # spec: (x(exec_text;basic_text)x)
 493     $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
 494
 495     # spec: (*(text)*)
 496     $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
 497
 498     # spec: (*(text1;text2)*)
 499     $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
 500
 501     # convert #Var to tag=>val form: Var\t#var
 502     $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
 503
 504     # spec: #varN
 505     $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
 506
 507     $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg;      # populate #var's
 508     $text =~ s/[ \t]*~+[ \t]*/ /g;              # squeeze tildes
 509     chomp $text;
 510     return "$text\n" if $text ne "";
 511     return $text; # suppress empty lines
 512 }
 513
 514 my %priv;
 515 $priv{$_}{128} = "LVINTRO"
 516   for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
 517        "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
 518        "padav", "padhv", "enteriter");
 519 $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
 520 $priv{"aassign"}{64} = "COMMON";
 521 $priv{"aassign"}{32} = "PHASH" if $] < 5.009;
 522 $priv{"sassign"}{64} = "BKWARD";
 523 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont");
 524 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
 525                                     "COMPL", "GROWS");
 526 $priv{"repeat"}{64} = "DOLIST";
 527 $priv{"leaveloop"}{64} = "CONT";
 528 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
 529   for (qw(rv2gv rv2sv padsv aelem helem));
 530 $priv{"entersub"}{16} = "DBG";
 531 $priv{"entersub"}{32} = "TARG";
 532 @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
 533 $priv{"gv"}{32} = "EARLYCV";
 534 $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
 535 $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
 536         "enteriter");
 537 $priv{$_}{16} = "TARGMY"
 538   for (map(($_,"s$_"),"chop", "chomp"),
 539        map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
 540            "add", "subtract", "negate"), "pow", "concat", "stringify",
 541        "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
 542        "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
 543        "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
 544        "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
 545        "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
 546        "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
 547        "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
 548        "setpriority", "time", "sleep");
 549 @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN");
 550 $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
 551 $priv{"list"}{64} = "GUESSED";
 552 $priv{"delete"}{64} = "SLICE";
 553 $priv{"exists"}{64} = "SUB";
 554 $priv{$_}{64} = "LOCALE"
 555   for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
 556        "scmp", "lc", "uc", "lcfirst", "ucfirst");
 557 @{$priv{"sort"}}{1,2,4,8} = ("NUM", "INT", "REV", "INPLACE");
 558 $priv{"threadsv"}{64} = "SVREFd";
 559 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
 560   for ("open", "backtick");
 561 $priv{"exit"}{128} = "VMS";
 562 $priv{$_}{2} = "FTACCESS"
 563   for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
 564 if ($] >= 5.009) {
 565   # Stacked filetests are post 5.8.x
 566   $priv{$_}{4} = "FTSTACKED"
 567     for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
 568          "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
 569          "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
 570          "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
 571          "ftbinary");
 572   # Lexical $_ is post 5.8.x
 573   $priv{$_}{2} = "GREPLEX"
 574     for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 575 }
 576
 577 sub private_flags {
 578     my($name, $x) = @_;
 579     my @s;
 580     for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
 581         if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
 582             $x -= $flag;
 583             push @s, $priv{$name}{$flag};
 584         }
 585     }
 586     push @s, $x if $x;
 587     return join(",", @s);
 588 }
 589
 590 sub concise_sv {
 591     my($sv, $hr) = @_;
 592     $hr->{svclass} = class($sv);
 593     $hr->{svclass} = "UV"
 594       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
 595     $hr->{svaddr} = sprintf("%#x", $$sv);
 596     if ($hr->{svclass} eq "GV") {
 597         my $gv = $sv;
 598         my $stash = $gv->STASH->NAME;
 599         if ($stash eq "main") {
 600             $stash = "";
 601         } else {
 602             $stash = $stash . "::";
 603         }
 604         $hr->{svval} = "*$stash" . $gv->SAFENAME;
 605         return "*$stash" . $gv->SAFENAME;
 606     } else {
 607         while (class($sv) eq "RV") {
 608             $hr->{svval} .= "\\";
 609             $sv = $sv->RV;
 610         }
 611         if (class($sv) eq "SPECIAL") {
 612             $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
 613         } elsif ($sv->FLAGS & SVf_NOK) {
 614             $hr->{svval} .= $sv->NV;
 615         } elsif ($sv->FLAGS & SVf_IOK) {
 616             $hr->{svval} .= $sv->int_value;
 617         } elsif ($sv->FLAGS & SVf_POK) {
 618             $hr->{svval} .= cstring($sv->PV);
 619         } elsif (class($sv) eq "HV") {
 620             $hr->{svval} .= 'HASH';
 621         }
 622
 623         $hr->{svval} = 'undef' unless defined $hr->{svval};
 624         my $out = $hr->{svclass};
 625         return $out .= " $hr->{svval}" ;
 626     }
 627 }
 628
 629 sub concise_op {
 630     my ($op, $level, $format) = @_;
 631     my %h;
 632     $h{exname} = $h{name} = $op->name;
 633     $h{NAME} = uc $h{name};
 634     $h{class} = class($op);
 635     $h{extarg} = $h{targ} = $op->targ;
 636     $h{extarg} = "" unless $h{extarg};
 637     if ($h{name} eq "null" and $h{targ}) {
 638         # targ holds the old type
 639         $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
 640         $h{extarg} = "";
 641     } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
 642         # targ potentially holds a reference count
 643         if ($op->private & 64) {
 644             my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
 645             $h{targarglife} = $h{targarg} = "$h{targ} $refs";
 646         }
 647     } elsif ($h{targ}) {
 648         my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
 649         if (defined $padname and class($padname) ne "SPECIAL") {
 650             $h{targarg}  = $padname->PVX;
 651             if ($padname->FLAGS & SVf_FAKE) {
 652                 if ($] < 5.009) {
 653                     $h{targarglife} = "$h{targarg}:FAKE";
 654                 } else {
 655                     # These changes relate to the jumbo closure fix.
 656                     # See changes 19939 and 20005
 657                     my $fake = '';
 658                     $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
 659                     $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
 660                     $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
 661                     $h{targarglife} = "$h{targarg}:FAKE:$fake";
 662                 }
 663             }
 664             else {
 665                 my $intro = $padname->NVX - $cop_seq_base;
 666                 my $finish = int($padname->IVX) - $cop_seq_base;
 667                 $finish = "end" if $finish == 999999999 - $cop_seq_base;
 668                 $h{targarglife} = "$h{targarg}:$intro,$finish";
 669             }
 670         } else {
 671             $h{targarglife} = $h{targarg} = "t" . $h{targ};
 672         }
 673     }
 674     $h{arg} = "";
 675     $h{svclass} = $h{svaddr} = $h{svval} = "";
 676     if ($h{class} eq "PMOP") {
 677         my $precomp = $op->precomp;
 678         if (defined $precomp) {
 679             $precomp = cstring($precomp); # Escape literal control sequences
 680             $precomp = "/$precomp/";
 681         } else {
 682             $precomp = "";
 683         }
 684         my $pmreplroot = $op->pmreplroot;
 685         my $pmreplstart;
 686         if (ref($pmreplroot) eq "B::GV") {
 687             # with C<@stash_array = split(/pat/, str);>,
 688             #  *stash_array is stored in /pat/'s pmreplroot.
 689             $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
 690         } elsif (!ref($pmreplroot) and $pmreplroot) {
 691             # same as the last case, except the value is actually a
 692             # pad offset for where the GV is kept (this happens under
 693             # ithreads)
 694             my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
 695             $h{arg} = "($precomp => \@" . $gv->NAME . ")";
 696         } elsif ($ {$op->pmreplstart}) {
 697             undef $lastnext;
 698             $pmreplstart = "replstart->" . seq($op->pmreplstart);
 699             $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
 700         } else {
 701             $h{arg} = "($precomp)";
 702         }
 703     } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
 704         $h{arg} = '("' . $op->pv . '")';
 705         $h{svval} = '"' . $op->pv . '"';
 706     } elsif ($h{class} eq "COP") {
 707         my $label = $op->label;
 708         $h{coplabel} = $label;
 709         $label = $label ? "$label: " : "";
 710         my $loc = $op->file;
 711         $loc =~ s[.*/][];
 712         $loc .= ":" . $op->line;
 713         my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
 714         my $arybase = $op->arybase;
 715         $arybase = $arybase ? ' $[=' . $arybase : "";
 716         $h{arg} = "($label$stash $cseq $loc$arybase)";
 717     } elsif ($h{class} eq "LOOP") {
 718         $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
 719           . " redo->" . seq($op->redoop) . ")";
 720     } elsif ($h{class} eq "LOGOP") {
 721         undef $lastnext;
 722         $h{arg} = "(other->" . seq($op->other) . ")";
 723     } elsif ($h{class} eq "SVOP") {
 724         unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
 725             if (! ${$op->sv}) {
 726                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
 727                 $h{arg} = "[" . concise_sv($sv, \%h) . "]";
 728                 $h{targarglife} = $h{targarg} = "";
 729             } else {
 730                 $h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
 731             }
 732         }
 733     } elsif ($h{class} eq "PADOP") {
 734         my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
 735         $h{arg} = "[" . concise_sv($sv, \%h) . "]";
 736     }
 737     $h{seq} = $h{hyphseq} = seq($op);
 738     $h{seq} = "" if $h{seq} eq "-";
 739     $h{opt} = $op->opt;
 740     $h{static} = $op->static;
 741     $h{next} = $op->next;
 742     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
 743     $h{nextaddr} = sprintf("%#x", $ {$op->next});
 744     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
 745     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
 746     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
 747
 748     $h{classsym} = $opclass{$h{class}};
 749     $h{flagval} = $op->flags;
 750     $h{flags} = op_flags($op->flags);
 751     $h{privval} = $op->private;
 752     $h{private} = private_flags($h{name}, $op->private);
 753     $h{addr} = sprintf("%#x", $$op);
 754     $h{label} = $labels{$$op};
 755     $h{typenum} = $op->type;
 756     $h{noise} = $linenoise[$op->type];
 757
 758     return fmt_line(\%h, $op, $format, $level);
 759 }
 760
 761 sub B::OP::concise {
 762     my($op, $level) = @_;
 763     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 764         # insert a 'goto' line
 765         my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
 766                      "addr" => sprintf("%#x", $$lastnext),
 767                      "goto" => seq($lastnext), # simplify goto '-' removal
 768              };
 769         print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
 770     }
 771     $lastnext = $op->next;
 772     print $walkHandle concise_op($op, $level, $format);
 773 }
 774
 775 # B::OP::terse (see Terse.pm) now just calls this
 776 sub b_terse {
 777     my($op, $level) = @_;
 778
 779     # This isn't necessarily right, but there's no easy way to get
 780     # from an OP to the right CV. This is a limitation of the
 781     # ->terse() interface style, and there isn't much to do about
 782     # it. In particular, we can die in concise_op if the main pad
 783     # isn't long enough, or has the wrong kind of entries, compared to
 784     # the pad a sub was compiled with. The fix for that would be to
 785     # make a backwards compatible "terse" format that never even
 786     # looked at the pad, just like the old B::Terse. I don't think
 787     # that's worth the effort, though.
 788     $curcv = main_cv unless $curcv;
 789
 790     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 791         # insert a 'goto'
 792         my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
 793                  "addr" => sprintf("%#x", $$lastnext)};
 794         print # $walkHandle
 795             fmt_line($h, $op, $style{"terse"}[1], $level+1);
 796     }
 797     $lastnext = $op->next;
 798     print # $walkHandle
 799         concise_op($op, $level, $style{"terse"}[0]);
 800 }
 801
 802 sub tree {
 803     my $op = shift;
 804     my $level = shift;
 805     my $style = $tree_decorations[$tree_style];
 806     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
 807     my $name = concise_op($op, $level, $treefmt);
 808     if (not $op->flags & OPf_KIDS) {
 809         return $name . "\n";
 810     }
 811     my @lines;
 812     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
 813         push @lines, tree($kid, $level+1);
 814     }
 815     my $i;
 816     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
 817         $lines[$i] = $space . $lines[$i];
 818     }
 819     if ($i > 0) {
 820         $lines[$i] = $last . $lines[$i];
 821         while ($i-- > 1) {
 822             if (substr($lines[$i], 0, 1) eq " ") {
 823                 $lines[$i] = $nokid . $lines[$i];
 824             } else {
 825                 $lines[$i] = $kid . $lines[$i];
 826             }
 827         }
 828         $lines[$i] = $kids . $lines[$i];
 829     } else {
 830         $lines[0] = $single . $lines[0];
 831     }
 832     return("$name$lead" . shift @lines,
 833            map(" " x (length($name)+$size) . $_, @lines));
 834 }
 835
 836 # *** Warning: fragile kludge ahead ***
 837 # Because the B::* modules run in the same interpreter as the code
 838 # they're compiling, their presence tends to distort the view we have of
 839 # the code we're looking at. In particular, perl gives sequence numbers
 840 # to COPs. If the program we're looking at were run on its own, this
 841 # would start at 1. Because all of B::Concise and all the modules it
 842 # uses are compiled first, though, by the time we get to the user's
 843 # program the sequence number is already pretty high, which could be
 844 # distracting if you're trying to tell OPs apart. Therefore we'd like to
 845 # subtract an offset from all the sequence numbers we display, to
 846 # restore the simpler view of the world. The trick is to know what that
 847 # offset will be, when we're still compiling B::Concise!  If we
 848 # hardcoded a value, it would have to change every time B::Concise or
 849 # other modules we use do. To help a little, what we do here is compile
 850 # a little code at the end of the module, and compute the base sequence
 851 # number for the user's program as being a small offset later, so all we
 852 # have to worry about are changes in the offset.
 853
 854 # When you say "perl -MO=Concise -e '$a'", the output should look like:
 855
 856 # 4  <@> leave[t1] vKP/REFC ->(end)
 857 # 1     <0> enter ->2
 858  #^ smallest OP sequence number should be 1
 859 # 2     <;> nextstate(main 1 -e:1) v ->3
 860  #                         ^ smallest COP sequence number should be 1
 861 # -     <1> ex-rv2sv vK/1 ->4
 862 # 3        <$> gvsv(*a) s ->4
 863
 864 # If the second of the marked numbers there isn't 1, it means you need
 865 # to update the corresponding magic number in the next line.
 866 # Remember, this needs to stay the last things in the module.
 867
 868 # Why is this different for MacOS?  Does it matter?
 869 my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
 870 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
 871
 872 1;
 873
 874 __END__
 875
 876 =head1 NAME
 877
 878 B::Concise - Walk Perl syntax tree, printing concise info about ops
 879
 880 =head1 SYNOPSIS
 881
 882     perl -MO=Concise[,OPTIONS] foo.pl
 883
 884     use B::Concise qw(set_style add_callback);
 885
 886 =head1 DESCRIPTION
 887
 888 This compiler backend prints the internal OPs of a Perl program's syntax
 889 tree in one of several space-efficient text formats suitable for debugging
 890 the inner workings of perl or other compiler backends. It can print OPs in
 891 the order they appear in the OP tree, in the order they will execute, or
 892 in a text approximation to their tree structure, and the format of the
 893 information displyed is customizable. Its function is similar to that of
 894 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
 895 sophisticated and flexible.
 896
 897 =head1 EXAMPLE
 898
 899 Here's is a short example of output (aka 'rendering'), using the
 900 default formatting conventions :
 901
 902     % perl -MO=Concise -e '$a = $b + 42'
 903     8  <@> leave[1 ref] vKP/REFC ->(end)
 904     1     <0> enter ->2
 905     2     <;> nextstate(main 1 -e:1) v ->3
 906     7     <2> sassign vKS/2 ->8
 907     5        <2> add[t1] sK/2 ->6
 908     -           <1> ex-rv2sv sK/1 ->4
 909     3              <$> gvsv(*b) s ->4
 910     4           <$> const(IV 42) s ->5
 911     -        <1> ex-rv2sv sKRM*/1 ->7
 912     6           <$> gvsv(*a) s ->7
 913
 914 Each line corresponds to an opcode. Null ops appear as C<ex-opname>,
 915 where I<opname> is the op that has been optimized away by perl.
 916
 917 The number on the first row indicates the op's sequence number. It's
 918 given in base 36 by default.
 919
 920 The symbol between angle brackets indicates the op's type : for example,
 921 <2> is a BINOP, <@> a LISTOP, etc. (see L</"OP class abbreviations">).
 922
 923 The opname may be followed by op-specific information in parentheses
 924 (e.g. C<gvsv(*b)>), and by targ information in brackets (e.g.
 925 C<leave[t1]>).
 926
 927 Next come the op flags. The common flags are listed below
 928 (L</"OP flags abbreviations">). The private flags follow, separated
 929 by a slash. For example, C<vKP/REFC> means that the leave op has
 930 public flags OPf_WANT_VOID, OPf_KIDS, and OPf_PARENS, and the private
 931 flag OPpREFCOUNTED.
 932
 933 Finally an arrow points to the sequence number of the next op.
 934
 935 =head1 OPTIONS
 936
 937 Arguments that don't start with a hyphen are taken to be the names of
 938 subroutines to print the OPs of; if no such functions are specified,
 939 the main body of the program (outside any subroutines, and not
 940 including use'd or require'd files) is printed. Passing C<BEGIN>,
 941 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
 942 special blocks to be printed.
 943
 944 Options affect how things are rendered (ie printed).  They're presented
 945 here by their visual effect, 1st being strongest.  They're grouped
 946 according to how they interrelate; within each group the options are
 947 mutually exclusive (unless otherwise stated).
 948
 949 =head2 Options for Opcode Ordering
 950
 951 These options control the 'vertical display' of opcodes.  The display
 952 'order' is also called 'mode' elsewhere in this document.
 953
 954 =over 4
 955
 956 =item B<-basic>
 957
 958 Print OPs in the order they appear in the OP tree (a preorder
 959 traversal, starting at the root). The indentation of each OP shows its
 960 level in the tree.  This mode is the default, so the flag is included
 961 simply for completeness.
 962
 963 =item B<-exec>
 964
 965 Print OPs in the order they would normally execute (for the majority
 966 of constructs this is a postorder traversal of the tree, ending at the
 967 root). In most cases the OP that usually follows a given OP will
 968 appear directly below it; alternate paths are shown by indentation. In
 969 cases like loops when control jumps out of a linear path, a 'goto'
 970 line is generated.
 971
 972 =item B<-tree>
 973
 974 Print OPs in a text approximation of a tree, with the root of the tree
 975 at the left and 'left-to-right' order of children transformed into
 976 'top-to-bottom'. Because this mode grows both to the right and down,
 977 it isn't suitable for large programs (unless you have a very wide
 978 terminal).
 979
 980 =back
 981
 982 =head2 Options for Line-Style
 983
 984 These options select the line-style (or just style) used to render
 985 each opcode, and dictates what info is actually printed into each line.
 986
 987 =over 4
 988
 989 =item B<-concise>
 990
 991 Use the author's favorite set of formatting conventions. This is the
 992 default, of course.
 993
 994 =item B<-terse>
 995
 996 Use formatting conventions that emulate the output of B<B::Terse>. The
 997 basic mode is almost indistinguishable from the real B<B::Terse>, and the
 998 exec mode looks very similar, but is in a more logical order and lacks
 999 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
1000 is only vaguely reminiscent of B<B::Terse>.
1001
1002 =item B<-linenoise>
1003
1004 Use formatting conventions in which the name of each OP, rather than being
1005 written out in full, is represented by a one- or two-character abbreviation.
1006 This is mainly a joke.
1007
1008 =item B<-debug>
1009
1010 Use formatting conventions reminiscent of B<B::Debug>; these aren't
1011 very concise at all.
1012
1013 =item B<-env>
1014
1015 Use formatting conventions read from the environment variables
1016 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
1017
1018 =back
1019
1020 =head2 Options for tree-specific formatting
1021
1022 =over 4
1023
1024 =item B<-compact>
1025
1026 Use a tree format in which the minimum amount of space is used for the
1027 lines connecting nodes (one character in most cases). This squeezes out
1028 a few precious columns of screen real estate.
1029
1030 =item B<-loose>
1031
1032 Use a tree format that uses longer edges to separate OP nodes. This format
1033 tends to look better than the compact one, especially in ASCII, and is
1034 the default.
1035
1036 =item B<-vt>
1037
1038 Use tree connecting characters drawn from the VT100 line-drawing set.
1039 This looks better if your terminal supports it.
1040
1041 =item B<-ascii>
1042
1043 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
1044 look as clean as the VT100 characters, but they'll work with almost any
1045 terminal (or the horizontal scrolling mode of less(1)) and are suitable
1046 for text documentation or email. This is the default.
1047
1048 =back
1049
1050 These are pairwise exclusive, i.e. compact or loose, vt or ascii.
1051
1052 =head2 Options controlling sequence numbering
1053
1054 =over 4
1055
1056 =item B<-base>I<n>
1057
1058 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
1059 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
1060 for 37 will be 'A', and so on until 62. Values greater than 62 are not
1061 currently supported. The default is 36.
1062
1063 =item B<-bigendian>
1064
1065 Print sequence numbers with the most significant digit first. This is the
1066 usual convention for Arabic numerals, and the default.
1067
1068 =item B<-littleendian>
1069
1070 Print seqence numbers with the least significant digit first.  This is
1071 obviously mutually exclusive with bigendian.
1072
1073 =back
1074
1075 =head2 Other options
1076
1077 These are pairwise exclusive.
1078
1079 =over 4
1080
1081 =item B<-main>
1082
1083 Include the main program in the output, even if subroutines were also
1084 specified.  This rendering is normally suppressed when a subroutine
1085 name or reference is given.
1086
1087 =item B<-nomain>
1088
1089 This restores the default behavior after you've changed it with '-main'
1090 (it's not normally needed).  If no subroutine name/ref is given, main is
1091 rendered, regardless of this flag.
1092
1093 =item B<-nobanner>
1094
1095 Renderings usually include a banner line identifying the function name
1096 or stringified subref.  This suppresses the printing of the banner.
1097
1098 TBC: Remove the stringified coderef; while it provides a 'cookie' for
1099 each function rendered, the cookies used should be 1,2,3.. not a
1100 random hex-address.  It also complicates string comparison of two
1101 different trees.
1102
1103 =item B<-banner>
1104
1105 restores default banner behavior.
1106
1107 =item B<-banneris> => subref
1108
1109 TBC: a hookpoint (and an option to set it) for a user-supplied
1110 function to produce a banner appropriate for users needs.  It's not
1111 ideal, because the rendering-state variables, which are a natural
1112 candidate for use in concise.t, are unavailable to the user.
1113
1114 =back
1115
1116 =head2 Option Stickiness
1117
1118 If you invoke Concise more than once in a program, you should know that
1119 the options are 'sticky'.  This means that the options you provide in
1120 the first call will be remembered for the 2nd call, unless you
1121 re-specify or change them.
1122
1123 =head1 ABBREVIATIONS
1124
1125 The concise style uses symbols to convey maximum info with minimal
1126 clutter (like hex addresses).  With just a little practice, you can
1127 start to see the flowers, not just the branches, in the trees.
1128
1129 =head2 OP class abbreviations
1130
1131 These symbols appear before the op-name, and indicate the
1132 B:: namespace that represents the ops in your Perl code.
1133
1134     0      OP (aka BASEOP)  An OP with no children
1135     1      UNOP             An OP with one child
1136     2      BINOP            An OP with two children
1137     |      LOGOP            A control branch OP
1138     @      LISTOP           An OP that could have lots of children
1139     /      PMOP             An OP with a regular expression
1140     $      SVOP             An OP with an SV
1141     "      PVOP             An OP with a string
1142     {      LOOP             An OP that holds pointers for a loop
1143     ;      COP              An OP that marks the start of a statement
1144     #      PADOP            An OP with a GV on the pad
1145
1146 =head2 OP flags abbreviations
1147
1148 These symbols represent various flags which alter behavior of the
1149 opcode, sometimes in opcode-specific ways.
1150
1151     v      OPf_WANT_VOID    Want nothing (void context)
1152     s      OPf_WANT_SCALAR  Want single value (scalar context)
1153     l      OPf_WANT_LIST    Want list of any length (list context)
1154     K      OPf_KIDS         There is a firstborn child.
1155     P      OPf_PARENS       This operator was parenthesized.
1156                              (Or block needs explicit scope entry.)
1157     R      OPf_REF          Certified reference.
1158                              (Return container, not containee).
1159     M      OPf_MOD          Will modify (lvalue).
1160     S      OPf_STACKED      Some arg is arriving on the stack.
1161     *      OPf_SPECIAL      Do something weird for this op (see op.h)
1162
1163 =head1 FORMATTING SPECIFICATIONS
1164
1165 For each line-style ('concise', 'terse', 'linenoise', etc.) there are
1166 3 format-specs which control how OPs are rendered.
1167
1168 The first is the 'default' format, which is used in both basic and exec
1169 modes to print all opcodes.  The 2nd, goto-format, is used in exec
1170 mode when branches are encountered.  They're not real opcodes, and are
1171 inserted to look like a closing curly brace.  The tree-format is tree
1172 specific.
1173
1174 When a line is rendered, the correct format-spec is copied and scanned
1175 for the following items; data is substituted in, and other
1176 manipulations like basic indenting are done, for each opcode rendered.
1177
1178 There are 3 kinds of items that may be populated; special patterns,
1179 #vars, and literal text, which is copied verbatim.  (Yes, it's a set
1180 of s///g steps.)
1181
1182 =head2 Special Patterns
1183
1184 These items are the primitives used to perform indenting, and to
1185 select text from amongst alternatives.
1186
1187 =over 4
1188
1189 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
1190
1191 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
1192
1193 =item B<(*(>I<text>B<)*)>
1194
1195 Generates one copy of I<text> for each indentation level.
1196
1197 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
1198
1199 Generates one fewer copies of I<text1> than the indentation level, followed
1200 by one copy of I<text2> if the indentation level is more than 0.
1201
1202 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
1203
1204 If the value of I<var> is true (not empty or zero), generates the
1205 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
1206 nothing.
1207
1208 =item B<~>
1209
1210 Any number of tildes and surrounding whitespace will be collapsed to
1211 a single space.
1212
1213 =back
1214
1215 =head2 # Variables
1216
1217 These #vars represent opcode properties that you may want as part of
1218 your rendering.  The '#' is intended as a private sigil; a #var's
1219 value is interpolated into the style-line, much like "read $this".
1220
1221 These vars take 3 forms:
1222
1223 =over 4
1224
1225 =item B<#>I<var>
1226
1227 A property named 'var' is assumed to exist for the opcodes, and is
1228 interpolated into the rendering.
1229
1230 =item B<#>I<var>I<N>
1231
1232 Generates the value of I<var>, left justified to fill I<N> spaces.
1233 Note that this means while you can have properties 'foo' and 'foo2',
1234 you cannot render 'foo2', but you could with 'foo2a'.  You would be
1235 wise not to rely on this behavior going forward ;-)
1236
1237 =item B<#>I<Var>
1238
1239 This ucfirst form of #var generates a tag-value form of itself for
1240 display; it converts '#Var' into a 'Var => #var' style, which is then
1241 handled as described above.  (Imp-note: #Vars cannot be used for
1242 conditional-fills, because the => #var transform is done after the check
1243 for #Var's value).
1244
1245 =back
1246
1247 The following variables are 'defined' by B::Concise; when they are
1248 used in a style, their respective values are plugged into the
1249 rendering of each opcode.
1250
1251 Only some of these are used by the standard styles, the others are
1252 provided for you to delve into optree mechanics, should you wish to
1253 add a new style (see L</add_style> below) that uses them.  You can
1254 also add new ones using L<add_callback>.
1255
1256 =over 4
1257
1258 =item B<#addr>
1259
1260 The address of the OP, in hexadecimal.
1261
1262 =item B<#arg>
1263
1264 The OP-specific information of the OP (such as the SV for an SVOP, the
1265 non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
1266
1267 =item B<#class>
1268
1269 The B-determined class of the OP, in all caps.
1270
1271 =item B<#classsym>
1272
1273 A single symbol abbreviating the class of the OP.
1274
1275 =item B<#coplabel>
1276
1277 The label of the statement or block the OP is the start of, if any.
1278
1279 =item B<#exname>
1280
1281 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
1282
1283 =item B<#extarg>
1284
1285 The target of the OP, or nothing for a nulled OP.
1286
1287 =item B<#firstaddr>
1288
1289 The address of the OP's first child, in hexidecimal.
1290
1291 =item B<#flags>
1292
1293 The OP's flags, abbreviated as a series of symbols.
1294
1295 =item B<#flagval>
1296
1297 The numeric value of the OP's flags.
1298
1299 =item B<#hyphseq>
1300
1301 The sequence number of the OP, or a hyphen if it doesn't have one.
1302
1303 =item B<#label>
1304
1305 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
1306 mode, or empty otherwise.
1307
1308 =item B<#lastaddr>
1309
1310 The address of the OP's last child, in hexidecimal.
1311
1312 =item B<#name>
1313
1314 The OP's name.
1315
1316 =item B<#NAME>
1317
1318 The OP's name, in all caps.
1319
1320 =item B<#next>
1321
1322 The sequence number of the OP's next OP.
1323
1324 =item B<#nextaddr>
1325
1326 The address of the OP's next OP, in hexidecimal.
1327
1328 =item B<#noise>
1329
1330 A one- or two-character abbreviation for the OP's name.
1331
1332 =item B<#private>
1333
1334 The OP's private flags, rendered with abbreviated names if possible.
1335
1336 =item B<#privval>
1337
1338 The numeric value of the OP's private flags.
1339
1340 =item B<#seq>
1341
1342 The sequence number of the OP. Note that this is a sequence number
1343 generated by B::Concise.
1344
1345 =item B<#opt>
1346
1347 Whether or not the op has been optimised by the peephole optimiser.
1348
1349 =item B<#static>
1350
1351 Whether or not the op is statically defined.  This flag is used by the
1352 B::C compiler backend and indicates that the op should not be freed.
1353
1354 =item B<#sibaddr>
1355
1356 The address of the OP's next youngest sibling, in hexidecimal.
1357
1358 =item B<#svaddr>
1359
1360 The address of the OP's SV, if it has an SV, in hexidecimal.
1361
1362 =item B<#svclass>
1363
1364 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
1365
1366 =item B<#svval>
1367
1368 The value of the OP's SV, if it has one, in a short human-readable format.
1369
1370 =item B<#targ>
1371
1372 The numeric value of the OP's targ.
1373
1374 =item B<#targarg>
1375
1376 The name of the variable the OP's targ refers to, if any, otherwise the
1377 letter t followed by the OP's targ in decimal.
1378
1379 =item B<#targarglife>
1380
1381 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
1382 the variable's lifetime (or 'end' for a variable in an open scope) for a
1383 variable.
1384
1385 =item B<#typenum>
1386
1387 The numeric value of the OP's type, in decimal.
1388
1389 =back
1390
1391 =head1 Using B::Concise outside of the O framework
1392
1393 The common (and original) usage of B::Concise was for command-line
1394 renderings of simple code, as given in EXAMPLE.  But you can also use
1395 B<B::Concise> from your code, and call compile() directly, and
1396 repeatedly.  By doing so, you can avoid the compile-time only
1397 operation of O.pm, and even use the debugger to step through
1398 B::Concise::compile() itself.
1399
1400 Once you're doing this, you may alter Concise output by adding new
1401 rendering styles, and by optionally adding callback routines which
1402 populate new variables, if such were referenced from those (just
1403 added) styles.
1404
1405 =head2 Example: Altering Concise Renderings
1406
1407     use B::Concise qw(set_style add_callback);
1408     add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
1409     add_callback
1410       ( sub {
1411             my ($h, $op, $format, $level, $stylename) = @_;
1412             $h->{variable} = some_func($op);
1413         });
1414     $walker = B::Concise::compile(@options,@subnames,@subrefs);
1415     $walker->();
1416
1417 =head2 set_style()
1418
1419 B<set_style> accepts 3 arguments, and updates the three format-specs
1420 comprising a line-style (basic-exec, goto, tree).  It has one minor
1421 drawback though; it doesn't register the style under a new name.  This
1422 can become an issue if you render more than once and switch styles.
1423 Thus you may prefer to use add_style() and/or set_style_standard()
1424 instead.
1425
1426 =head2 set_style_standard($name)
1427
1428 This restores one of the standard line-styles: C<terse>, C<concise>,
1429 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
1430 names previously defined with add_style().
1431
1432 =head2 add_style()
1433
1434 This subroutine accepts a new style name and three style arguments as
1435 above, and creates, registers, and selects the newly named style.  It is
1436 an error to re-add a style; call set_style_standard() to switch between
1437 several styles.
1438
1439 =head2 add_callback()
1440
1441 If your newly minted styles refer to any #variables, you'll need to
1442 define a callback subroutine that will populate (or modify) those
1443 variables.  They are then available for use in the style you've chosen.
1444
1445 The callbacks are called for each opcode visited by Concise, in the
1446 same order as they are added.  Each subroutine is passed five
1447 parameters.
1448
1449   1. A hashref, containing the variable names and values which are
1450      populated into the report-line for the op
1451   2. the op, as a B<B::OP> object
1452   3. a reference to the format string
1453   4. the formatting (indent) level
1454   5. the selected stylename
1455
1456 To define your own variables, simply add them to the hash, or change
1457 existing values if you need to.  The level and format are passed in as
1458 references to scalars, but it is unlikely that they will need to be
1459 changed or even used.
1460
1461 =head2 Running B::Concise::compile()
1462
1463 B<compile> accepts options as described above in L</OPTIONS>, and
1464 arguments, which are either coderefs, or subroutine names.
1465
1466 It constructs and returns a $treewalker coderef, which when invoked,
1467 traverses, or walks, and renders the optrees of the given arguments to
1468 STDOUT.  You can reuse this, and can change the rendering style used
1469 each time; thereafter the coderef renders in the new style.
1470
1471 B<walk_output> lets you change the print destination from STDOUT to
1472 another open filehandle, or (unless you've built with -Uuseperlio)
1473 into a string passed as a ref.
1474
1475     my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef);  # 1
1476     walk_output(\my $buf);
1477     $walker->();                        # 1 renders -terse
1478     set_style_standard('concise');      # 2
1479     $walker->();                        # 2 renders -concise
1480     $walker->(@new);                    # 3 renders whatever
1481     print "3 different renderings: terse, concise, and @new: $buf\n";
1482
1483 When $walker is called, it traverses the subroutines supplied when it
1484 was created, and renders them using the current style.  You can change
1485 the style afterwards in several different ways:
1486
1487   1. call C<compile>, altering style or mode/order
1488   2. call C<set_style_standard>
1489   3. call $walker, passing @new options
1490
1491 Passing new options to the $walker is the easiest way to change
1492 amongst any pre-defined styles (the ones you add are automatically
1493 recognized as options), and is the only way to alter rendering order
1494 without calling compile again.  Note however that rendering state is
1495 still shared amongst multiple $walker objects, so they must still be
1496 used in a coordinated manner.
1497
1498 =head2 B::Concise::reset_sequence()
1499
1500 This function (not exported) lets you reset the sequence numbers (note
1501 that they're numbered arbitrarily, their goal being to be human
1502 readable).  Its purpose is mostly to support testing, i.e. to compare
1503 the concise output from two identical anonymous subroutines (but
1504 different instances).  Without the reset, B::Concise, seeing that
1505 they're separate optrees, generates different sequence numbers in
1506 the output.
1507
1508 =head2 Errors
1509
1510 All detected errors, (invalid arguments, internal errors, etc.) are
1511 resolved with a die($message). Use an eval if you wish to catch these
1512 errors and continue processing.
1513
1514 In particular, B<compile> will die if you've asked for a non-existent
1515 function-name, a non-existent coderef, or a non-CODE reference.
1516
1517 =head1 AUTHOR
1518
1519 Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
1520
1521 =cut