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