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         $precomp = defined($precomp) ? "/$precomp/" : "";
 343         my $pmreplroot = $op->pmreplroot;
 344         my ($pmreplroot, $pmreplstart);
 345         if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) {
 346             # with C<@stash_array = split(/pat/, str);>,
 347             #  *stash_array is stored in pmreplroot.
 348             $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
 349         } elsif ($ {$op->pmreplstart}) {
 350             undef $lastnext;
 351             $pmreplstart = "replstart->" . seq($op->pmreplstart);
 352             $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
 353         } else {
 354             $h{arg} = "($precomp)";
 355         }
 356     } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
 357         $h{arg} = '("' . $op->pv . '")';
 358         $h{svval} = '"' . $op->pv . '"';
 359     } elsif ($h{class} eq "COP") {
 360         my $label = $op->label;
 361         $h{coplabel} = $label;
 362         $label = $label ? "$label: " : "";
 363         my $loc = $op->file;
 364         $loc =~ s[.*/][];
 365         $loc .= ":" . $op->line;
 366         my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
 367         my $arybase = $op->arybase;
 368         $arybase = $arybase ? ' $[=' . $arybase : "";
 369         $h{arg} = "($label$stash $cseq $loc$arybase)";
 370     } elsif ($h{class} eq "LOOP") {
 371         $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
 372           . " redo->" . seq($op->redoop) . ")";
 373     } elsif ($h{class} eq "LOGOP") {
 374         undef $lastnext;
 375         $h{arg} = "(other->" . seq($op->other) . ")";
 376     } elsif ($h{class} eq "SVOP") {
 377         my $sv = $op->sv;
 378         $h{svclass} = class($sv);
 379         $h{svaddr} = sprintf("%#x", $$sv);
 380         if ($h{svclass} eq "GV") {
 381             my $gv = $sv;
 382             my $stash = $gv->STASH->NAME;
 383             if ($stash eq "main") {
 384                 $stash = "";
 385             } else {
 386                 $stash = $stash . "::";
 387             }
 388             $h{arg} = "(*$stash" . $gv->SAFENAME . ")";
 389             $h{svval} = "*$stash" . $gv->SAFENAME;
 390         } else {
 391             while (class($sv) eq "RV") {
 392                 $h{svval} .= "\\";
 393                 $sv = $sv->RV;
 394             }
 395             if (class($sv) eq "SPECIAL") {
 396                 $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
 397             } elsif ($sv->FLAGS & SVf_NOK) {
 398                 $h{svval} = $sv->NV;
 399             } elsif ($sv->FLAGS & SVf_IOK) {
 400                 $h{svval} = $sv->IV;
 401             } elsif ($sv->FLAGS & SVf_POK) {
 402                 $h{svval} = cstring($sv->PV);
 403             }
 404             $h{arg} = "($h{svclass} $h{svval})";
 405         }
 406     }
 407     $h{seq} = $h{hyphseq} = seq($op);
 408     $h{seq} = "" if $h{seq} eq "-";
 409     $h{seqnum} = $op->seq;
 410     $h{next} = $op->next;
 411     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
 412     $h{nextaddr} = sprintf("%#x", $ {$op->next});
 413     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
 414     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
 415     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
 416
 417     $h{classsym} = $opclass{$h{class}};
 418     $h{flagval} = $op->flags;
 419     $h{flags} = op_flags($op->flags);
 420     $h{privval} = $op->private;
 421     $h{private} = private_flags($h{name}, $op->private);
 422     $h{addr} = sprintf("%#x", $$op);
 423     $h{label} = $labels{$op->seq};
 424     $h{typenum} = $op->type;
 425     $h{noise} = $linenoise[$op->type];
 426     return fmt_line(\%h, $format, $level);
 427 }
 428
 429 sub B::OP::concise {
 430     my($op, $level) = @_;
 431     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 432         my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
 433                  "addr" => sprintf("%#x", $$lastnext)};
 434         print fmt_line($h, $gotofmt, $level+1);
 435     }
 436     $lastnext = $op->next;
 437     print concise_op($op, $level, $format);
 438 }
 439
 440 sub tree {
 441     my $op = shift;
 442     my $level = shift;
 443     my $style = $tree_decorations[$tree_style];
 444     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
 445     my $name = concise_op($op, $level, $treefmt);
 446     if (not $op->flags & OPf_KIDS) {
 447         return $name . "\n";
 448     }
 449     my @lines;
 450     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
 451         push @lines, tree($kid, $level+1);
 452     }
 453     my $i;
 454     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
 455         $lines[$i] = $space . $lines[$i];
 456     }
 457     if ($i > 0) {
 458         $lines[$i] = $last . $lines[$i];
 459         while ($i-- > 1) {
 460             if (substr($lines[$i], 0, 1) eq " ") {
 461                 $lines[$i] = $nokid . $lines[$i];
 462             } else {
 463                 $lines[$i] = $kid . $lines[$i];
 464             }
 465         }
 466         $lines[$i] = $kids . $lines[$i];
 467     } else {
 468         $lines[0] = $single . $lines[0];
 469     }
 470     return("$name$lead" . shift @lines,
 471            map(" " x (length($name)+$size) . $_, @lines));
 472 }
 473
 474 # This is a bit of a hack; the 2 and 15 were determined empirically.
 475 # These need to stay the last things in the module.
 476 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2;
 477 $seq_base = svref_2object(eval 'sub{}')->START->seq + 15;
 478
 479 1;
 480
 481 __END__
 482
 483 =head1 NAME
 484
 485 B::Concise - Walk Perl syntax tree, printing concise info about ops
 486
 487 =head1 SYNOPSIS
 488
 489     perl -MO=Concise[,OPTIONS] foo.pl
 490
 491 =head1 DESCRIPTION
 492
 493 This compiler backend prints the internal OPs of a Perl program's syntax
 494 tree in one of several space-efficient text formats suitable for debugging
 495 the inner workings of perl or other compiler backends. It can print OPs in
 496 the order they appear in the OP tree, in the order they will execute, or
 497 in a text approximation to their tree structure, and the format of the
 498 information displyed is customizable. Its function is similar to that of
 499 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
 500 sophisticated and flexible.
 501
 502 =head1 OPTIONS
 503
 504 Arguments that don't start with a hyphen are taken to be the names of
 505 subroutines to print the OPs of; if no such functions are specified, the
 506 main body of the program (outside any subroutines, and not including use'd
 507 or require'd files) is printed.
 508
 509 =over 4
 510
 511 =item B<-basic>
 512
 513 Print OPs in the order they appear in the OP tree (a preorder
 514 traversal, starting at the root). The indentation of each OP shows its
 515 level in the tree.  This mode is the default, so the flag is included
 516 simply for completeness.
 517
 518 =item B<-exec>
 519
 520 Print OPs in the order they would normally execute (for the majority
 521 of constructs this is a postorder traversal of the tree, ending at the
 522 root). In most cases the OP that usually follows a given OP will
 523 appear directly below it; alternate paths are shown by indentation. In
 524 cases like loops when control jumps out of a linear path, a 'goto'
 525 line is generated.
 526
 527 =item B<-tree>
 528
 529 Print OPs in a text approximation of a tree, with the root of the tree
 530 at the left and 'left-to-right' order of children transformed into
 531 'top-to-bottom'. Because this mode grows both to the right and down,
 532 it isn't suitable for large programs (unless you have a very wide
 533 terminal).
 534
 535 =item B<-compact>
 536
 537 Use a tree format in which the minimum amount of space is used for the
 538 lines connecting nodes (one character in most cases). This squeezes out
 539 a few precious columns of screen real estate.
 540
 541 =item B<-loose>
 542
 543 Use a tree format that uses longer edges to separate OP nodes. This format
 544 tends to look better than the compact one, especially in ASCII, and is
 545 the default.
 546
 547 =item B<-vt>
 548
 549 Use tree connecting characters drawn from the VT100 line-drawing set.
 550 This looks better if your terminal supports it.
 551
 552 =item B<-ascii>
 553
 554 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
 555 look as clean as the VT100 characters, but they'll work with almost any
 556 terminal (or the horizontal scrolling mode of less(1)) and are suitable
 557 for text documentation or email. This is the default.
 558
 559 =item B<-main>
 560
 561 Include the main program in the output, even if subroutines were also
 562 specified.
 563
 564 =item B<-base>I<n>
 565
 566 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
 567 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
 568 for 37 will be 'A', and so on until 62. Values greater than 62 are not
 569 currently supported. The default is 36.
 570
 571 =item B<-bigendian>
 572
 573 Print sequence numbers with the most significant digit first. This is the
 574 usual convention for Arabic numerals, and the default.
 575
 576 =item B<-littleendian>
 577
 578 Print seqence numbers with the least significant digit first.
 579
 580 =item B<-concise>
 581
 582 Use the author's favorite set of formatting conventions. This is the
 583 default, of course.
 584
 585 =item B<-terse>
 586
 587 Use formatting conventions that emulate the ouput of B<B::Terse>. The
 588 basic mode is almost indistinguishable from the real B<B::Terse>, and the
 589 exec mode looks very similar, but is in a more logical order and lacks
 590 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
 591 is only vaguely reminiscient of B<B::Terse>.
 592
 593 =item B<-linenoise>
 594
 595 Use formatting conventions in which the name of each OP, rather than being
 596 written out in full, is represented by a one- or two-character abbreviation.
 597 This is mainly a joke.
 598
 599 =item B<-debug>
 600
 601 Use formatting conventions reminiscient of B<B::Debug>; these aren't
 602 very concise at all.
 603
 604 =item B<-env>
 605
 606 Use formatting conventions read from the environment variables
 607 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
 608
 609 =back
 610
 611 =head1 FORMATTING SPECIFICATIONS
 612
 613 For each general style ('concise', 'terse', 'linenoise', etc.) there are
 614 three specifications: one of how OPs should appear in the basic or exec
 615 modes, one of how 'goto' lines should appear (these occur in the exec
 616 mode only), and one of how nodes should appear in tree mode. Each has the
 617 same format, described below. Any text that doesn't match a special
 618 pattern is copied verbatim.
 619
 620 =over 4
 621
 622 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
 623
 624 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
 625
 626 =item B<(*(>I<text>B<)*)>
 627
 628 Generates one copy of I<text> for each indentation level.
 629
 630 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
 631
 632 Generates one fewer copies of I<text1> than the indentation level, followed
 633 by one copy of I<text2> if the indentation level is more than 0.
 634
 635 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
 636
 637 If the value of I<var> is true (not empty or zero), generates the
 638 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
 639 nothing.
 640
 641 =item B<#>I<var>
 642
 643 Generates the value of the variable I<var>.
 644
 645 =item B<#>I<var>I<N>
 646
 647 Generates the value of I<var>, left jutified to fill I<N> spaces.
 648
 649 =item B<~>
 650
 651 Any number of tildes and surrounding whitespace will be collapsed to
 652 a single space.
 653
 654 =back
 655
 656 The following variables are recognized:
 657
 658 =over 4
 659
 660 =item B<#addr>
 661
 662 The address of the OP, in hexidecimal.
 663
 664 =item B<#arg>
 665
 666 The OP-specific information of the OP (such as the SV for an SVOP, the
 667 non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
 668
 669 =item B<#class>
 670
 671 The B-determined class of the OP, in all caps.
 672
 673 =item B<#classym>
 674
 675 A single symbol abbreviating the class of the OP.
 676
 677 =item B<#coplabel>
 678
 679 The label of the statement or block the OP is the start of, if any.
 680
 681 =item B<#exname>
 682
 683 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
 684
 685 =item B<#extarg>
 686
 687 The target of the OP, or nothing for a nulled OP.
 688
 689 =item B<#firstaddr>
 690
 691 The address of the OP's first child, in hexidecimal.
 692
 693 =item B<#flags>
 694
 695 The OP's flags, abbreviated as a series of symbols.
 696
 697 =item B<#flagval>
 698
 699 The numeric value of the OP's flags.
 700
 701 =item B<#hyphenseq>
 702
 703 The sequence number of the OP, or a hyphen if it doesn't have one.
 704
 705 =item B<#label>
 706
 707 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
 708 mode, or empty otherwise.
 709
 710 =item B<#lastaddr>
 711
 712 The address of the OP's last child, in hexidecimal.
 713
 714 =item B<#name>
 715
 716 The OP's name.
 717
 718 =item B<#NAME>
 719
 720 The OP's name, in all caps.
 721
 722 =item B<#next>
 723
 724 The sequence number of the OP's next OP.
 725
 726 =item B<#nextaddr>
 727
 728 The address of the OP's next OP, in hexidecimal.
 729
 730 =item B<#noise>
 731
 732 The two-character abbreviation for the OP's name.
 733
 734 =item B<#private>
 735
 736 The OP's private flags, rendered with abbreviated names if possible.
 737
 738 =item B<#privval>
 739
 740 The numeric value of the OP's private flags.
 741
 742 =item B<#seq>
 743
 744 The sequence number of the OP.
 745
 746 =item B<#seqnum>
 747
 748 The real sequence number of the OP, as a regular number and not adjusted
 749 to be relative to the start of the real program. (This will generally be
 750 a fairly large number because all of B<B::Concise> is compiled before
 751 your program is).
 752
 753 =item B<#sibaddr>
 754
 755 The address of the OP's next youngest sibling, in hexidecimal.
 756
 757 =item B<#svaddr>
 758
 759 The address of the OP's SV, if it has an SV, in hexidecimal.
 760
 761 =item B<#svclass>
 762
 763 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
 764
 765 =item B<#svval>
 766
 767 The value of the OP's SV, if it has one, in a short human-readable format.
 768
 769 =item B<#targ>
 770
 771 The numeric value of the OP's targ.
 772
 773 =item B<#targarg>
 774
 775 The name of the variable the OP's targ refers to, if any, otherwise the
 776 letter t followed by the OP's targ in decimal.
 777
 778 =item B<#targarglife>
 779
 780 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
 781 the variable's lifetime (or 'end' for a variable in an open scope) for a
 782 variable.
 783
 784 =item B<#typenum>
 785
 786 The numeric value of the OP's type, in decimal.
 787
 788 =back
 789
 790 =head1 ABBREVIATIONS
 791
 792 =head2 OP flags abbreviations
 793
 794     v      OPf_WANT_VOID    Want nothing (void context)
 795     s      OPf_WANT_SCALAR  Want single value (scalar context)
 796     l      OPf_WANT_LIST    Want list of any length (list context)
 797     K      OPf_KIDS         There is a firstborn child.
 798     P      OPf_PARENS       This operator was parenthesized.
 799                              (Or block needs explicit scope entry.)
 800     R      OPf_REF          Certified reference.
 801                              (Return container, not containee).
 802     M      OPf_MOD          Will modify (lvalue).
 803     S      OPf_STACKED      Some arg is arriving on the stack.
 804     *      OPf_SPECIAL      Do something weird for this op (see op.h)
 805
 806 =head2 OP class abbreviations
 807
 808     0      OP (aka BASEOP)  An OP with no children
 809     1      UNOP             An OP with one child
 810     2      BINOP            An OP with two children
 811     |      LOGOP            A control branch OP
 812     @      LISTOP           An OP that could have lots of children
 813     /      PMOP             An OP with a regular expression
 814     $      SVOP             An OP with an SV
 815     "      PVOP             An OP with a string
 816     {      LOOP             An OP that holds pointers for a loop
 817     ;      COP              An OP that marks the start of a statement
 818
 819 =head1 AUTHOR
 820
 821 Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
 822
 823 =cut