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