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