This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
OPpRUNTIME can be set on OP_QR too
[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
c0939cee 17our $VERSION = "0.66";
78ad9108 18our @ISA = qw(Exporter);
cc02ea56
JC
19our @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 );
22our %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 )], );
78ad9108 27
8ec8fbef 28# use #6
c99ca59a 29use B qw(class ppname main_start main_root main_cv cstring svref_2object
6a077020
DM
30 SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
31 CVf_ANON);
c99ca59a 32
f95e3c3c 33my %style =
c99ca59a 34 ("terse" =>
c3caa09d
SM
35 ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
36 . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
c99ca59a
SM
37 "(*( )*)goto #class (#addr)\n",
38 "#class pp_#name"],
39 "concise" =>
40 ["#hyphseq2 (*( (x( ;)x))*)<#classsym> "
cc02ea56
JC
41 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n"
42 , " (*( )*) goto #seq\n",
c99ca59a
SM
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"
7252851f
NC
50 . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
51 ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
2814eb74 52 . "\top_flags\t#flagval\n\top_private\t#privval\n"
c99ca59a
SM
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
724aa791
JC
61# Renderings, ie how Concise prints, is controlled by these vars
62# primary:
63our $stylename; # selects current style from %style
64my $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
69my ($format, $gotofmt, $treefmt);
70
71# lesser players:
72my $base = 36; # how <sequence#> is displayed
73my $big_endian = 1; # more <sequence#> display
74my $tree_style = 0; # tree-order details
75my $banner = 1; # print banner before optree is traversed
cc02ea56 76my $do_main = 0; # force printing of main routine
724aa791 77
cc02ea56 78# another factor: can affect all styles!
724aa791
JC
79our @callbacks; # allow external management
80
81set_style_standard("concise");
82
c99ca59a 83my $curcv;
c27ea44e 84my $cop_seq_base;
78ad9108
PJ
85
86sub set_style {
87 ($format, $gotofmt, $treefmt) = @_;
724aa791 88 #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
f95e3c3c
JC
89 die "expecting 3 style-format args\n" unless @_ == 3;
90}
91
92sub 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];
724aa791 98 $stylename = $newstyle; # update rendering state
78ad9108
PJ
99}
100
31b49ad4 101sub set_style_standard {
724aa791 102 ($stylename) = @_; # update rendering state
f95e3c3c
JC
103 die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
104 set_style(@{$style{$stylename}});
31b49ad4
SM
105}
106
78ad9108
PJ
107sub add_callback {
108 push @callbacks, @_;
109}
c99ca59a 110
f95e3c3c 111# output handle, used with all Concise-output printing
cc02ea56
JC
112our $walkHandle; # public for your convenience
113BEGIN { $walkHandle = \*STDOUT }
f95e3c3c
JC
114
115sub walk_output { # updates $walkHandle
116 my $handle = shift;
cc02ea56
JC
117 return $walkHandle unless $handle; # allow use as accessor
118
f95e3c3c 119 if (ref $handle eq 'SCALAR') {
2ce64696
JC
120 require Config;
121 die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
122 unless $Config::Config{useperlio};
f95e3c3c 123 # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
2ce64696 124 open my $tmp, '>', $handle; # but cant re-set existing STDOUT
f95e3c3c 125 $walkHandle = $tmp; # so use my $tmp as intermediate var
cc02ea56 126 return $walkHandle;
f95e3c3c 127 }
cc02ea56 128 my $iotype = ref $handle;
f95e3c3c 129 die "expecting argument/object that can print\n"
cc02ea56
JC
130 unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
131 $walkHandle = $handle;
f95e3c3c
JC
132}
133
8ec8fbef 134sub concise_subref {
c0939cee 135 my($order, $coderef, $name) = @_;
f95e3c3c 136 my $codeobj = svref_2object($coderef);
cc02ea56 137
c0939cee 138 return concise_stashref(@_)
cc02ea56 139 unless ref $codeobj eq 'B::CV';
c0939cee 140 concise_cv_obj($order, $codeobj, $name);
8ec8fbef
SM
141}
142
cc02ea56
JC
143sub 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
8ec8fbef
SM
157# This should have been called concise_subref, but it was exported
158# under this name in versions before 0.56
c0939cee 159*concise_cv = \&concise_subref;
8ec8fbef
SM
160
161sub concise_cv_obj {
c0939cee
JC
162 my ($order, $cv, $name) = @_;
163 # name is either a string, or a CODE ref (copy of $cv arg??)
164
c99ca59a 165 $curcv = $cv;
c0939cee
JC
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) {
e75702e9 176 print $walkHandle "$name exists in stash, but has no START\n";
c0939cee
JC
177 }
178 else {
179 print $walkHandle "$name not in symbol table\n";
180 }
181 return;
182 }
c27ea44e 183 sequence($cv->START);
c99ca59a
SM
184 if ($order eq "exec") {
185 walk_exec($cv->START);
c0939cee
JC
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 }
c99ca59a 195 } else {
f95e3c3c 196 print $walkHandle tree($cv->ROOT, 0);
c99ca59a
SM
197 }
198}
199
31b49ad4
SM
200sub 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";
f95e3c3c 209 print $walkHandle tree(main_root, 0);
31b49ad4
SM
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
8ec8fbef
SM
217sub concise_specials {
218 my($name, $order, @cv_s) = @_;
219 my $i = 1;
220 if ($name eq "BEGIN") {
c0939cee 221 splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
8ec8fbef
SM
222 } elsif ($name eq "CHECK") {
223 pop @cv_s; # skip the CHECK block that calls us
224 }
f95e3c3c
JC
225 for my $cv (@cv_s) {
226 print $walkHandle "$name $i:\n";
8ec8fbef 227 $i++;
c0939cee 228 concise_cv_obj($order, $cv, $name);
8ec8fbef
SM
229 }
230}
231
c99ca59a
SM
232my $start_sym = "\e(0"; # "\cN" sometimes also works
233my $end_sym = "\e(B"; # "\cO" respectively
234
f95e3c3c 235my @tree_decorations =
c99ca59a
SM
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 );
78ad9108 241
cc02ea56
JC
242
243sub compileOpts {
244 # set rendering state from options and args
c0939cee
JC
245 my (@options,@args);
246 if (@_) {
247 @options = grep(/^-/, @_);
248 @args = grep(!/^-/, @_);
249 }
c99ca59a 250 for my $o (@options) {
cc02ea56 251 # mode/order
c99ca59a
SM
252 if ($o eq "-basic") {
253 $order = "basic";
254 } elsif ($o eq "-exec") {
255 $order = "exec";
256 } elsif ($o eq "-tree") {
257 $order = "tree";
cc02ea56
JC
258 }
259 # tree-specific
260 elsif ($o eq "-compact") {
c99ca59a
SM
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;
cc02ea56
JC
268 }
269 # sequence numbering
270 elsif ($o =~ /^-base(\d+)$/) {
c99ca59a
SM
271 $base = $1;
272 } elsif ($o eq "-bigendian") {
273 $big_endian = 1;
274 } elsif ($o eq "-littleendian") {
275 $big_endian = 0;
cc02ea56
JC
276 }
277 elsif ($o eq "-nobanner") {
724aa791 278 $banner = 0;
cc02ea56
JC
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;
724aa791 286 }
cc02ea56 287 # line-style options
724aa791 288 elsif (exists $style{substr($o, 1)}) {
f95e3c3c 289 $stylename = substr($o, 1);
724aa791 290 set_style_standard($stylename);
c99ca59a
SM
291 } else {
292 warn "Option $o unrecognized";
293 }
294 }
cc02ea56
JC
295 return (@args);
296}
297
298sub compile {
299 my (@args) = compileOpts(@_);
c27ea44e 300 return sub {
cc02ea56
JC
301 my @newargs = compileOpts(@_); # accept new rendering options
302 warn "disregarding non-options: @newargs\n" if @newargs;
303
304 for my $objname (@args) {
59910b6d
JC
305 next unless $objname; # skip null args to avoid noisy responses
306
cc02ea56
JC
307 if ($objname eq "BEGIN") {
308 concise_specials("BEGIN", $order,
c0939cee
JC
309 B::begin_av->isa("B::AV") ?
310 B::begin_av->ARRAY : ());
cc02ea56
JC
311 } elsif ($objname eq "INIT") {
312 concise_specials("INIT", $order,
c0939cee
JC
313 B::init_av->isa("B::AV") ?
314 B::init_av->ARRAY : ());
cc02ea56
JC
315 } elsif ($objname eq "CHECK") {
316 concise_specials("CHECK", $order,
c0939cee
JC
317 B::check_av->isa("B::AV") ?
318 B::check_av->ARRAY : ());
cc02ea56
JC
319 } elsif ($objname eq "END") {
320 concise_specials("END", $order,
c0939cee
JC
321 B::end_av->isa("B::AV") ?
322 B::end_av->ARRAY : ());
cc02ea56
JC
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;
8ec8fbef 331 } else {
cc02ea56
JC
332 $objname = "main::" . $objname unless $objname =~ /::/;
333 print $walkHandle "$objname:\n";
334 no strict 'refs';
c0939cee
JC
335 unless (exists &$objname) {
336 print $walkHandle "err: unknown function ($objname)\n";
337 return;
338 }
cc02ea56 339 $objref = \&$objname;
8ec8fbef 340 }
c0939cee 341 concise_subref($order, $objref, $objname);
c99ca59a
SM
342 }
343 }
c27ea44e 344 if (!@args or $do_main) {
f95e3c3c 345 print $walkHandle "main program:\n" if $do_main;
31b49ad4 346 concise_main($order);
c99ca59a 347 }
cc02ea56 348 return @args; # something
c99ca59a
SM
349 }
350}
351
352my %labels;
724aa791 353my $lastnext; # remembers op-chain, used to insert gotos
c99ca59a
SM
354
355my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
356 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
051f02e9 357 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
c99ca59a 358
8ec8fbef 359no warnings 'qw'; # "Possible attempt to put comments..."; use #7
35fc55f1
RH
360my @linenoise =
361 qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
c99ca59a
SM
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
c27ea44e 375 Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
c99ca59a
SM
376
377my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
378
19e169bf 379sub op_flags { # common flags (see BASOP.op_flags in op.h)
c99ca59a
SM
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
394sub 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
c27ea44e
SM
403my %sequence_num;
404my $seq_max = 1;
405
f95e3c3c
JC
406sub reset_sequence {
407 # reset the sequence
408 %sequence_num = ();
409 $seq_max = 1;
cc02ea56 410 $lastnext = 0;
f95e3c3c
JC
411}
412
c27ea44e
SM
413sub seq {
414 my($op) = @_;
415 return "-" if not exists $sequence_num{$$op};
416 return base_n($sequence_num{$$op});
417}
c99ca59a
SM
418
419sub 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 }
c0939cee 427 elsif (class($op) eq "PMOP") {
c6e79e55
SM
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 }
c99ca59a
SM
434 }
435}
436
437sub 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
448sub 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;
62e36f8a 458 if (class($op) eq "LOGOP") {
c99ca59a
SM
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)$/) {
7252851f
NC
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 }
c99ca59a
SM
476 }
477 }
478 }
479 walklines(\@lines, 0);
480}
481
c27ea44e
SM
482# The structure of this routine is purposely modeled after op.c's peep()
483sub 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
724aa791 518sub fmt_line { # generate text-line for op.
cc02ea56
JC
519 my($hr, $op, $text, $level) = @_;
520
521 $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
522
724aa791 523 return '' if $hr->{SKIP}; # suppress line if a callback said so
cc02ea56 524 return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
f95e3c3c 525
cc02ea56 526 # spec: (?(text1#varText2)?)
c99ca59a 527 $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
f95e3c3c
JC
528 $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
529
cc02ea56 530 # spec: (x(exec_text;basic_text)x)
c99ca59a 531 $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
cc02ea56
JC
532
533 # spec: (*(text)*)
c99ca59a 534 $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
cc02ea56
JC
535
536 # spec: (*(text1;text2)*)
c99ca59a 537 $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
cc02ea56
JC
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
724aa791
JC
543 $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
544
cc02ea56
JC
545 $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
546 $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
f95e3c3c
JC
547 chomp $text;
548 return "$text\n" if $text ne "";
549 return $text; # suppress empty lines
c99ca59a
SM
550}
551
19e169bf
JC
552our %priv; # used to display each opcode's BASEOP.op_private values
553
c99ca59a
SM
554$priv{$_}{128} = "LVINTRO"
555 for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
556 "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
241416b8 557 "padav", "padhv", "enteriter");
c99ca59a
SM
558$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
559$priv{"aassign"}{64} = "COMMON";
4ac6efe6 560$priv{"aassign"}{32} = "PHASH" if $] < 5.009;
c99ca59a 561$priv{"sassign"}{64} = "BKWARD";
7abc42fc 562$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
c99ca59a
SM
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")
314d4778 568 for (qw(rv2gv rv2sv padsv aelem helem));
d4797c1d 569@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
c99ca59a
SM
570@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
571$priv{"gv"}{32} = "EARLYCV";
572$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
241416b8
DM
573$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
574 "enteriter");
c99ca59a
SM
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");
ef3e5ea9 587$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
d4797c1d 588@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
c99ca59a
SM
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");
6c3fb703 596@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC");
c99ca59a 597$priv{"threadsv"}{64} = "SVREFd";
c27ea44e
SM
598@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
599 for ("open", "backtick");
c99ca59a 600$priv{"exit"}{128} = "VMS";
feaeca78
JH
601$priv{$_}{2} = "FTACCESS"
602 for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
32454ac8
NC
603if ($] >= 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}
c99ca59a
SM
615
616sub 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
c27ea44e 629sub concise_sv {
2db5ca0a 630 my($sv, $hr, $preferpv) = @_;
c27ea44e 631 $hr->{svclass} = class($sv);
31b49ad4
SM
632 $hr->{svclass} = "UV"
633 if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
5b493bdf 634 Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
c27ea44e
SM
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") {
40b5b14f 652 $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
2db5ca0a
YST
653 } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
654 $hr->{svval} .= cstring($sv->PV);
c27ea44e 655 } elsif ($sv->FLAGS & SVf_NOK) {
40b5b14f 656 $hr->{svval} .= $sv->NV;
c27ea44e 657 } elsif ($sv->FLAGS & SVf_IOK) {
31b49ad4 658 $hr->{svval} .= $sv->int_value;
c27ea44e 659 } elsif ($sv->FLAGS & SVf_POK) {
40b5b14f 660 $hr->{svval} .= cstring($sv->PV);
31b49ad4
SM
661 } elsif (class($sv) eq "HV") {
662 $hr->{svval} .= 'HASH';
c27ea44e 663 }
cc02ea56
JC
664
665 $hr->{svval} = 'undef' unless defined $hr->{svval};
666 my $out = $hr->{svclass};
667 return $out .= " $hr->{svval}" ;
c27ea44e
SM
668 }
669}
670
c99ca59a
SM
671sub 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}) {
8ec8fbef 680 # targ holds the old type
c99ca59a
SM
681 $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
682 $h{extarg} = "";
8ec8fbef
SM
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 }
c99ca59a
SM
689 } elsif ($h{targ}) {
690 my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
691 if (defined $padname and class($padname) ne "SPECIAL") {
0b40bd6d 692 $h{targarg} = $padname->PVX;
127212b2 693 if ($padname->FLAGS & SVf_FAKE) {
4ac6efe6
NC
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 }
127212b2
DM
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 }
c99ca59a
SM
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;
7a9b44b9 720 if (defined $precomp) {
c27ea44e
SM
721 $precomp = cstring($precomp); # Escape literal control sequences
722 $precomp = "/$precomp/";
723 } else {
724 $precomp = "";
7a9b44b9 725 }
b2a3cfdd 726 my $pmreplroot = $op->pmreplroot;
34a48b4b 727 my $pmreplstart;
c6e79e55 728 if (ref($pmreplroot) eq "B::GV") {
b2a3cfdd 729 # with C<@stash_array = split(/pat/, str);>,
c6e79e55 730 # *stash_array is stored in /pat/'s pmreplroot.
b2a3cfdd 731 $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
c6e79e55
SM
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 . ")";
b2a3cfdd 738 } elsif ($ {$op->pmreplstart}) {
c99ca59a
SM
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;
c3caa09d 750 $h{coplabel} = $label;
c99ca59a
SM
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) . ")";
5b493bdf
JC
765 }
766 elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
6a077020 767 unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
5b493bdf 768 my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
2db5ca0a 769 my $preferpv = $h{name} eq "method_named";
5b493bdf
JC
770 if ($h{class} eq "PADOP" or !${$op->sv}) {
771 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
2db5ca0a 772 $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
6a077020
DM
773 $h{targarglife} = $h{targarg} = "";
774 } else {
2db5ca0a 775 $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
6a077020 776 }
c99ca59a
SM
777 }
778 }
779 $h{seq} = $h{hyphseq} = seq($op);
780 $h{seq} = "" if $h{seq} eq "-";
7252851f
NC
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 }
c99ca59a
SM
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);
c99ca59a
SM
802 $h{typenum} = $op->type;
803 $h{noise} = $linenoise[$op->type];
f95e3c3c 804
cc02ea56 805 return fmt_line(\%h, $op, $format, $level);
c99ca59a
SM
806}
807
808sub B::OP::concise {
809 my($op, $level) = @_;
810 if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
724aa791 811 # insert a 'goto' line
cc02ea56
JC
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);
c99ca59a
SM
817 }
818 $lastnext = $op->next;
f95e3c3c 819 print $walkHandle concise_op($op, $level, $format);
c99ca59a
SM
820}
821
31b49ad4
SM
822# B::OP::terse (see Terse.pm) now just calls this
823sub 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) {
724aa791 838 # insert a 'goto'
31b49ad4
SM
839 my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
840 "addr" => sprintf("%#x", $$lastnext)};
cc02ea56
JC
841 print # $walkHandle
842 fmt_line($h, $op, $style{"terse"}[1], $level+1);
31b49ad4
SM
843 }
844 $lastnext = $op->next;
cc02ea56
JC
845 print # $walkHandle
846 concise_op($op, $level, $style{"terse"}[0]);
31b49ad4
SM
847}
848
c99ca59a
SM
849sub 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 {
f95e3c3c 872 $lines[$i] = $kid . $lines[$i];
c99ca59a
SM
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
213a1a26
SM
883# *** Warning: fragile kludge ahead ***
884# Because the B::* modules run in the same interpreter as the code
2814eb74
PJ
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
213a1a26 895# hardcoded a value, it would have to change every time B::Concise or
2814eb74
PJ
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.
7252851f
NC
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
213a1a26
SM
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
c27ea44e
SM
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.
e69a2255 918
c27ea44e 919# Why is this different for MacOS? Does it matter?
8ec8fbef 920my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
e69a2255 921$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
c99ca59a
SM
922
9231;
924
925__END__
926
927=head1 NAME
928
929B::Concise - Walk Perl syntax tree, printing concise info about ops
930
931=head1 SYNOPSIS
932
933 perl -MO=Concise[,OPTIONS] foo.pl
934
78ad9108
PJ
935 use B::Concise qw(set_style add_callback);
936
c99ca59a
SM
937=head1 DESCRIPTION
938
939This compiler backend prints the internal OPs of a Perl program's syntax
940tree in one of several space-efficient text formats suitable for debugging
941the inner workings of perl or other compiler backends. It can print OPs in
942the order they appear in the OP tree, in the order they will execute, or
943in a text approximation to their tree structure, and the format of the
3c4b39be 944information displayed is customizable. Its function is similar to that of
c99ca59a
SM
945perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
946sophisticated and flexible.
947
f8a679e6
RGS
948=head1 EXAMPLE
949
19e169bf
JC
950Here's an example of 2 outputs (aka 'renderings'), using the
951-exec and -basic (i.e. default) formatting conventions on the same code
952snippet.
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
964Each line corresponds to an opcode. The opcode marked with '*' is used
965in a few examples below.
966
967The 1st column is the op's sequence number, starting at 1, and is
968displayed in base 36 by default. This rendering is in -exec (i.e.
969execution) order.
970
971The symbol between angle brackets indicates the op's type, for
972example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
973used in threaded perls. (see L</"OP class abbreviations">).
974
975The opname, as in B<'add[t1]'>, which may be followed by op-specific
976information in parentheses or brackets (ex B<'[t1]'>).
977
978The op-flags (ex B<'sK/2'>) follow, and are described in (L</"OP flags
979abbreviations">).
f8a679e6
RGS
980
981 % perl -MO=Concise -e '$a = $b + 42'
8ec8fbef 982 8 <@> leave[1 ref] vKP/REFC ->(end)
f8a679e6
RGS
983 1 <0> enter ->2
984 2 <;> nextstate(main 1 -e:1) v ->3
985 7 <2> sassign vKS/2 ->8
19e169bf 986 * 5 <2> add[t1] sK/2 ->6
f8a679e6
RGS
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
19e169bf
JC
993The default rendering is top-down, so they're not in execution order.
994This form reflects the way the stack is used to parse and evaluate
995expressions; the add operates on the two terms below it in the tree.
f8a679e6 996
19e169bf
JC
997Nullops appear as C<ex-opname>, where I<opname> is an op that has been
998optimized away by perl. They're displayed with a sequence-number of
999'-', because they are not executed (they don't appear in previous
1000example), they're printed here because they reflect the parse.
f8a679e6 1001
19e169bf
JC
1002The arrow points to the sequence number of the next op; they're not
1003displayed in -exec mode, for obvious reasons.
f8a679e6 1004
19e169bf
JC
1005Note that because this rendering was done on a non-threaded perl, the
1006PADOPs in the previous examples are now SVOPs, and some (but not all)
1007of the square brackets have been replaced by round ones. This is a
1008subtle feature to provide some visual distinction between renderings
1009on threaded and un-threaded perls.
f8a679e6 1010
f8a679e6 1011
c99ca59a
SM
1012=head1 OPTIONS
1013
1014Arguments that don't start with a hyphen are taken to be the names of
8ec8fbef
SM
1015subroutines to print the OPs of; if no such functions are specified,
1016the main body of the program (outside any subroutines, and not
19e169bf 1017including use'd or require'd files) is rendered. Passing C<BEGIN>,
8ec8fbef
SM
1018C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
1019special blocks to be printed.
c99ca59a 1020
724aa791
JC
1021Options affect how things are rendered (ie printed). They're presented
1022here by their visual effect, 1st being strongest. They're grouped
1023according to how they interrelate; within each group the options are
1024mutually exclusive (unless otherwise stated).
1025
1026=head2 Options for Opcode Ordering
1027
1028These options control the 'vertical display' of opcodes. The display
1029'order' is also called 'mode' elsewhere in this document.
1030
c99ca59a
SM
1031=over 4
1032
1033=item B<-basic>
1034
1035Print OPs in the order they appear in the OP tree (a preorder
1036traversal, starting at the root). The indentation of each OP shows its
19e169bf
JC
1037level in the tree, and the '->' at the end of the line indicates the
1038next opcode in execution order. This mode is the default, so the flag
1039is included simply for completeness.
c99ca59a
SM
1040
1041=item B<-exec>
1042
1043Print OPs in the order they would normally execute (for the majority
1044of constructs this is a postorder traversal of the tree, ending at the
1045root). In most cases the OP that usually follows a given OP will
1046appear directly below it; alternate paths are shown by indentation. In
1047cases like loops when control jumps out of a linear path, a 'goto'
1048line is generated.
1049
1050=item B<-tree>
1051
1052Print OPs in a text approximation of a tree, with the root of the tree
1053at 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,
1055it isn't suitable for large programs (unless you have a very wide
1056terminal).
1057
724aa791
JC
1058=back
1059
1060=head2 Options for Line-Style
1061
1062These options select the line-style (or just style) used to render
1063each opcode, and dictates what info is actually printed into each line.
1064
1065=over 4
1066
1067=item B<-concise>
1068
1069Use the author's favorite set of formatting conventions. This is the
1070default, of course.
1071
1072=item B<-terse>
1073
1074Use formatting conventions that emulate the output of B<B::Terse>. The
1075basic mode is almost indistinguishable from the real B<B::Terse>, and the
1076exec mode looks very similar, but is in a more logical order and lacks
1077curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
1078is only vaguely reminiscent of B<B::Terse>.
1079
1080=item B<-linenoise>
1081
1082Use formatting conventions in which the name of each OP, rather than being
1083written out in full, is represented by a one- or two-character abbreviation.
1084This is mainly a joke.
1085
1086=item B<-debug>
1087
1088Use formatting conventions reminiscent of B<B::Debug>; these aren't
1089very concise at all.
1090
1091=item B<-env>
1092
1093Use formatting conventions read from the environment variables
1094C<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
c99ca59a
SM
1102=item B<-compact>
1103
1104Use a tree format in which the minimum amount of space is used for the
1105lines connecting nodes (one character in most cases). This squeezes out
1106a few precious columns of screen real estate.
1107
1108=item B<-loose>
1109
1110Use a tree format that uses longer edges to separate OP nodes. This format
1111tends to look better than the compact one, especially in ASCII, and is
1112the default.
1113
1114=item B<-vt>
1115
1116Use tree connecting characters drawn from the VT100 line-drawing set.
1117This looks better if your terminal supports it.
1118
1119=item B<-ascii>
1120
1121Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
1122look as clean as the VT100 characters, but they'll work with almost any
1123terminal (or the horizontal scrolling mode of less(1)) and are suitable
1124for text documentation or email. This is the default.
1125
724aa791 1126=back
c99ca59a 1127
724aa791
JC
1128These are pairwise exclusive, i.e. compact or loose, vt or ascii.
1129
1130=head2 Options controlling sequence numbering
1131
1132=over 4
c99ca59a
SM
1133
1134=item B<-base>I<n>
1135
1136Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
1137digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
1138for 37 will be 'A', and so on until 62. Values greater than 62 are not
1139currently supported. The default is 36.
1140
1141=item B<-bigendian>
1142
1143Print sequence numbers with the most significant digit first. This is the
1144usual convention for Arabic numerals, and the default.
1145
1146=item B<-littleendian>
1147
724aa791
JC
1148Print seqence numbers with the least significant digit first. This is
1149obviously mutually exclusive with bigendian.
c99ca59a 1150
724aa791 1151=back
c99ca59a 1152
724aa791 1153=head2 Other options
c99ca59a 1154
cc02ea56
JC
1155These are pairwise exclusive.
1156
724aa791 1157=over 4
c99ca59a 1158
724aa791 1159=item B<-main>
c99ca59a 1160
724aa791 1161Include the main program in the output, even if subroutines were also
cc02ea56
JC
1162specified. This rendering is normally suppressed when a subroutine
1163name or reference is given.
1164
1165=item B<-nomain>
1166
1167This 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
1169rendered, regardless of this flag.
1170
1171=item B<-nobanner>
1172
1173Renderings usually include a banner line identifying the function name
1174or stringified subref. This suppresses the printing of the banner.
1175
1176TBC: Remove the stringified coderef; while it provides a 'cookie' for
1177each function rendered, the cookies used should be 1,2,3.. not a
1178random hex-address. It also complicates string comparison of two
1179different trees.
c99ca59a 1180
724aa791 1181=item B<-banner>
c99ca59a 1182
cc02ea56
JC
1183restores default banner behavior.
1184
1185=item B<-banneris> => subref
1186
1187TBC: a hookpoint (and an option to set it) for a user-supplied
1188function to produce a banner appropriate for users needs. It's not
1189ideal, because the rendering-state variables, which are a natural
1190candidate for use in concise.t, are unavailable to the user.
c99ca59a 1191
724aa791 1192=back
c99ca59a 1193
724aa791 1194=head2 Option Stickiness
c99ca59a 1195
724aa791
JC
1196If you invoke Concise more than once in a program, you should know that
1197the options are 'sticky'. This means that the options you provide in
1198the first call will be remembered for the 2nd call, unless you
1199re-specify or change them.
c99ca59a 1200
cc02ea56
JC
1201=head1 ABBREVIATIONS
1202
1203The concise style uses symbols to convey maximum info with minimal
1204clutter (like hex addresses). With just a little practice, you can
1205start to see the flowers, not just the branches, in the trees.
1206
1207=head2 OP class abbreviations
1208
1209These symbols appear before the op-name, and indicate the
1210B:: 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
19e169bf
JC
1226OP flags are either public or private. The public flags alter the
1227behavior of each opcode in consistent ways, and are represented by 0
1228or more single characters.
cc02ea56
JC
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)
19e169bf 1233 Want is unknown
cc02ea56
JC
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
19e169bf
JC
1243Private 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
1248They're opcode specific, and occur less often than the public ones, so
1249they're represented by short mnemonics instead of single-chars; see
00baac8f 1250F<op.h> for gory details, or try this quick 2-liner:
19e169bf
JC
1251
1252 $> perl -MB::Concise -de 1
1253 DB<1> |x \%B::Concise::priv
1254
c99ca59a
SM
1255=head1 FORMATTING SPECIFICATIONS
1256
724aa791
JC
1257For each line-style ('concise', 'terse', 'linenoise', etc.) there are
12583 format-specs which control how OPs are rendered.
1259
1260The first is the 'default' format, which is used in both basic and exec
1261modes to print all opcodes. The 2nd, goto-format, is used in exec
1262mode when branches are encountered. They're not real opcodes, and are
1263inserted to look like a closing curly brace. The tree-format is tree
1264specific.
1265
cc02ea56
JC
1266When a line is rendered, the correct format-spec is copied and scanned
1267for the following items; data is substituted in, and other
1268manipulations like basic indenting are done, for each opcode rendered.
1269
1270There 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
1272of s///g steps.)
1273
1274=head2 Special Patterns
1275
1276These items are the primitives used to perform indenting, and to
1277select text from amongst alternatives.
c99ca59a
SM
1278
1279=over 4
1280
1281=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
1282
1283Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
1284
1285=item B<(*(>I<text>B<)*)>
1286
1287Generates one copy of I<text> for each indentation level.
1288
1289=item B<(*(>I<text1>B<;>I<text2>B<)*)>
1290
1291Generates one fewer copies of I<text1> than the indentation level, followed
1292by 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
1296If the value of I<var> is true (not empty or zero), generates the
1297value of I<var> surrounded by I<text1> and I<Text2>, otherwise
1298nothing.
1299
cc02ea56
JC
1300=item B<~>
1301
1302Any number of tildes and surrounding whitespace will be collapsed to
1303a single space.
1304
1305=back
1306
1307=head2 # Variables
1308
1309These #vars represent opcode properties that you may want as part of
1310your rendering. The '#' is intended as a private sigil; a #var's
1311value is interpolated into the style-line, much like "read $this".
1312
1313These vars take 3 forms:
1314
1315=over 4
1316
c99ca59a
SM
1317=item B<#>I<var>
1318
cc02ea56
JC
1319A property named 'var' is assumed to exist for the opcodes, and is
1320interpolated into the rendering.
c99ca59a
SM
1321
1322=item B<#>I<var>I<N>
1323
cc02ea56
JC
1324Generates the value of I<var>, left justified to fill I<N> spaces.
1325Note that this means while you can have properties 'foo' and 'foo2',
1326you cannot render 'foo2', but you could with 'foo2a'. You would be
1327wise not to rely on this behavior going forward ;-)
c99ca59a 1328
cc02ea56 1329=item B<#>I<Var>
c99ca59a 1330
cc02ea56
JC
1331This ucfirst form of #var generates a tag-value form of itself for
1332display; it converts '#Var' into a 'Var => #var' style, which is then
1333handled as described above. (Imp-note: #Vars cannot be used for
1334conditional-fills, because the => #var transform is done after the check
1335for #Var's value).
c99ca59a
SM
1336
1337=back
1338
cc02ea56
JC
1339The following variables are 'defined' by B::Concise; when they are
1340used in a style, their respective values are plugged into the
1341rendering of each opcode.
1342
1343Only some of these are used by the standard styles, the others are
1344provided for you to delve into optree mechanics, should you wish to
1345add a new style (see L</add_style> below) that uses them. You can
00baac8f 1346also add new ones using L</add_callback>.
c99ca59a
SM
1347
1348=over 4
1349
1350=item B<#addr>
1351
cc02ea56 1352The address of the OP, in hexadecimal.
c99ca59a
SM
1353
1354=item B<#arg>
1355
1356The OP-specific information of the OP (such as the SV for an SVOP, the
cc02ea56 1357non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
c99ca59a
SM
1358
1359=item B<#class>
1360
1361The B-determined class of the OP, in all caps.
1362
f8a679e6 1363=item B<#classsym>
c99ca59a
SM
1364
1365A single symbol abbreviating the class of the OP.
1366
c3caa09d
SM
1367=item B<#coplabel>
1368
1369The label of the statement or block the OP is the start of, if any.
1370
c99ca59a
SM
1371=item B<#exname>
1372
1373The 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
1377The target of the OP, or nothing for a nulled OP.
1378
1379=item B<#firstaddr>
1380
19e169bf 1381The address of the OP's first child, in hexadecimal.
c99ca59a
SM
1382
1383=item B<#flags>
1384
1385The OP's flags, abbreviated as a series of symbols.
1386
1387=item B<#flagval>
1388
1389The numeric value of the OP's flags.
1390
f8a679e6 1391=item B<#hyphseq>
c99ca59a
SM
1392
1393The 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
1398mode, or empty otherwise.
1399
1400=item B<#lastaddr>
1401
19e169bf 1402The address of the OP's last child, in hexadecimal.
c99ca59a
SM
1403
1404=item B<#name>
1405
1406The OP's name.
1407
1408=item B<#NAME>
1409
1410The OP's name, in all caps.
1411
1412=item B<#next>
1413
1414The sequence number of the OP's next OP.
1415
1416=item B<#nextaddr>
1417
19e169bf 1418The address of the OP's next OP, in hexadecimal.
c99ca59a
SM
1419
1420=item B<#noise>
1421
c27ea44e 1422A one- or two-character abbreviation for the OP's name.
c99ca59a
SM
1423
1424=item B<#private>
1425
1426The OP's private flags, rendered with abbreviated names if possible.
1427
1428=item B<#privval>
1429
1430The numeric value of the OP's private flags.
1431
1432=item B<#seq>
1433
2814eb74
PJ
1434The sequence number of the OP. Note that this is a sequence number
1435generated by B::Concise.
c99ca59a 1436
7252851f
NC
1437=item B<#seqnum>
1438
14395.8.x and earlier only. 5.9 and later do not provide this.
1440
1441The real sequence number of the OP, as a regular number and not adjusted
1442to be relative to the start of the real program. (This will generally be
1443a fairly large number because all of B<B::Concise> is compiled before
1444your program is).
1445
2814eb74 1446=item B<#opt>
c99ca59a 1447
2814eb74
PJ
1448Whether or not the op has been optimised by the peephole optimiser.
1449
7252851f
NC
1450Only available in 5.9 and later.
1451
2814eb74
PJ
1452=item B<#static>
1453
1454Whether or not the op is statically defined. This flag is used by the
1455B::C compiler backend and indicates that the op should not be freed.
c99ca59a 1456
7252851f
NC
1457Only available in 5.9 and later.
1458
c99ca59a
SM
1459=item B<#sibaddr>
1460
19e169bf 1461The address of the OP's next youngest sibling, in hexadecimal.
c99ca59a
SM
1462
1463=item B<#svaddr>
1464
19e169bf 1465The address of the OP's SV, if it has an SV, in hexadecimal.
c99ca59a
SM
1466
1467=item B<#svclass>
1468
1469The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
1470
1471=item B<#svval>
1472
1473The value of the OP's SV, if it has one, in a short human-readable format.
1474
1475=item B<#targ>
1476
1477The numeric value of the OP's targ.
1478
1479=item B<#targarg>
1480
1481The name of the variable the OP's targ refers to, if any, otherwise the
1482letter t followed by the OP's targ in decimal.
1483
1484=item B<#targarglife>
1485
1486Same as B<#targarg>, but followed by the COP sequence numbers that delimit
1487the variable's lifetime (or 'end' for a variable in an open scope) for a
1488variable.
1489
1490=item B<#typenum>
1491
1492The numeric value of the OP's type, in decimal.
1493
1494=back
1495
78ad9108
PJ
1496=head1 Using B::Concise outside of the O framework
1497
cc02ea56
JC
1498The common (and original) usage of B::Concise was for command-line
1499renderings of simple code, as given in EXAMPLE. But you can also use
1500B<B::Concise> from your code, and call compile() directly, and
724aa791 1501repeatedly. By doing so, you can avoid the compile-time only
cc02ea56
JC
1502operation of O.pm, and even use the debugger to step through
1503B::Concise::compile() itself.
f95e3c3c 1504
cc02ea56
JC
1505Once you're doing this, you may alter Concise output by adding new
1506rendering styles, and by optionally adding callback routines which
1507populate new variables, if such were referenced from those (just
1508added) styles.
f95e3c3c 1509
724aa791 1510=head2 Example: Altering Concise Renderings
78ad9108
PJ
1511
1512 use B::Concise qw(set_style add_callback);
cc02ea56 1513 add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
78ad9108 1514 add_callback
f95e3c3c
JC
1515 ( sub {
1516 my ($h, $op, $format, $level, $stylename) = @_;
78ad9108 1517 $h->{variable} = some_func($op);
cc02ea56
JC
1518 });
1519 $walker = B::Concise::compile(@options,@subnames,@subrefs);
1520 $walker->();
78ad9108 1521
f95e3c3c
JC
1522=head2 set_style()
1523
724aa791
JC
1524B<set_style> accepts 3 arguments, and updates the three format-specs
1525comprising a line-style (basic-exec, goto, tree). It has one minor
1526drawback though; it doesn't register the style under a new name. This
1527can become an issue if you render more than once and switch styles.
1528Thus you may prefer to use add_style() and/or set_style_standard()
1529instead.
1530
1531=head2 set_style_standard($name)
1532
1533This restores one of the standard line-styles: C<terse>, C<concise>,
1534C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
1535names previously defined with add_style().
f95e3c3c
JC
1536
1537=head2 add_style()
78ad9108 1538
f95e3c3c
JC
1539This subroutine accepts a new style name and three style arguments as
1540above, and creates, registers, and selects the newly named style. It is
1541an error to re-add a style; call set_style_standard() to switch between
1542several styles.
1543
f95e3c3c
JC
1544=head2 add_callback()
1545
19e169bf
JC
1546If your newly minted styles refer to any new #variables, you'll need
1547to define a callback subroutine that will populate (or modify) those
1548variables. They are then available for use in the style you've
1549chosen.
f95e3c3c
JC
1550
1551The callbacks are called for each opcode visited by Concise, in the
1552same order as they are added. Each subroutine is passed five
1553parameters.
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
78ad9108
PJ
1561
1562To define your own variables, simply add them to the hash, or change
1563existing values if you need to. The level and format are passed in as
1564references to scalars, but it is unlikely that they will need to be
1565changed or even used.
1566
724aa791 1567=head2 Running B::Concise::compile()
f95e3c3c
JC
1568
1569B<compile> accepts options as described above in L</OPTIONS>, and
1570arguments, which are either coderefs, or subroutine names.
1571
cc02ea56
JC
1572It constructs and returns a $treewalker coderef, which when invoked,
1573traverses, or walks, and renders the optrees of the given arguments to
1574STDOUT. You can reuse this, and can change the rendering style used
1575each time; thereafter the coderef renders in the new style.
f95e3c3c
JC
1576
1577B<walk_output> lets you change the print destination from STDOUT to
19e169bf
JC
1578another open filehandle, or into a string passed as a ref (unless
1579you've built perl with -Uuseperlio).
f95e3c3c 1580
cc02ea56 1581 my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
f95e3c3c 1582 walk_output(\my $buf);
cc02ea56
JC
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
1589When $walker is called, it traverses the subroutines supplied when it
1590was created, and renders them using the current style. You can change
1591the 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
1597Passing new options to the $walker is the easiest way to change
1598amongst any pre-defined styles (the ones you add are automatically
1599recognized as options), and is the only way to alter rendering order
1600without calling compile again. Note however that rendering state is
1601still shared amongst multiple $walker objects, so they must still be
1602used in a coordinated manner.
f95e3c3c
JC
1603
1604=head2 B::Concise::reset_sequence()
1605
1606This function (not exported) lets you reset the sequence numbers (note
1607that they're numbered arbitrarily, their goal being to be human
1608readable). Its purpose is mostly to support testing, i.e. to compare
1609the concise output from two identical anonymous subroutines (but
1610different instances). Without the reset, B::Concise, seeing that
1611they're separate optrees, generates different sequence numbers in
1612the output.
1613
1614=head2 Errors
1615
9a3b3024
JC
1616Errors in rendering (non-existent function-name, non-existent coderef)
1617are written to the STDOUT, or wherever you've set it via
1618walk_output().
31b49ad4 1619
9a3b3024
JC
1620Errors using the various *style* calls, and bad args to walk_output(),
1621result in die(). Use an eval if you wish to catch these errors and
1622continue processing.
78ad9108 1623
c99ca59a
SM
1624=head1 AUTHOR
1625
31b49ad4 1626Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
c99ca59a
SM
1627
1628=cut