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