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