This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: POSIX::div
[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
127212b2 17 SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS CVf_ANON);
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;
127212b2
DM
439 if ($padname->FLAGS & SVf_FAKE) {
440 my $fake = '';
441 $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
442 $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
443 $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
444 $h{targarglife} = "$h{targarg}:FAKE:$fake";
445 }
446 else {
447 my $intro = $padname->NVX - $cop_seq_base;
448 my $finish = int($padname->IVX) - $cop_seq_base;
449 $finish = "end" if $finish == 999999999 - $cop_seq_base;
450 $h{targarglife} = "$h{targarg}:$intro,$finish";
451 }
c99ca59a
SM
452 } else {
453 $h{targarglife} = $h{targarg} = "t" . $h{targ};
454 }
455 }
456 $h{arg} = "";
457 $h{svclass} = $h{svaddr} = $h{svval} = "";
458 if ($h{class} eq "PMOP") {
459 my $precomp = $op->precomp;
7a9b44b9 460 if (defined $precomp) {
c27ea44e
SM
461 $precomp = cstring($precomp); # Escape literal control sequences
462 $precomp = "/$precomp/";
463 } else {
464 $precomp = "";
7a9b44b9 465 }
b2a3cfdd 466 my $pmreplroot = $op->pmreplroot;
34a48b4b 467 my $pmreplstart;
31b49ad4 468 if ($pmreplroot && $$pmreplroot && $pmreplroot->isa("B::GV")) {
b2a3cfdd
RH
469 # with C<@stash_array = split(/pat/, str);>,
470 # *stash_array is stored in pmreplroot.
471 $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
472 } elsif ($ {$op->pmreplstart}) {
c99ca59a
SM
473 undef $lastnext;
474 $pmreplstart = "replstart->" . seq($op->pmreplstart);
475 $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
476 } else {
477 $h{arg} = "($precomp)";
478 }
479 } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
480 $h{arg} = '("' . $op->pv . '")';
481 $h{svval} = '"' . $op->pv . '"';
482 } elsif ($h{class} eq "COP") {
483 my $label = $op->label;
c3caa09d 484 $h{coplabel} = $label;
c99ca59a
SM
485 $label = $label ? "$label: " : "";
486 my $loc = $op->file;
487 $loc =~ s[.*/][];
488 $loc .= ":" . $op->line;
489 my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
490 my $arybase = $op->arybase;
491 $arybase = $arybase ? ' $[=' . $arybase : "";
492 $h{arg} = "($label$stash $cseq $loc$arybase)";
493 } elsif ($h{class} eq "LOOP") {
494 $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
495 . " redo->" . seq($op->redoop) . ")";
496 } elsif ($h{class} eq "LOGOP") {
497 undef $lastnext;
498 $h{arg} = "(other->" . seq($op->other) . ")";
499 } elsif ($h{class} eq "SVOP") {
c27ea44e
SM
500 if (! ${$op->sv}) {
501 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
502 $h{arg} = "[" . concise_sv($sv, \%h) . "]";
503 $h{targarglife} = $h{targarg} = "";
c99ca59a 504 } else {
c27ea44e 505 $h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
c99ca59a 506 }
31b49ad4
SM
507 } elsif ($h{class} eq "PADOP") {
508 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
509 $h{arg} = "[" . concise_sv($sv, \%h) . "]";
c99ca59a
SM
510 }
511 $h{seq} = $h{hyphseq} = seq($op);
512 $h{seq} = "" if $h{seq} eq "-";
513 $h{seqnum} = $op->seq;
514 $h{next} = $op->next;
515 $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
516 $h{nextaddr} = sprintf("%#x", $ {$op->next});
517 $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
518 $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
519 $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
520
521 $h{classsym} = $opclass{$h{class}};
522 $h{flagval} = $op->flags;
523 $h{flags} = op_flags($op->flags);
524 $h{privval} = $op->private;
525 $h{private} = private_flags($h{name}, $op->private);
526 $h{addr} = sprintf("%#x", $$op);
527 $h{label} = $labels{$op->seq};
528 $h{typenum} = $op->type;
529 $h{noise} = $linenoise[$op->type];
78ad9108 530 $_->(\%h, $op, \$format, \$level) for @callbacks;
c99ca59a
SM
531 return fmt_line(\%h, $format, $level);
532}
533
534sub B::OP::concise {
535 my($op, $level) = @_;
536 if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
537 my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
538 "addr" => sprintf("%#x", $$lastnext)};
539 print fmt_line($h, $gotofmt, $level+1);
540 }
541 $lastnext = $op->next;
542 print concise_op($op, $level, $format);
543}
544
31b49ad4
SM
545# B::OP::terse (see Terse.pm) now just calls this
546sub b_terse {
547 my($op, $level) = @_;
548
549 # This isn't necessarily right, but there's no easy way to get
550 # from an OP to the right CV. This is a limitation of the
551 # ->terse() interface style, and there isn't much to do about
552 # it. In particular, we can die in concise_op if the main pad
553 # isn't long enough, or has the wrong kind of entries, compared to
554 # the pad a sub was compiled with. The fix for that would be to
555 # make a backwards compatible "terse" format that never even
556 # looked at the pad, just like the old B::Terse. I don't think
557 # that's worth the effort, though.
558 $curcv = main_cv unless $curcv;
559
560 if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
561 my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
562 "addr" => sprintf("%#x", $$lastnext)};
563 print fmt_line($h, $style{"terse"}[1], $level+1);
564 }
565 $lastnext = $op->next;
566 print concise_op($op, $level, $style{"terse"}[0]);
567}
568
c99ca59a
SM
569sub tree {
570 my $op = shift;
571 my $level = shift;
572 my $style = $tree_decorations[$tree_style];
573 my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
574 my $name = concise_op($op, $level, $treefmt);
575 if (not $op->flags & OPf_KIDS) {
576 return $name . "\n";
577 }
578 my @lines;
579 for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
580 push @lines, tree($kid, $level+1);
581 }
582 my $i;
583 for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
584 $lines[$i] = $space . $lines[$i];
585 }
586 if ($i > 0) {
587 $lines[$i] = $last . $lines[$i];
588 while ($i-- > 1) {
589 if (substr($lines[$i], 0, 1) eq " ") {
590 $lines[$i] = $nokid . $lines[$i];
591 } else {
592 $lines[$i] = $kid . $lines[$i];
593 }
594 }
595 $lines[$i] = $kids . $lines[$i];
596 } else {
597 $lines[0] = $single . $lines[0];
598 }
599 return("$name$lead" . shift @lines,
600 map(" " x (length($name)+$size) . $_, @lines));
601}
602
213a1a26
SM
603# *** Warning: fragile kludge ahead ***
604# Because the B::* modules run in the same interpreter as the code
605# they're compiling, their presence tends to distort the view we have
606# of the code we're looking at. In particular, perl gives sequence
607# numbers to both OPs in general and COPs in particular. If the
608# program we're looking at were run on its own, these numbers would
609# start at 1. Because all of B::Concise and all the modules it uses
610# are compiled first, though, by the time we get to the user's program
611# the sequence numbers are alreay at pretty high numbers, which would
612# be distracting if you're trying to tell OPs apart. Therefore we'd
613# like to subtract an offset from all the sequence numbers we display,
614# to restore the simpler view of the world. The trick is to know what
615# that offset will be, when we're still compiling B::Concise! If we
616# hardcoded a value, it would have to change every time B::Concise or
617# other modules we use do. To help a little, what we do here is
618# compile a little code at the end of the module, and compute the base
619# sequence number for the user's program as being a small offset
620# later, so all we have to worry about are changes in the offset.
c27ea44e
SM
621# (Note that we now only play this game with COP sequence numbers. OP
622# sequence numbers aren't used to refer to OPs from a distance, and
623# they don't have much significance, so we just generate our own
624# sequence numbers which are easier to control. This way we also don't
625# stand in the way of a possible future removal of OP sequence
626# numbers).
213a1a26
SM
627
628# When you say "perl -MO=Concise -e '$a'", the output should look like:
629
630# 4 <@> leave[t1] vKP/REFC ->(end)
631# 1 <0> enter ->2
632 #^ smallest OP sequence number should be 1
633# 2 <;> nextstate(main 1 -e:1) v ->3
634 # ^ smallest COP sequence number should be 1
635# - <1> ex-rv2sv vK/1 ->4
636# 3 <$> gvsv(*a) s ->4
637
c27ea44e
SM
638# If the second of the marked numbers there isn't 1, it means you need
639# to update the corresponding magic number in the next line.
640# Remember, this needs to stay the last things in the module.
e69a2255 641
c27ea44e
SM
642# Why is this different for MacOS? Does it matter?
643my $cop_seq_mnum = $^O eq 'MacOS' ? 10 : 9;
e69a2255 644$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
c99ca59a
SM
645
6461;
647
648__END__
649
650=head1 NAME
651
652B::Concise - Walk Perl syntax tree, printing concise info about ops
653
654=head1 SYNOPSIS
655
656 perl -MO=Concise[,OPTIONS] foo.pl
657
78ad9108
PJ
658 use B::Concise qw(set_style add_callback);
659
c99ca59a
SM
660=head1 DESCRIPTION
661
662This compiler backend prints the internal OPs of a Perl program's syntax
663tree in one of several space-efficient text formats suitable for debugging
664the inner workings of perl or other compiler backends. It can print OPs in
665the order they appear in the OP tree, in the order they will execute, or
666in a text approximation to their tree structure, and the format of the
667information displyed is customizable. Its function is similar to that of
668perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
669sophisticated and flexible.
670
f8a679e6
RGS
671=head1 EXAMPLE
672
673Here's is a short example of output, using the default formatting
674conventions :
675
676 % perl -MO=Concise -e '$a = $b + 42'
677 8 <@> leave[t1] vKP/REFC ->(end)
678 1 <0> enter ->2
679 2 <;> nextstate(main 1 -e:1) v ->3
680 7 <2> sassign vKS/2 ->8
681 5 <2> add[t1] sK/2 ->6
682 - <1> ex-rv2sv sK/1 ->4
683 3 <$> gvsv(*b) s ->4
684 4 <$> const(IV 42) s ->5
685 - <1> ex-rv2sv sKRM*/1 ->7
686 6 <$> gvsv(*a) s ->7
687
688Each line corresponds to an operator. Null ops appear as C<ex-opname>,
689where I<opname> is the op that has been optimized away by perl.
690
691The number on the first row indicates the op's sequence number. It's
692given in base 36 by default.
693
694The symbol between angle brackets indicates the op's type : for example,
695<2> is a BINOP, <@> a LISTOP, etc. (see L</"OP class abbreviations">).
696
697The opname may be followed by op-specific information in parentheses
698(e.g. C<gvsv(*b)>), and by targ information in brackets (e.g.
699C<leave[t1]>).
700
701Next come the op flags. The common flags are listed below
702(L</"OP flags abbreviations">). The private flags follow, separated
703by a slash. For example, C<vKP/REFC> means that the leave op has
704public flags OPf_WANT_VOID, OPf_KIDS, and OPf_PARENS, and the private
705flag OPpREFCOUNTED.
706
707Finally an arrow points to the sequence number of the next op.
708
c99ca59a
SM
709=head1 OPTIONS
710
711Arguments that don't start with a hyphen are taken to be the names of
712subroutines to print the OPs of; if no such functions are specified, the
713main body of the program (outside any subroutines, and not including use'd
714or require'd files) is printed.
715
716=over 4
717
718=item B<-basic>
719
720Print OPs in the order they appear in the OP tree (a preorder
721traversal, starting at the root). The indentation of each OP shows its
722level in the tree. This mode is the default, so the flag is included
723simply for completeness.
724
725=item B<-exec>
726
727Print OPs in the order they would normally execute (for the majority
728of constructs this is a postorder traversal of the tree, ending at the
729root). In most cases the OP that usually follows a given OP will
730appear directly below it; alternate paths are shown by indentation. In
731cases like loops when control jumps out of a linear path, a 'goto'
732line is generated.
733
734=item B<-tree>
735
736Print OPs in a text approximation of a tree, with the root of the tree
737at the left and 'left-to-right' order of children transformed into
738'top-to-bottom'. Because this mode grows both to the right and down,
739it isn't suitable for large programs (unless you have a very wide
740terminal).
741
742=item B<-compact>
743
744Use a tree format in which the minimum amount of space is used for the
745lines connecting nodes (one character in most cases). This squeezes out
746a few precious columns of screen real estate.
747
748=item B<-loose>
749
750Use a tree format that uses longer edges to separate OP nodes. This format
751tends to look better than the compact one, especially in ASCII, and is
752the default.
753
754=item B<-vt>
755
756Use tree connecting characters drawn from the VT100 line-drawing set.
757This looks better if your terminal supports it.
758
759=item B<-ascii>
760
761Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
762look as clean as the VT100 characters, but they'll work with almost any
763terminal (or the horizontal scrolling mode of less(1)) and are suitable
764for text documentation or email. This is the default.
765
766=item B<-main>
767
768Include the main program in the output, even if subroutines were also
769specified.
770
771=item B<-base>I<n>
772
773Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
774digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
775for 37 will be 'A', and so on until 62. Values greater than 62 are not
776currently supported. The default is 36.
777
778=item B<-bigendian>
779
780Print sequence numbers with the most significant digit first. This is the
781usual convention for Arabic numerals, and the default.
782
783=item B<-littleendian>
784
785Print seqence numbers with the least significant digit first.
786
787=item B<-concise>
788
789Use the author's favorite set of formatting conventions. This is the
790default, of course.
791
792=item B<-terse>
793
a6d05634 794Use formatting conventions that emulate the output of B<B::Terse>. The
c99ca59a
SM
795basic mode is almost indistinguishable from the real B<B::Terse>, and the
796exec mode looks very similar, but is in a more logical order and lacks
797curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
798is only vaguely reminiscient of B<B::Terse>.
799
800=item B<-linenoise>
801
802Use formatting conventions in which the name of each OP, rather than being
803written out in full, is represented by a one- or two-character abbreviation.
804This is mainly a joke.
805
806=item B<-debug>
807
808Use formatting conventions reminiscient of B<B::Debug>; these aren't
809very concise at all.
810
811=item B<-env>
812
813Use formatting conventions read from the environment variables
814C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
815
816=back
817
818=head1 FORMATTING SPECIFICATIONS
819
820For each general style ('concise', 'terse', 'linenoise', etc.) there are
821three specifications: one of how OPs should appear in the basic or exec
822modes, one of how 'goto' lines should appear (these occur in the exec
823mode only), and one of how nodes should appear in tree mode. Each has the
824same format, described below. Any text that doesn't match a special
825pattern is copied verbatim.
826
827=over 4
828
829=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
830
831Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
832
833=item B<(*(>I<text>B<)*)>
834
835Generates one copy of I<text> for each indentation level.
836
837=item B<(*(>I<text1>B<;>I<text2>B<)*)>
838
839Generates one fewer copies of I<text1> than the indentation level, followed
840by one copy of I<text2> if the indentation level is more than 0.
841
842=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
843
844If the value of I<var> is true (not empty or zero), generates the
845value of I<var> surrounded by I<text1> and I<Text2>, otherwise
846nothing.
847
848=item B<#>I<var>
849
850Generates the value of the variable I<var>.
851
852=item B<#>I<var>I<N>
853
854Generates the value of I<var>, left jutified to fill I<N> spaces.
855
856=item B<~>
857
858Any number of tildes and surrounding whitespace will be collapsed to
859a single space.
860
861=back
862
863The following variables are recognized:
864
865=over 4
866
867=item B<#addr>
868
869The address of the OP, in hexidecimal.
870
871=item B<#arg>
872
873The OP-specific information of the OP (such as the SV for an SVOP, the
874non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
875
876=item B<#class>
877
878The B-determined class of the OP, in all caps.
879
f8a679e6 880=item B<#classsym>
c99ca59a
SM
881
882A single symbol abbreviating the class of the OP.
883
c3caa09d
SM
884=item B<#coplabel>
885
886The label of the statement or block the OP is the start of, if any.
887
c99ca59a
SM
888=item B<#exname>
889
890The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
891
892=item B<#extarg>
893
894The target of the OP, or nothing for a nulled OP.
895
896=item B<#firstaddr>
897
898The address of the OP's first child, in hexidecimal.
899
900=item B<#flags>
901
902The OP's flags, abbreviated as a series of symbols.
903
904=item B<#flagval>
905
906The numeric value of the OP's flags.
907
f8a679e6 908=item B<#hyphseq>
c99ca59a
SM
909
910The sequence number of the OP, or a hyphen if it doesn't have one.
911
912=item B<#label>
913
914'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
915mode, or empty otherwise.
916
917=item B<#lastaddr>
918
919The address of the OP's last child, in hexidecimal.
920
921=item B<#name>
922
923The OP's name.
924
925=item B<#NAME>
926
927The OP's name, in all caps.
928
929=item B<#next>
930
931The sequence number of the OP's next OP.
932
933=item B<#nextaddr>
934
935The address of the OP's next OP, in hexidecimal.
936
937=item B<#noise>
938
c27ea44e 939A one- or two-character abbreviation for the OP's name.
c99ca59a
SM
940
941=item B<#private>
942
943The OP's private flags, rendered with abbreviated names if possible.
944
945=item B<#privval>
946
947The numeric value of the OP's private flags.
948
949=item B<#seq>
950
c27ea44e
SM
951The sequence number of the OP. Note that this is now a sequence number
952generated by B::Concise, rather than the real op_seq value (for which
953see B<#seqnum>).
c99ca59a
SM
954
955=item B<#seqnum>
956
957The real sequence number of the OP, as a regular number and not adjusted
958to be relative to the start of the real program. (This will generally be
959a fairly large number because all of B<B::Concise> is compiled before
960your program is).
961
962=item B<#sibaddr>
963
964The address of the OP's next youngest sibling, in hexidecimal.
965
966=item B<#svaddr>
967
968The address of the OP's SV, if it has an SV, in hexidecimal.
969
970=item B<#svclass>
971
972The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
973
974=item B<#svval>
975
976The value of the OP's SV, if it has one, in a short human-readable format.
977
978=item B<#targ>
979
980The numeric value of the OP's targ.
981
982=item B<#targarg>
983
984The name of the variable the OP's targ refers to, if any, otherwise the
985letter t followed by the OP's targ in decimal.
986
987=item B<#targarglife>
988
989Same as B<#targarg>, but followed by the COP sequence numbers that delimit
990the variable's lifetime (or 'end' for a variable in an open scope) for a
991variable.
992
993=item B<#typenum>
994
995The numeric value of the OP's type, in decimal.
996
997=back
998
999=head1 ABBREVIATIONS
1000
1001=head2 OP flags abbreviations
1002
1003 v OPf_WANT_VOID Want nothing (void context)
1004 s OPf_WANT_SCALAR Want single value (scalar context)
1005 l OPf_WANT_LIST Want list of any length (list context)
1006 K OPf_KIDS There is a firstborn child.
1007 P OPf_PARENS This operator was parenthesized.
1008 (Or block needs explicit scope entry.)
1009 R OPf_REF Certified reference.
1010 (Return container, not containee).
1011 M OPf_MOD Will modify (lvalue).
1012 S OPf_STACKED Some arg is arriving on the stack.
1013 * OPf_SPECIAL Do something weird for this op (see op.h)
1014
1015=head2 OP class abbreviations
1016
1017 0 OP (aka BASEOP) An OP with no children
1018 1 UNOP An OP with one child
1019 2 BINOP An OP with two children
1020 | LOGOP A control branch OP
1021 @ LISTOP An OP that could have lots of children
1022 / PMOP An OP with a regular expression
1023 $ SVOP An OP with an SV
1024 " PVOP An OP with a string
1025 { LOOP An OP that holds pointers for a loop
1026 ; COP An OP that marks the start of a statement
051f02e9 1027 # PADOP An OP with a GV on the pad
c99ca59a 1028
78ad9108
PJ
1029=head1 Using B::Concise outside of the O framework
1030
1031It is possible to extend B<B::Concise> by using it outside of the B<O>
1032framework and providing new styles and new variables.
1033
1034 use B::Concise qw(set_style add_callback);
1035 set_style($format, $gotofmt, $treefmt);
1036 add_callback
1037 (
1038 sub
1039 {
1040 my ($h, $op, $level, $format) = @_;
1041 $h->{variable} = some_func($op);
1042 }
1043 );
1044 B::Concise::compile(@options)->();
1045
1046You can specify a style by calling the B<set_style> subroutine. If you
1047have a new variable in your style, or you want to change the value of an
1048existing variable, you will need to add a callback to specify the value
1049for that variable.
1050
1051This is done by calling B<add_callback> passing references to any
1052callback subroutines. The subroutines are called in the same order as
1053they are added. Each subroutine is passed four parameters. These are a
1054reference to a hash, the keys of which are the names of the variables
1055and the values of which are their values, the op, the level and the
1056format.
1057
1058To define your own variables, simply add them to the hash, or change
1059existing values if you need to. The level and format are passed in as
1060references to scalars, but it is unlikely that they will need to be
1061changed or even used.
1062
31b49ad4
SM
1063To switch back to one of the standard styles like C<concise> or
1064C<terse>, use C<set_style_standard>.
1065
78ad9108
PJ
1066To see the output, call the subroutine returned by B<compile> in the
1067same way that B<O> does.
1068
c99ca59a
SM
1069=head1 AUTHOR
1070
31b49ad4 1071Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
c99ca59a
SM
1072
1073=cut