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