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.
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.
13 use warnings; # uses #3 and #4, since warnings uses Carp
15 use Exporter (); # use #5
17 our $VERSION = "0.59";
18 our @ISA = qw(Exporter);
19 our @EXPORT_OK = qw(set_style set_style_standard add_callback
20 concise_subref concise_cv concise_main);
23 use B qw(class ppname main_start main_root main_cv cstring svref_2object
24 SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
29 ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
30 . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
31 "(*( )*)goto #class (#addr)\n",
34 ["#hyphseq2 (*( (x( ;)x))*)<#classsym> "
35 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n",
36 " (*( )*) goto #seq\n",
37 "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
39 ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
41 "(?(#seq)?)#noise#arg(?([#targarg])?)"],
43 ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
44 . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
45 . "\top_flags\t#flagval\n\top_private\t#privval\n"
46 . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
47 . "(?(\top_sv\t\t#svaddr\n)?)",
50 "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
51 $ENV{B_CONCISE_TREE_FORMAT}],
54 my($format, $gotofmt, $treefmt);
60 ($format, $gotofmt, $treefmt) = @_;
63 sub set_style_standard {
65 set_style(@{$style{$name}});
73 my($order, $subref) = @_;
74 concise_cv_obj($order, svref_2object($subref));
77 # This should have been called concise_subref, but it was exported
78 # under this name in versions before 0.56
79 sub concise_cv { concise_subref(@_); }
82 my ($order, $cv) = @_;
85 if ($order eq "exec") {
86 walk_exec($cv->START);
87 } elsif ($order eq "basic") {
88 walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
90 print tree($cv->ROOT, 0)
98 if ($order eq "exec") {
99 return if class(main_start) eq "NULL";
100 walk_exec(main_start);
101 } elsif ($order eq "tree") {
102 return if class(main_root) eq "NULL";
103 print tree(main_root, 0);
104 } elsif ($order eq "basic") {
105 return if class(main_root) eq "NULL";
106 walk_topdown(main_root,
107 sub { $_[0]->concise($_[1]) }, 0);
111 sub concise_specials {
112 my($name, $order, @cv_s) = @_;
114 if ($name eq "BEGIN") {
115 splice(@cv_s, 0, 7); # skip 7 BEGIN blocks in this file
116 } elsif ($name eq "CHECK") {
117 pop @cv_s; # skip the CHECK block that calls us
122 concise_cv_obj($order, $cv);
126 my $start_sym = "\e(0"; # "\cN" sometimes also works
127 my $end_sym = "\e(B"; # "\cO" respectively
129 my @tree_decorations =
130 ([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
131 [" ", "-", "+", "+", "|", "`", "", 0],
132 [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
133 [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
142 set_style_standard("concise");
145 my @options = grep(/^-/, @_);
146 my @args = grep(!/^-/, @_);
148 for my $o (@options) {
149 if ($o eq "-basic") {
151 } elsif ($o eq "-exec") {
153 } elsif ($o eq "-tree") {
155 } elsif ($o eq "-compact") {
157 } elsif ($o eq "-loose") {
159 } elsif ($o eq "-vt") {
161 } elsif ($o eq "-ascii") {
163 } elsif ($o eq "-main") {
165 } elsif ($o =~ /^-base(\d+)$/) {
167 } elsif ($o eq "-bigendian") {
169 } elsif ($o eq "-littleendian") {
171 } elsif (exists $style{substr($o, 1)}) {
172 set_style(@{$style{substr($o, 1)}});
174 warn "Option $o unrecognized";
179 for my $objname (@args) {
180 if ($objname eq "BEGIN") {
181 concise_specials("BEGIN", $order,
182 B::begin_av->isa("B::AV") ?
183 B::begin_av->ARRAY : ());
184 } elsif ($objname eq "INIT") {
185 concise_specials("INIT", $order,
186 B::init_av->isa("B::AV") ?
187 B::init_av->ARRAY : ());
188 } elsif ($objname eq "CHECK") {
189 concise_specials("CHECK", $order,
190 B::check_av->isa("B::AV") ?
191 B::check_av->ARRAY : ());
192 } elsif ($objname eq "END") {
193 concise_specials("END", $order,
194 B::end_av->isa("B::AV") ?
195 B::end_av->ARRAY : ());
197 $objname = "main::" . $objname unless $objname =~ /::/;
199 eval "concise_subref(\$order, \\&$objname)";
200 die "concise_subref($order, \\&$objname) failed: $@" if $@;
204 if (!@args or $do_main) {
205 print "main program:\n" if $do_main;
206 concise_main($order);
214 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
215 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
216 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
218 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
220 qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
221 ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
222 -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
223 > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
224 ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
225 uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
226 a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
227 v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
228 ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
229 ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
230 -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
231 co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
232 g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
233 e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
234 Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
236 my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
241 push @v, "v" if ($x & 3) == 1;
242 push @v, "s" if ($x & 3) == 2;
243 push @v, "l" if ($x & 3) == 3;
244 push @v, "K" if $x & 4;
245 push @v, "P" if $x & 8;
246 push @v, "R" if $x & 16;
247 push @v, "M" if $x & 32;
248 push @v, "S" if $x & 64;
249 push @v, "*" if $x & 128;
255 return "-" . base_n(-$x) if $x < 0;
257 do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
258 $str = reverse $str if $big_endian;
267 return "-" if not exists $sequence_num{$$op};
268 return base_n($sequence_num{$$op});
272 my($op, $sub, $level) = @_;
274 if ($op->flags & OPf_KIDS) {
275 for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
276 walk_topdown($kid, $sub, $level + 1);
279 if (class($op) eq "PMOP") {
280 my $maybe_root = $op->pmreplroot;
281 if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
282 # It really is the root of the replacement, not something
283 # else stored here for lack of space elsewhere
284 walk_topdown($maybe_root, $sub, $level + 1);
290 my($ar, $level) = @_;
292 if (ref($l) eq "ARRAY") {
293 walklines($l, $level + 1);
301 my($top, $level) = @_;
304 my @todo = ([$top, \@lines]);
305 while (@todo and my($op, $targ) = @{shift @todo}) {
306 for (; $$op; $op = $op->next) {
307 last if $opsseen{$$op}++;
309 my $name = $op->name;
310 if (class($op) eq "LOGOP") {
313 push @todo, [$op->other, $ar];
314 } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
317 push @todo, [$op->pmreplstart, $ar];
318 } elsif ($name =~ /^enter(loop|iter)$/) {
319 $labels{${$op->nextop}} = "NEXT";
320 $labels{${$op->lastop}} = "LAST";
321 $labels{${$op->redoop}} = "REDO";
325 walklines(\@lines, 0);
328 # The structure of this routine is purposely modeled after op.c's peep()
332 return if class($op) eq "NULL" or exists $sequence_num{$$op};
333 for (; $$op; $op = $op->next) {
334 last if exists $sequence_num{$$op};
335 my $name = $op->name;
336 if ($name =~ /^(null|scalar|lineseq|scope)$/) {
337 next if $oldop and $ {$op->next};
339 $sequence_num{$$op} = $seq_max++;
340 if (class($op) eq "LOGOP") {
341 my $other = $op->other;
342 $other = $other->next while $other->name eq "null";
344 } elsif (class($op) eq "LOOP") {
345 my $redoop = $op->redoop;
346 $redoop = $redoop->next while $redoop->name eq "null";
348 my $nextop = $op->nextop;
349 $nextop = $nextop->next while $nextop->name eq "null";
351 my $lastop = $op->lastop;
352 $lastop = $lastop->next while $lastop->name eq "null";
354 } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
355 my $replstart = $op->pmreplstart;
356 $replstart = $replstart->next while $replstart->name eq "null";
357 sequence($replstart);
365 my($hr, $fmt, $level) = @_;
367 $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
368 $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
369 $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
370 $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
371 $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
372 $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
373 $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg;
374 $text =~ s/[ \t]*~+[ \t]*/ /g;
379 $priv{$_}{128} = "LVINTRO"
380 for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
381 "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
382 "padav", "padhv", "enteriter");
383 $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
384 $priv{"aassign"}{64} = "COMMON";
385 $priv{"sassign"}{64} = "BKWARD";
386 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont");
387 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
389 $priv{"repeat"}{64} = "DOLIST";
390 $priv{"leaveloop"}{64} = "CONT";
391 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
392 for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem");
393 $priv{"entersub"}{16} = "DBG";
394 $priv{"entersub"}{32} = "TARG";
395 @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
396 $priv{"gv"}{32} = "EARLYCV";
397 $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
398 $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
400 $priv{$_}{16} = "TARGMY"
401 for (map(($_,"s$_"),"chop", "chomp"),
402 map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
403 "add", "subtract", "negate"), "pow", "concat", "stringify",
404 "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
405 "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
406 "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
407 "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
408 "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
409 "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
410 "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
411 "setpriority", "time", "sleep");
412 @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN");
413 $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
414 $priv{"list"}{64} = "GUESSED";
415 $priv{"delete"}{64} = "SLICE";
416 $priv{"exists"}{64} = "SUB";
417 $priv{$_}{64} = "LOCALE"
418 for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
419 "scmp", "lc", "uc", "lcfirst", "ucfirst");
420 @{$priv{"sort"}}{1,2,4,8} = ("NUM", "INT", "REV", "INPLACE");
421 $priv{"threadsv"}{64} = "SVREFd";
422 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
423 for ("open", "backtick");
424 $priv{"exit"}{128} = "VMS";
425 $priv{$_}{2} = "FTACCESS"
426 for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
427 $priv{$_}{4} = "FTSTACKED"
428 for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
429 "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
430 "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
431 "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
433 $priv{$_}{2} = "GREPLEX"
434 for ("mapwhile", "mapstart", "grepwhile", "grepstart");
439 for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
440 if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
442 push @s, $priv{$name}{$flag};
446 return join(",", @s);
451 $hr->{svclass} = class($sv);
452 $hr->{svclass} = "UV"
453 if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
454 $hr->{svaddr} = sprintf("%#x", $$sv);
455 if ($hr->{svclass} eq "GV") {
457 my $stash = $gv->STASH->NAME;
458 if ($stash eq "main") {
461 $stash = $stash . "::";
463 $hr->{svval} = "*$stash" . $gv->SAFENAME;
464 return "*$stash" . $gv->SAFENAME;
466 while (class($sv) eq "RV") {
467 $hr->{svval} .= "\\";
470 if (class($sv) eq "SPECIAL") {
471 $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
472 } elsif ($sv->FLAGS & SVf_NOK) {
473 $hr->{svval} .= $sv->NV;
474 } elsif ($sv->FLAGS & SVf_IOK) {
475 $hr->{svval} .= $sv->int_value;
476 } elsif ($sv->FLAGS & SVf_POK) {
477 $hr->{svval} .= cstring($sv->PV);
478 } elsif (class($sv) eq "HV") {
479 $hr->{svval} .= 'HASH';
481 return $hr->{svclass} . " " . $hr->{svval};
486 my ($op, $level, $format) = @_;
488 $h{exname} = $h{name} = $op->name;
489 $h{NAME} = uc $h{name};
490 $h{class} = class($op);
491 $h{extarg} = $h{targ} = $op->targ;
492 $h{extarg} = "" unless $h{extarg};
493 if ($h{name} eq "null" and $h{targ}) {
494 # targ holds the old type
495 $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
497 } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
498 # targ potentially holds a reference count
499 if ($op->private & 64) {
500 my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
501 $h{targarglife} = $h{targarg} = "$h{targ} $refs";
504 my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
505 if (defined $padname and class($padname) ne "SPECIAL") {
506 $h{targarg} = $padname->PVX;
507 if ($padname->FLAGS & SVf_FAKE) {
509 $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
510 $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
511 $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
512 $h{targarglife} = "$h{targarg}:FAKE:$fake";
515 my $intro = $padname->NVX - $cop_seq_base;
516 my $finish = int($padname->IVX) - $cop_seq_base;
517 $finish = "end" if $finish == 999999999 - $cop_seq_base;
518 $h{targarglife} = "$h{targarg}:$intro,$finish";
521 $h{targarglife} = $h{targarg} = "t" . $h{targ};
525 $h{svclass} = $h{svaddr} = $h{svval} = "";
526 if ($h{class} eq "PMOP") {
527 my $precomp = $op->precomp;
528 if (defined $precomp) {
529 $precomp = cstring($precomp); # Escape literal control sequences
530 $precomp = "/$precomp/";
534 my $pmreplroot = $op->pmreplroot;
536 if (ref($pmreplroot) eq "B::GV") {
537 # with C<@stash_array = split(/pat/, str);>,
538 # *stash_array is stored in /pat/'s pmreplroot.
539 $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
540 } elsif (!ref($pmreplroot) and $pmreplroot) {
541 # same as the last case, except the value is actually a
542 # pad offset for where the GV is kept (this happens under
544 my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
545 $h{arg} = "($precomp => \@" . $gv->NAME . ")";
546 } elsif ($ {$op->pmreplstart}) {
548 $pmreplstart = "replstart->" . seq($op->pmreplstart);
549 $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
551 $h{arg} = "($precomp)";
553 } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
554 $h{arg} = '("' . $op->pv . '")';
555 $h{svval} = '"' . $op->pv . '"';
556 } elsif ($h{class} eq "COP") {
557 my $label = $op->label;
558 $h{coplabel} = $label;
559 $label = $label ? "$label: " : "";
562 $loc .= ":" . $op->line;
563 my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
564 my $arybase = $op->arybase;
565 $arybase = $arybase ? ' $[=' . $arybase : "";
566 $h{arg} = "($label$stash $cseq $loc$arybase)";
567 } elsif ($h{class} eq "LOOP") {
568 $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
569 . " redo->" . seq($op->redoop) . ")";
570 } elsif ($h{class} eq "LOGOP") {
572 $h{arg} = "(other->" . seq($op->other) . ")";
573 } elsif ($h{class} eq "SVOP") {
574 unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
576 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
577 $h{arg} = "[" . concise_sv($sv, \%h) . "]";
578 $h{targarglife} = $h{targarg} = "";
580 $h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
583 } elsif ($h{class} eq "PADOP") {
584 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
585 $h{arg} = "[" . concise_sv($sv, \%h) . "]";
587 $h{seq} = $h{hyphseq} = seq($op);
588 $h{seq} = "" if $h{seq} eq "-";
590 $h{static} = $op->static;
591 $h{next} = $op->next;
592 $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
593 $h{nextaddr} = sprintf("%#x", $ {$op->next});
594 $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
595 $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
596 $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
598 $h{classsym} = $opclass{$h{class}};
599 $h{flagval} = $op->flags;
600 $h{flags} = op_flags($op->flags);
601 $h{privval} = $op->private;
602 $h{private} = private_flags($h{name}, $op->private);
603 $h{addr} = sprintf("%#x", $$op);
604 $h{label} = $labels{$$op};
605 $h{typenum} = $op->type;
606 $h{noise} = $linenoise[$op->type];
607 $_->(\%h, $op, \$format, \$level) for @callbacks;
608 return fmt_line(\%h, $format, $level);
612 my($op, $level) = @_;
613 if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
614 my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
615 "addr" => sprintf("%#x", $$lastnext)};
616 print fmt_line($h, $gotofmt, $level+1);
618 $lastnext = $op->next;
619 print concise_op($op, $level, $format);
622 # B::OP::terse (see Terse.pm) now just calls this
624 my($op, $level) = @_;
626 # This isn't necessarily right, but there's no easy way to get
627 # from an OP to the right CV. This is a limitation of the
628 # ->terse() interface style, and there isn't much to do about
629 # it. In particular, we can die in concise_op if the main pad
630 # isn't long enough, or has the wrong kind of entries, compared to
631 # the pad a sub was compiled with. The fix for that would be to
632 # make a backwards compatible "terse" format that never even
633 # looked at the pad, just like the old B::Terse. I don't think
634 # that's worth the effort, though.
635 $curcv = main_cv unless $curcv;
637 if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
638 my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
639 "addr" => sprintf("%#x", $$lastnext)};
640 print fmt_line($h, $style{"terse"}[1], $level+1);
642 $lastnext = $op->next;
643 print concise_op($op, $level, $style{"terse"}[0]);
649 my $style = $tree_decorations[$tree_style];
650 my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
651 my $name = concise_op($op, $level, $treefmt);
652 if (not $op->flags & OPf_KIDS) {
656 for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
657 push @lines, tree($kid, $level+1);
660 for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
661 $lines[$i] = $space . $lines[$i];
664 $lines[$i] = $last . $lines[$i];
666 if (substr($lines[$i], 0, 1) eq " ") {
667 $lines[$i] = $nokid . $lines[$i];
669 $lines[$i] = $kid . $lines[$i];
672 $lines[$i] = $kids . $lines[$i];
674 $lines[0] = $single . $lines[0];
676 return("$name$lead" . shift @lines,
677 map(" " x (length($name)+$size) . $_, @lines));
680 # *** Warning: fragile kludge ahead ***
681 # Because the B::* modules run in the same interpreter as the code
682 # they're compiling, their presence tends to distort the view we have of
683 # the code we're looking at. In particular, perl gives sequence numbers
684 # to COPs. If the program we're looking at were run on its own, this
685 # would start at 1. Because all of B::Concise and all the modules it
686 # uses are compiled first, though, by the time we get to the user's
687 # program the sequence number is already pretty high, which could be
688 # distracting if you're trying to tell OPs apart. Therefore we'd like to
689 # subtract an offset from all the sequence numbers we display, to
690 # restore the simpler view of the world. The trick is to know what that
691 # offset will be, when we're still compiling B::Concise! If we
692 # hardcoded a value, it would have to change every time B::Concise or
693 # other modules we use do. To help a little, what we do here is compile
694 # a little code at the end of the module, and compute the base sequence
695 # number for the user's program as being a small offset later, so all we
696 # have to worry about are changes in the offset.
698 # When you say "perl -MO=Concise -e '$a'", the output should look like:
700 # 4 <@> leave[t1] vKP/REFC ->(end)
702 #^ smallest OP sequence number should be 1
703 # 2 <;> nextstate(main 1 -e:1) v ->3
704 # ^ smallest COP sequence number should be 1
705 # - <1> ex-rv2sv vK/1 ->4
706 # 3 <$> gvsv(*a) s ->4
708 # If the second of the marked numbers there isn't 1, it means you need
709 # to update the corresponding magic number in the next line.
710 # Remember, this needs to stay the last things in the module.
712 # Why is this different for MacOS? Does it matter?
713 my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
714 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
722 B::Concise - Walk Perl syntax tree, printing concise info about ops
726 perl -MO=Concise[,OPTIONS] foo.pl
728 use B::Concise qw(set_style add_callback);
732 This compiler backend prints the internal OPs of a Perl program's syntax
733 tree in one of several space-efficient text formats suitable for debugging
734 the inner workings of perl or other compiler backends. It can print OPs in
735 the order they appear in the OP tree, in the order they will execute, or
736 in a text approximation to their tree structure, and the format of the
737 information displyed is customizable. Its function is similar to that of
738 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
739 sophisticated and flexible.
743 Here's is a short example of output, using the default formatting
746 % perl -MO=Concise -e '$a = $b + 42'
747 8 <@> leave[1 ref] vKP/REFC ->(end)
749 2 <;> nextstate(main 1 -e:1) v ->3
750 7 <2> sassign vKS/2 ->8
751 5 <2> add[t1] sK/2 ->6
752 - <1> ex-rv2sv sK/1 ->4
754 4 <$> const(IV 42) s ->5
755 - <1> ex-rv2sv sKRM*/1 ->7
758 Each line corresponds to an operator. Null ops appear as C<ex-opname>,
759 where I<opname> is the op that has been optimized away by perl.
761 The number on the first row indicates the op's sequence number. It's
762 given in base 36 by default.
764 The symbol between angle brackets indicates the op's type : for example,
765 <2> is a BINOP, <@> a LISTOP, etc. (see L</"OP class abbreviations">).
767 The opname may be followed by op-specific information in parentheses
768 (e.g. C<gvsv(*b)>), and by targ information in brackets (e.g.
771 Next come the op flags. The common flags are listed below
772 (L</"OP flags abbreviations">). The private flags follow, separated
773 by a slash. For example, C<vKP/REFC> means that the leave op has
774 public flags OPf_WANT_VOID, OPf_KIDS, and OPf_PARENS, and the private
777 Finally an arrow points to the sequence number of the next op.
781 Arguments that don't start with a hyphen are taken to be the names of
782 subroutines to print the OPs of; if no such functions are specified,
783 the main body of the program (outside any subroutines, and not
784 including use'd or require'd files) is printed. Passing C<BEGIN>,
785 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
786 special blocks to be printed.
792 Print OPs in the order they appear in the OP tree (a preorder
793 traversal, starting at the root). The indentation of each OP shows its
794 level in the tree. This mode is the default, so the flag is included
795 simply for completeness.
799 Print OPs in the order they would normally execute (for the majority
800 of constructs this is a postorder traversal of the tree, ending at the
801 root). In most cases the OP that usually follows a given OP will
802 appear directly below it; alternate paths are shown by indentation. In
803 cases like loops when control jumps out of a linear path, a 'goto'
808 Print OPs in a text approximation of a tree, with the root of the tree
809 at the left and 'left-to-right' order of children transformed into
810 'top-to-bottom'. Because this mode grows both to the right and down,
811 it isn't suitable for large programs (unless you have a very wide
816 Use a tree format in which the minimum amount of space is used for the
817 lines connecting nodes (one character in most cases). This squeezes out
818 a few precious columns of screen real estate.
822 Use a tree format that uses longer edges to separate OP nodes. This format
823 tends to look better than the compact one, especially in ASCII, and is
828 Use tree connecting characters drawn from the VT100 line-drawing set.
829 This looks better if your terminal supports it.
833 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
834 look as clean as the VT100 characters, but they'll work with almost any
835 terminal (or the horizontal scrolling mode of less(1)) and are suitable
836 for text documentation or email. This is the default.
840 Include the main program in the output, even if subroutines were also
845 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
846 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
847 for 37 will be 'A', and so on until 62. Values greater than 62 are not
848 currently supported. The default is 36.
852 Print sequence numbers with the most significant digit first. This is the
853 usual convention for Arabic numerals, and the default.
855 =item B<-littleendian>
857 Print seqence numbers with the least significant digit first.
861 Use the author's favorite set of formatting conventions. This is the
866 Use formatting conventions that emulate the output of B<B::Terse>. The
867 basic mode is almost indistinguishable from the real B<B::Terse>, and the
868 exec mode looks very similar, but is in a more logical order and lacks
869 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
870 is only vaguely reminiscient of B<B::Terse>.
874 Use formatting conventions in which the name of each OP, rather than being
875 written out in full, is represented by a one- or two-character abbreviation.
876 This is mainly a joke.
880 Use formatting conventions reminiscient of B<B::Debug>; these aren't
885 Use formatting conventions read from the environment variables
886 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
890 =head1 FORMATTING SPECIFICATIONS
892 For each general style ('concise', 'terse', 'linenoise', etc.) there are
893 three specifications: one of how OPs should appear in the basic or exec
894 modes, one of how 'goto' lines should appear (these occur in the exec
895 mode only), and one of how nodes should appear in tree mode. Each has the
896 same format, described below. Any text that doesn't match a special
897 pattern is copied verbatim.
901 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
903 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
905 =item B<(*(>I<text>B<)*)>
907 Generates one copy of I<text> for each indentation level.
909 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
911 Generates one fewer copies of I<text1> than the indentation level, followed
912 by one copy of I<text2> if the indentation level is more than 0.
914 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
916 If the value of I<var> is true (not empty or zero), generates the
917 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
922 Generates the value of the variable I<var>.
926 Generates the value of I<var>, left jutified to fill I<N> spaces.
930 Any number of tildes and surrounding whitespace will be collapsed to
935 The following variables are recognized:
941 The address of the OP, in hexidecimal.
945 The OP-specific information of the OP (such as the SV for an SVOP, the
946 non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
950 The B-determined class of the OP, in all caps.
954 A single symbol abbreviating the class of the OP.
958 The label of the statement or block the OP is the start of, if any.
962 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
966 The target of the OP, or nothing for a nulled OP.
970 The address of the OP's first child, in hexidecimal.
974 The OP's flags, abbreviated as a series of symbols.
978 The numeric value of the OP's flags.
982 The sequence number of the OP, or a hyphen if it doesn't have one.
986 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
987 mode, or empty otherwise.
991 The address of the OP's last child, in hexidecimal.
999 The OP's name, in all caps.
1003 The sequence number of the OP's next OP.
1007 The address of the OP's next OP, in hexidecimal.
1011 A one- or two-character abbreviation for the OP's name.
1015 The OP's private flags, rendered with abbreviated names if possible.
1019 The numeric value of the OP's private flags.
1023 The sequence number of the OP. Note that this is a sequence number
1024 generated by B::Concise.
1028 Whether or not the op has been optimised by the peephole optimiser.
1032 Whether or not the op is statically defined. This flag is used by the
1033 B::C compiler backend and indicates that the op should not be freed.
1037 The address of the OP's next youngest sibling, in hexidecimal.
1041 The address of the OP's SV, if it has an SV, in hexidecimal.
1045 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
1049 The value of the OP's SV, if it has one, in a short human-readable format.
1053 The numeric value of the OP's targ.
1057 The name of the variable the OP's targ refers to, if any, otherwise the
1058 letter t followed by the OP's targ in decimal.
1060 =item B<#targarglife>
1062 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
1063 the variable's lifetime (or 'end' for a variable in an open scope) for a
1068 The numeric value of the OP's type, in decimal.
1072 =head1 ABBREVIATIONS
1074 =head2 OP flags abbreviations
1076 v OPf_WANT_VOID Want nothing (void context)
1077 s OPf_WANT_SCALAR Want single value (scalar context)
1078 l OPf_WANT_LIST Want list of any length (list context)
1079 K OPf_KIDS There is a firstborn child.
1080 P OPf_PARENS This operator was parenthesized.
1081 (Or block needs explicit scope entry.)
1082 R OPf_REF Certified reference.
1083 (Return container, not containee).
1084 M OPf_MOD Will modify (lvalue).
1085 S OPf_STACKED Some arg is arriving on the stack.
1086 * OPf_SPECIAL Do something weird for this op (see op.h)
1088 =head2 OP class abbreviations
1090 0 OP (aka BASEOP) An OP with no children
1091 1 UNOP An OP with one child
1092 2 BINOP An OP with two children
1093 | LOGOP A control branch OP
1094 @ LISTOP An OP that could have lots of children
1095 / PMOP An OP with a regular expression
1096 $ SVOP An OP with an SV
1097 " PVOP An OP with a string
1098 { LOOP An OP that holds pointers for a loop
1099 ; COP An OP that marks the start of a statement
1100 # PADOP An OP with a GV on the pad
1102 =head1 Using B::Concise outside of the O framework
1104 It is possible to extend B<B::Concise> by using it outside of the B<O>
1105 framework and providing new styles and new variables.
1107 use B::Concise qw(set_style add_callback);
1108 set_style($format, $gotofmt, $treefmt);
1113 my ($h, $op, $level, $format) = @_;
1114 $h->{variable} = some_func($op);
1117 B::Concise::compile(@options)->();
1119 You can specify a style by calling the B<set_style> subroutine. If you
1120 have a new variable in your style, or you want to change the value of an
1121 existing variable, you will need to add a callback to specify the value
1124 This is done by calling B<add_callback> passing references to any
1125 callback subroutines. The subroutines are called in the same order as
1126 they are added. Each subroutine is passed four parameters. These are a
1127 reference to a hash, the keys of which are the names of the variables
1128 and the values of which are their values, the op, the level and the
1131 To define your own variables, simply add them to the hash, or change
1132 existing values if you need to. The level and format are passed in as
1133 references to scalars, but it is unlikely that they will need to be
1134 changed or even used.
1136 To switch back to one of the standard styles like C<concise> or
1137 C<terse>, use C<set_style_standard>.
1139 To see the output, call the subroutine returned by B<compile> in the
1140 same way that B<O> does.
1144 Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.