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