Commit | Line | Data |
c99ca59a |
1 | package B::Concise; |
2 | # Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved. |
3 | # This program is free software; you can redistribute and/or modify it |
4 | # under the same terms as Perl itself. |
5 | |
c3caa09d |
6 | our $VERSION = "0.51"; |
c99ca59a |
7 | use strict; |
8 | use B qw(class ppname main_start main_root main_cv cstring svref_2object |
9 | SVf_IOK SVf_NOK SVf_POK OPf_KIDS); |
10 | |
11 | my %style = |
12 | ("terse" => |
c3caa09d |
13 | ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " |
14 | . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", |
c99ca59a |
15 | "(*( )*)goto #class (#addr)\n", |
16 | "#class pp_#name"], |
17 | "concise" => |
18 | ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " |
19 | . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", |
20 | " (*( )*) goto #seq\n", |
21 | "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], |
22 | "linenoise" => |
23 | ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", |
24 | "gt_#seq ", |
25 | "(?(#seq)?)#noise#arg(?([#targarg])?)"], |
26 | "debug" => |
27 | ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" |
28 | . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" |
29 | . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" |
30 | . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" |
31 | . "(?(\top_sv\t\t#svaddr\n)?)", |
32 | " GOTO #addr\n", |
33 | "#addr"], |
34 | "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, |
35 | $ENV{B_CONCISE_TREE_FORMAT}], |
36 | ); |
37 | |
38 | my($format, $gotofmt, $treefmt); |
39 | my $curcv; |
40 | my($seq_base, $cop_seq_base); |
41 | |
42 | sub concise_cv { |
43 | my ($order, $cvref) = @_; |
44 | my $cv = svref_2object($cvref); |
45 | $curcv = $cv; |
46 | if ($order eq "exec") { |
47 | walk_exec($cv->START); |
48 | } elsif ($order eq "basic") { |
49 | walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); |
50 | } else { |
51 | print tree($cv->ROOT, 0) |
52 | } |
53 | } |
54 | |
55 | my $start_sym = "\e(0"; # "\cN" sometimes also works |
56 | my $end_sym = "\e(B"; # "\cO" respectively |
57 | |
58 | my @tree_decorations = |
59 | ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], |
60 | [" ", "-", "+", "+", "|", "`", "", 0], |
61 | [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], |
62 | [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], |
63 | ); |
64 | my $tree_style = 0; |
65 | |
66 | my $base = 36; |
67 | my $big_endian = 1; |
68 | |
69 | my $order = "basic"; |
70 | |
71 | sub compile { |
72 | my @options = grep(/^-/, @_); |
73 | my @args = grep(!/^-/, @_); |
74 | my $do_main = 0; |
75 | ($format, $gotofmt, $treefmt) = @{$style{"concise"}}; |
76 | for my $o (@options) { |
77 | if ($o eq "-basic") { |
78 | $order = "basic"; |
79 | } elsif ($o eq "-exec") { |
80 | $order = "exec"; |
81 | } elsif ($o eq "-tree") { |
82 | $order = "tree"; |
83 | } elsif ($o eq "-compact") { |
84 | $tree_style |= 1; |
85 | } elsif ($o eq "-loose") { |
86 | $tree_style &= ~1; |
87 | } elsif ($o eq "-vt") { |
88 | $tree_style |= 2; |
89 | } elsif ($o eq "-ascii") { |
90 | $tree_style &= ~2; |
91 | } elsif ($o eq "-main") { |
92 | $do_main = 1; |
93 | } elsif ($o =~ /^-base(\d+)$/) { |
94 | $base = $1; |
95 | } elsif ($o eq "-bigendian") { |
96 | $big_endian = 1; |
97 | } elsif ($o eq "-littleendian") { |
98 | $big_endian = 0; |
99 | } elsif (exists $style{substr($o, 1)}) { |
100 | ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}}; |
101 | } else { |
102 | warn "Option $o unrecognized"; |
103 | } |
104 | } |
105 | if (@args) { |
106 | return sub { |
107 | for my $objname (@args) { |
108 | $objname = "main::" . $objname unless $objname =~ /::/; |
109 | eval "concise_cv(\$order, \\&$objname)"; |
110 | die "concise_cv($order, \\&$objname) failed: $@" if $@; |
111 | } |
112 | } |
113 | } |
114 | if (!@args or $do_main) { |
115 | if ($order eq "exec") { |
116 | return sub { return if class(main_start) eq "NULL"; |
117 | $curcv = main_cv; |
118 | walk_exec(main_start) } |
119 | } elsif ($order eq "tree") { |
120 | return sub { return if class(main_root) eq "NULL"; |
121 | $curcv = main_cv; |
122 | print tree(main_root, 0) } |
123 | } elsif ($order eq "basic") { |
124 | return sub { return if class(main_root) eq "NULL"; |
125 | $curcv = main_cv; |
126 | walk_topdown(main_root, |
127 | sub { $_[0]->concise($_[1]) }, 0); } |
128 | } |
129 | } |
130 | } |
131 | |
132 | my %labels; |
133 | my $lastnext; |
134 | |
135 | my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", |
136 | 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", |
137 | 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";"); |
138 | |
34a48b4b |
139 | my @linenoise = ('#', |
140 | qw'() sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl |
c99ca59a |
141 | ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I |
142 | -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< |
143 | > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i |
144 | ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy |
145 | uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ |
146 | a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} |
147 | v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o |
148 | ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v |
149 | ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r |
150 | -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd |
151 | co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 |
152 | g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e |
153 | e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn |
34a48b4b |
154 | Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>'); |
c99ca59a |
155 | |
156 | my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; |
157 | |
158 | sub op_flags { |
159 | my($x) = @_; |
160 | my(@v); |
161 | push @v, "v" if ($x & 3) == 1; |
162 | push @v, "s" if ($x & 3) == 2; |
163 | push @v, "l" if ($x & 3) == 3; |
164 | push @v, "K" if $x & 4; |
165 | push @v, "P" if $x & 8; |
166 | push @v, "R" if $x & 16; |
167 | push @v, "M" if $x & 32; |
168 | push @v, "S" if $x & 64; |
169 | push @v, "*" if $x & 128; |
170 | return join("", @v); |
171 | } |
172 | |
173 | sub base_n { |
174 | my $x = shift; |
175 | return "-" . base_n(-$x) if $x < 0; |
176 | my $str = ""; |
177 | do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); |
178 | $str = reverse $str if $big_endian; |
179 | return $str; |
180 | } |
181 | |
182 | sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" } |
183 | |
184 | sub walk_topdown { |
185 | my($op, $sub, $level) = @_; |
186 | $sub->($op, $level); |
187 | if ($op->flags & OPf_KIDS) { |
188 | for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { |
189 | walk_topdown($kid, $sub, $level + 1); |
190 | } |
191 | } |
b2a3cfdd |
192 | if (class($op) eq "PMOP" and $ {$op->pmreplroot} |
193 | and $op->pmreplroot->isa("B::OP")) { |
c99ca59a |
194 | walk_topdown($op->pmreplroot, $sub, $level + 1); |
195 | } |
196 | } |
197 | |
198 | sub walklines { |
199 | my($ar, $level) = @_; |
200 | for my $l (@$ar) { |
201 | if (ref($l) eq "ARRAY") { |
202 | walklines($l, $level + 1); |
203 | } else { |
204 | $l->concise($level); |
205 | } |
206 | } |
207 | } |
208 | |
209 | sub walk_exec { |
210 | my($top, $level) = @_; |
211 | my %opsseen; |
212 | my @lines; |
213 | my @todo = ([$top, \@lines]); |
214 | while (@todo and my($op, $targ) = @{shift @todo}) { |
215 | for (; $$op; $op = $op->next) { |
216 | last if $opsseen{$$op}++; |
217 | push @$targ, $op; |
218 | my $name = $op->name; |
219 | if ($name |
220 | =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) { |
221 | my $ar = []; |
222 | push @$targ, $ar; |
223 | push @todo, [$op->other, $ar]; |
224 | } elsif ($name eq "subst" and $ {$op->pmreplstart}) { |
225 | my $ar = []; |
226 | push @$targ, $ar; |
227 | push @todo, [$op->pmreplstart, $ar]; |
228 | } elsif ($name =~ /^enter(loop|iter)$/) { |
229 | $labels{$op->nextop->seq} = "NEXT"; |
230 | $labels{$op->lastop->seq} = "LAST"; |
231 | $labels{$op->redoop->seq} = "REDO"; |
232 | } |
233 | } |
234 | } |
235 | walklines(\@lines, 0); |
236 | } |
237 | |
238 | sub fmt_line { |
239 | my($hr, $fmt, $level) = @_; |
240 | my $text = $fmt; |
241 | $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ |
242 | $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; |
243 | $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; |
244 | $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; |
245 | $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; |
246 | $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; |
247 | $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg; |
248 | $text =~ s/[ \t]*~+[ \t]*/ /g; |
249 | return $text; |
250 | } |
251 | |
252 | my %priv; |
253 | $priv{$_}{128} = "LVINTRO" |
254 | for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", |
255 | "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", |
256 | "padav", "padhv"); |
257 | $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); |
258 | $priv{"aassign"}{64} = "COMMON"; |
259 | $priv{"aassign"}{32} = "PHASH"; |
260 | $priv{"sassign"}{64} = "BKWARD"; |
261 | $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont"); |
262 | @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL", |
263 | "COMPL", "GROWS"); |
264 | $priv{"repeat"}{64} = "DOLIST"; |
265 | $priv{"leaveloop"}{64} = "CONT"; |
266 | @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") |
267 | for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem"); |
268 | $priv{"entersub"}{16} = "DBG"; |
269 | $priv{"entersub"}{32} = "TARG"; |
270 | @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); |
271 | $priv{"gv"}{32} = "EARLYCV"; |
272 | $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; |
273 | $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv"); |
274 | $priv{$_}{16} = "TARGMY" |
275 | for (map(($_,"s$_"),"chop", "chomp"), |
276 | map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", |
277 | "add", "subtract", "negate"), "pow", "concat", "stringify", |
278 | "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", |
279 | "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", |
280 | "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", |
281 | "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", |
282 | "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", |
283 | "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", |
284 | "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", |
285 | "setpriority", "time", "sleep"); |
7a9b44b9 |
286 | @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN"); |
c99ca59a |
287 | $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; |
288 | $priv{"list"}{64} = "GUESSED"; |
289 | $priv{"delete"}{64} = "SLICE"; |
290 | $priv{"exists"}{64} = "SUB"; |
291 | $priv{$_}{64} = "LOCALE" |
292 | for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", |
293 | "scmp", "lc", "uc", "lcfirst", "ucfirst"); |
294 | @{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV"); |
295 | $priv{"threadsv"}{64} = "SVREFd"; |
296 | $priv{$_}{16} = "INBIN" for ("open", "backtick"); |
297 | $priv{$_}{32} = "INCR" for ("open", "backtick"); |
298 | $priv{$_}{64} = "OUTBIN" for ("open", "backtick"); |
299 | $priv{$_}{128} = "OUTCR" for ("open", "backtick"); |
300 | $priv{"exit"}{128} = "VMS"; |
301 | |
302 | sub private_flags { |
303 | my($name, $x) = @_; |
304 | my @s; |
305 | for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { |
306 | if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { |
307 | $x -= $flag; |
308 | push @s, $priv{$name}{$flag}; |
309 | } |
310 | } |
311 | push @s, $x if $x; |
312 | return join(",", @s); |
313 | } |
314 | |
315 | sub concise_op { |
316 | my ($op, $level, $format) = @_; |
317 | my %h; |
318 | $h{exname} = $h{name} = $op->name; |
319 | $h{NAME} = uc $h{name}; |
320 | $h{class} = class($op); |
321 | $h{extarg} = $h{targ} = $op->targ; |
322 | $h{extarg} = "" unless $h{extarg}; |
323 | if ($h{name} eq "null" and $h{targ}) { |
324 | $h{exname} = "ex-" . substr(ppname($h{targ}), 3); |
325 | $h{extarg} = ""; |
326 | } elsif ($h{targ}) { |
327 | my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; |
328 | if (defined $padname and class($padname) ne "SPECIAL") { |
0b40bd6d |
329 | $h{targarg} = $padname->PVX; |
c99ca59a |
330 | my $intro = $padname->NVX - $cop_seq_base; |
331 | my $finish = int($padname->IVX) - $cop_seq_base; |
332 | $finish = "end" if $finish == 999999999 - $cop_seq_base; |
333 | $h{targarglife} = "$h{targarg}:$intro,$finish"; |
334 | } else { |
335 | $h{targarglife} = $h{targarg} = "t" . $h{targ}; |
336 | } |
337 | } |
338 | $h{arg} = ""; |
339 | $h{svclass} = $h{svaddr} = $h{svval} = ""; |
340 | if ($h{class} eq "PMOP") { |
341 | my $precomp = $op->precomp; |
7a9b44b9 |
342 | if (defined $precomp) { |
343 | # Escape literal control sequences |
344 | for ($precomp) { |
345 | s/\t/\\t/g; s/\n/\\n/g; s/\r/\\r/g; |
346 | # How can we do the below portably? |
347 | #s/([\0-\037\177-\377])/"\\".sprintf("%03o", ord($1))/eg; |
348 | } |
349 | $precomp = "/$precomp/"; |
350 | } |
351 | else { $precomp = ""; } |
b2a3cfdd |
352 | my $pmreplroot = $op->pmreplroot; |
34a48b4b |
353 | my $pmreplstart; |
354 | if ($$pmreplroot && $pmreplroot->isa("B::GV")) { |
b2a3cfdd |
355 | # with C<@stash_array = split(/pat/, str);>, |
356 | # *stash_array is stored in pmreplroot. |
357 | $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")"; |
358 | } elsif ($ {$op->pmreplstart}) { |
c99ca59a |
359 | undef $lastnext; |
360 | $pmreplstart = "replstart->" . seq($op->pmreplstart); |
361 | $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; |
362 | } else { |
363 | $h{arg} = "($precomp)"; |
364 | } |
365 | } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { |
366 | $h{arg} = '("' . $op->pv . '")'; |
367 | $h{svval} = '"' . $op->pv . '"'; |
368 | } elsif ($h{class} eq "COP") { |
369 | my $label = $op->label; |
c3caa09d |
370 | $h{coplabel} = $label; |
c99ca59a |
371 | $label = $label ? "$label: " : ""; |
372 | my $loc = $op->file; |
373 | $loc =~ s[.*/][]; |
374 | $loc .= ":" . $op->line; |
375 | my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); |
376 | my $arybase = $op->arybase; |
377 | $arybase = $arybase ? ' $[=' . $arybase : ""; |
378 | $h{arg} = "($label$stash $cseq $loc$arybase)"; |
379 | } elsif ($h{class} eq "LOOP") { |
380 | $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) |
381 | . " redo->" . seq($op->redoop) . ")"; |
382 | } elsif ($h{class} eq "LOGOP") { |
383 | undef $lastnext; |
384 | $h{arg} = "(other->" . seq($op->other) . ")"; |
385 | } elsif ($h{class} eq "SVOP") { |
386 | my $sv = $op->sv; |
387 | $h{svclass} = class($sv); |
388 | $h{svaddr} = sprintf("%#x", $$sv); |
389 | if ($h{svclass} eq "GV") { |
390 | my $gv = $sv; |
391 | my $stash = $gv->STASH->NAME; |
392 | if ($stash eq "main") { |
393 | $stash = ""; |
394 | } else { |
395 | $stash = $stash . "::"; |
396 | } |
002b978b |
397 | $h{arg} = "(*$stash" . $gv->SAFENAME . ")"; |
398 | $h{svval} = "*$stash" . $gv->SAFENAME; |
c99ca59a |
399 | } else { |
400 | while (class($sv) eq "RV") { |
401 | $h{svval} .= "\\"; |
402 | $sv = $sv->RV; |
403 | } |
404 | if (class($sv) eq "SPECIAL") { |
405 | $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; |
406 | } elsif ($sv->FLAGS & SVf_NOK) { |
407 | $h{svval} = $sv->NV; |
408 | } elsif ($sv->FLAGS & SVf_IOK) { |
409 | $h{svval} = $sv->IV; |
410 | } elsif ($sv->FLAGS & SVf_POK) { |
411 | $h{svval} = cstring($sv->PV); |
412 | } |
413 | $h{arg} = "($h{svclass} $h{svval})"; |
414 | } |
415 | } |
416 | $h{seq} = $h{hyphseq} = seq($op); |
417 | $h{seq} = "" if $h{seq} eq "-"; |
418 | $h{seqnum} = $op->seq; |
419 | $h{next} = $op->next; |
420 | $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); |
421 | $h{nextaddr} = sprintf("%#x", $ {$op->next}); |
422 | $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); |
423 | $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); |
424 | $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); |
425 | |
426 | $h{classsym} = $opclass{$h{class}}; |
427 | $h{flagval} = $op->flags; |
428 | $h{flags} = op_flags($op->flags); |
429 | $h{privval} = $op->private; |
430 | $h{private} = private_flags($h{name}, $op->private); |
431 | $h{addr} = sprintf("%#x", $$op); |
432 | $h{label} = $labels{$op->seq}; |
433 | $h{typenum} = $op->type; |
434 | $h{noise} = $linenoise[$op->type]; |
435 | return fmt_line(\%h, $format, $level); |
436 | } |
437 | |
438 | sub B::OP::concise { |
439 | my($op, $level) = @_; |
440 | if ($order eq "exec" and $lastnext and $$lastnext != $$op) { |
441 | my $h = {"seq" => seq($lastnext), "class" => class($lastnext), |
442 | "addr" => sprintf("%#x", $$lastnext)}; |
443 | print fmt_line($h, $gotofmt, $level+1); |
444 | } |
445 | $lastnext = $op->next; |
446 | print concise_op($op, $level, $format); |
447 | } |
448 | |
449 | sub tree { |
450 | my $op = shift; |
451 | my $level = shift; |
452 | my $style = $tree_decorations[$tree_style]; |
453 | my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; |
454 | my $name = concise_op($op, $level, $treefmt); |
455 | if (not $op->flags & OPf_KIDS) { |
456 | return $name . "\n"; |
457 | } |
458 | my @lines; |
459 | for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { |
460 | push @lines, tree($kid, $level+1); |
461 | } |
462 | my $i; |
463 | for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { |
464 | $lines[$i] = $space . $lines[$i]; |
465 | } |
466 | if ($i > 0) { |
467 | $lines[$i] = $last . $lines[$i]; |
468 | while ($i-- > 1) { |
469 | if (substr($lines[$i], 0, 1) eq " ") { |
470 | $lines[$i] = $nokid . $lines[$i]; |
471 | } else { |
472 | $lines[$i] = $kid . $lines[$i]; |
473 | } |
474 | } |
475 | $lines[$i] = $kids . $lines[$i]; |
476 | } else { |
477 | $lines[0] = $single . $lines[0]; |
478 | } |
479 | return("$name$lead" . shift @lines, |
480 | map(" " x (length($name)+$size) . $_, @lines)); |
481 | } |
482 | |
483 | # This is a bit of a hack; the 2 and 15 were determined empirically. |
484 | # These need to stay the last things in the module. |
485 | $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2; |
486 | $seq_base = svref_2object(eval 'sub{}')->START->seq + 15; |
487 | |
488 | 1; |
489 | |
490 | __END__ |
491 | |
492 | =head1 NAME |
493 | |
494 | B::Concise - Walk Perl syntax tree, printing concise info about ops |
495 | |
496 | =head1 SYNOPSIS |
497 | |
498 | perl -MO=Concise[,OPTIONS] foo.pl |
499 | |
500 | =head1 DESCRIPTION |
501 | |
502 | This compiler backend prints the internal OPs of a Perl program's syntax |
503 | tree in one of several space-efficient text formats suitable for debugging |
504 | the inner workings of perl or other compiler backends. It can print OPs in |
505 | the order they appear in the OP tree, in the order they will execute, or |
506 | in a text approximation to their tree structure, and the format of the |
507 | information displyed is customizable. Its function is similar to that of |
508 | perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more |
509 | sophisticated and flexible. |
510 | |
511 | =head1 OPTIONS |
512 | |
513 | Arguments that don't start with a hyphen are taken to be the names of |
514 | subroutines to print the OPs of; if no such functions are specified, the |
515 | main body of the program (outside any subroutines, and not including use'd |
516 | or require'd files) is printed. |
517 | |
518 | =over 4 |
519 | |
520 | =item B<-basic> |
521 | |
522 | Print OPs in the order they appear in the OP tree (a preorder |
523 | traversal, starting at the root). The indentation of each OP shows its |
524 | level in the tree. This mode is the default, so the flag is included |
525 | simply for completeness. |
526 | |
527 | =item B<-exec> |
528 | |
529 | Print OPs in the order they would normally execute (for the majority |
530 | of constructs this is a postorder traversal of the tree, ending at the |
531 | root). In most cases the OP that usually follows a given OP will |
532 | appear directly below it; alternate paths are shown by indentation. In |
533 | cases like loops when control jumps out of a linear path, a 'goto' |
534 | line is generated. |
535 | |
536 | =item B<-tree> |
537 | |
538 | Print OPs in a text approximation of a tree, with the root of the tree |
539 | at the left and 'left-to-right' order of children transformed into |
540 | 'top-to-bottom'. Because this mode grows both to the right and down, |
541 | it isn't suitable for large programs (unless you have a very wide |
542 | terminal). |
543 | |
544 | =item B<-compact> |
545 | |
546 | Use a tree format in which the minimum amount of space is used for the |
547 | lines connecting nodes (one character in most cases). This squeezes out |
548 | a few precious columns of screen real estate. |
549 | |
550 | =item B<-loose> |
551 | |
552 | Use a tree format that uses longer edges to separate OP nodes. This format |
553 | tends to look better than the compact one, especially in ASCII, and is |
554 | the default. |
555 | |
556 | =item B<-vt> |
557 | |
558 | Use tree connecting characters drawn from the VT100 line-drawing set. |
559 | This looks better if your terminal supports it. |
560 | |
561 | =item B<-ascii> |
562 | |
563 | Draw the tree with standard ASCII characters like C<+> and C<|>. These don't |
564 | look as clean as the VT100 characters, but they'll work with almost any |
565 | terminal (or the horizontal scrolling mode of less(1)) and are suitable |
566 | for text documentation or email. This is the default. |
567 | |
568 | =item B<-main> |
569 | |
570 | Include the main program in the output, even if subroutines were also |
571 | specified. |
572 | |
573 | =item B<-base>I<n> |
574 | |
575 | Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the |
576 | digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit |
577 | for 37 will be 'A', and so on until 62. Values greater than 62 are not |
578 | currently supported. The default is 36. |
579 | |
580 | =item B<-bigendian> |
581 | |
582 | Print sequence numbers with the most significant digit first. This is the |
583 | usual convention for Arabic numerals, and the default. |
584 | |
585 | =item B<-littleendian> |
586 | |
587 | Print seqence numbers with the least significant digit first. |
588 | |
589 | =item B<-concise> |
590 | |
591 | Use the author's favorite set of formatting conventions. This is the |
592 | default, of course. |
593 | |
594 | =item B<-terse> |
595 | |
596 | Use formatting conventions that emulate the ouput of B<B::Terse>. The |
597 | basic mode is almost indistinguishable from the real B<B::Terse>, and the |
598 | exec mode looks very similar, but is in a more logical order and lacks |
599 | curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode |
600 | is only vaguely reminiscient of B<B::Terse>. |
601 | |
602 | =item B<-linenoise> |
603 | |
604 | Use formatting conventions in which the name of each OP, rather than being |
605 | written out in full, is represented by a one- or two-character abbreviation. |
606 | This is mainly a joke. |
607 | |
608 | =item B<-debug> |
609 | |
610 | Use formatting conventions reminiscient of B<B::Debug>; these aren't |
611 | very concise at all. |
612 | |
613 | =item B<-env> |
614 | |
615 | Use formatting conventions read from the environment variables |
616 | C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>. |
617 | |
618 | =back |
619 | |
620 | =head1 FORMATTING SPECIFICATIONS |
621 | |
622 | For each general style ('concise', 'terse', 'linenoise', etc.) there are |
623 | three specifications: one of how OPs should appear in the basic or exec |
624 | modes, one of how 'goto' lines should appear (these occur in the exec |
625 | mode only), and one of how nodes should appear in tree mode. Each has the |
626 | same format, described below. Any text that doesn't match a special |
627 | pattern is copied verbatim. |
628 | |
629 | =over 4 |
630 | |
631 | =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)> |
632 | |
633 | Generates I<exec_text> in exec mode, or I<basic_text> in basic mode. |
634 | |
635 | =item B<(*(>I<text>B<)*)> |
636 | |
637 | Generates one copy of I<text> for each indentation level. |
638 | |
639 | =item B<(*(>I<text1>B<;>I<text2>B<)*)> |
640 | |
641 | Generates one fewer copies of I<text1> than the indentation level, followed |
642 | by one copy of I<text2> if the indentation level is more than 0. |
643 | |
644 | =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)> |
645 | |
646 | If the value of I<var> is true (not empty or zero), generates the |
647 | value of I<var> surrounded by I<text1> and I<Text2>, otherwise |
648 | nothing. |
649 | |
650 | =item B<#>I<var> |
651 | |
652 | Generates the value of the variable I<var>. |
653 | |
654 | =item B<#>I<var>I<N> |
655 | |
656 | Generates the value of I<var>, left jutified to fill I<N> spaces. |
657 | |
658 | =item B<~> |
659 | |
660 | Any number of tildes and surrounding whitespace will be collapsed to |
661 | a single space. |
662 | |
663 | =back |
664 | |
665 | The following variables are recognized: |
666 | |
667 | =over 4 |
668 | |
669 | =item B<#addr> |
670 | |
671 | The address of the OP, in hexidecimal. |
672 | |
673 | =item B<#arg> |
674 | |
675 | The OP-specific information of the OP (such as the SV for an SVOP, the |
676 | non-local exit pointers for a LOOP, etc.) enclosed in paretheses. |
677 | |
678 | =item B<#class> |
679 | |
680 | The B-determined class of the OP, in all caps. |
681 | |
682 | =item B<#classym> |
683 | |
684 | A single symbol abbreviating the class of the OP. |
685 | |
c3caa09d |
686 | =item B<#coplabel> |
687 | |
688 | The label of the statement or block the OP is the start of, if any. |
689 | |
c99ca59a |
690 | =item B<#exname> |
691 | |
692 | The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. |
693 | |
694 | =item B<#extarg> |
695 | |
696 | The target of the OP, or nothing for a nulled OP. |
697 | |
698 | =item B<#firstaddr> |
699 | |
700 | The address of the OP's first child, in hexidecimal. |
701 | |
702 | =item B<#flags> |
703 | |
704 | The OP's flags, abbreviated as a series of symbols. |
705 | |
706 | =item B<#flagval> |
707 | |
708 | The numeric value of the OP's flags. |
709 | |
710 | =item B<#hyphenseq> |
711 | |
712 | The sequence number of the OP, or a hyphen if it doesn't have one. |
713 | |
714 | =item B<#label> |
715 | |
716 | 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec |
717 | mode, or empty otherwise. |
718 | |
719 | =item B<#lastaddr> |
720 | |
721 | The address of the OP's last child, in hexidecimal. |
722 | |
723 | =item B<#name> |
724 | |
725 | The OP's name. |
726 | |
727 | =item B<#NAME> |
728 | |
729 | The OP's name, in all caps. |
730 | |
731 | =item B<#next> |
732 | |
733 | The sequence number of the OP's next OP. |
734 | |
735 | =item B<#nextaddr> |
736 | |
737 | The address of the OP's next OP, in hexidecimal. |
738 | |
739 | =item B<#noise> |
740 | |
741 | The two-character abbreviation for the OP's name. |
742 | |
743 | =item B<#private> |
744 | |
745 | The OP's private flags, rendered with abbreviated names if possible. |
746 | |
747 | =item B<#privval> |
748 | |
749 | The numeric value of the OP's private flags. |
750 | |
751 | =item B<#seq> |
752 | |
753 | The sequence number of the OP. |
754 | |
755 | =item B<#seqnum> |
756 | |
757 | The real sequence number of the OP, as a regular number and not adjusted |
758 | to be relative to the start of the real program. (This will generally be |
759 | a fairly large number because all of B<B::Concise> is compiled before |
760 | your program is). |
761 | |
762 | =item B<#sibaddr> |
763 | |
764 | The address of the OP's next youngest sibling, in hexidecimal. |
765 | |
766 | =item B<#svaddr> |
767 | |
768 | The address of the OP's SV, if it has an SV, in hexidecimal. |
769 | |
770 | =item B<#svclass> |
771 | |
772 | The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). |
773 | |
774 | =item B<#svval> |
775 | |
776 | The value of the OP's SV, if it has one, in a short human-readable format. |
777 | |
778 | =item B<#targ> |
779 | |
780 | The numeric value of the OP's targ. |
781 | |
782 | =item B<#targarg> |
783 | |
784 | The name of the variable the OP's targ refers to, if any, otherwise the |
785 | letter t followed by the OP's targ in decimal. |
786 | |
787 | =item B<#targarglife> |
788 | |
789 | Same as B<#targarg>, but followed by the COP sequence numbers that delimit |
790 | the variable's lifetime (or 'end' for a variable in an open scope) for a |
791 | variable. |
792 | |
793 | =item B<#typenum> |
794 | |
795 | The numeric value of the OP's type, in decimal. |
796 | |
797 | =back |
798 | |
799 | =head1 ABBREVIATIONS |
800 | |
801 | =head2 OP flags abbreviations |
802 | |
803 | v OPf_WANT_VOID Want nothing (void context) |
804 | s OPf_WANT_SCALAR Want single value (scalar context) |
805 | l OPf_WANT_LIST Want list of any length (list context) |
806 | K OPf_KIDS There is a firstborn child. |
807 | P OPf_PARENS This operator was parenthesized. |
808 | (Or block needs explicit scope entry.) |
809 | R OPf_REF Certified reference. |
810 | (Return container, not containee). |
811 | M OPf_MOD Will modify (lvalue). |
812 | S OPf_STACKED Some arg is arriving on the stack. |
813 | * OPf_SPECIAL Do something weird for this op (see op.h) |
814 | |
815 | =head2 OP class abbreviations |
816 | |
817 | 0 OP (aka BASEOP) An OP with no children |
818 | 1 UNOP An OP with one child |
819 | 2 BINOP An OP with two children |
820 | | LOGOP A control branch OP |
821 | @ LISTOP An OP that could have lots of children |
822 | / PMOP An OP with a regular expression |
823 | $ SVOP An OP with an SV |
824 | " PVOP An OP with a string |
825 | { LOOP An OP that holds pointers for a loop |
826 | ; COP An OP that marks the start of a statement |
827 | |
828 | =head1 AUTHOR |
829 | |
830 | Stephen McCamant, C<smcc@CSUA.Berkeley.EDU> |
831 | |
832 | =cut |