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