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