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