ext/B/B/Concise.pm

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