ext/B/B/Concise.pm

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