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