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