ext/B/B/Concise.pm

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