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