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