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