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.50";
   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) pp_#name "
  14     . "(?([#targ])?) #svclass~(?((#svaddr))?)~#svval\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         walk_topdown($op->pmreplroot, $sub, $level + 1);
 194     }
 195 }
 196
 197 sub walklines {
 198     my($ar, $level) = @_;
 199     for my $l (@$ar) {
 200         if (ref($l) eq "ARRAY") {
 201             walklines($l, $level + 1);
 202         } else {
 203             $l->concise($level);
 204         }
 205     }
 206 }
 207
 208 sub walk_exec {
 209     my($top, $level) = @_;
 210     my %opsseen;
 211     my @lines;
 212     my @todo = ([$top, \@lines]);
 213     while (@todo and my($op, $targ) = @{shift @todo}) {
 214         for (; $$op; $op = $op->next) {
 215             last if $opsseen{$$op}++;
 216             push @$targ, $op;
 217             my $name = $op->name;
 218             if ($name
 219                 =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) {
 220                 my $ar = [];
 221                 push @$targ, $ar;
 222                 push @todo, [$op->other, $ar];
 223             } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
 224                 my $ar = [];
 225                 push @$targ, $ar;
 226                 push @todo, [$op->pmreplstart, $ar];
 227             } elsif ($name =~ /^enter(loop|iter)$/) {
 228                 $labels{$op->nextop->seq} = "NEXT";
 229                 $labels{$op->lastop->seq} = "LAST";
 230                 $labels{$op->redoop->seq} = "REDO";
 231             }
 232         }
 233     }
 234     walklines(\@lines, 0);
 235 }
 236
 237 sub fmt_line {
 238     my($hr, $fmt, $level) = @_;
 239     my $text = $fmt;
 240     $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
 241       $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
 242     $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
 243     $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
 244     $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
 245     $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
 246     $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg;
 247     $text =~ s/[ \t]*~+[ \t]*/ /g;
 248     return $text;
 249 }
 250
 251 my %priv;
 252 $priv{$_}{128} = "LVINTRO"
 253   for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
 254        "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
 255        "padav", "padhv");
 256 $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
 257 $priv{"aassign"}{64} = "COMMON";
 258 $priv{"aassign"}{32} = "PHASH";
 259 $priv{"sassign"}{64} = "BKWARD";
 260 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont");
 261 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
 262                                     "COMPL", "GROWS");
 263 $priv{"repeat"}{64} = "DOLIST";
 264 $priv{"leaveloop"}{64} = "CONT";
 265 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
 266   for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem");
 267 $priv{"entersub"}{16} = "DBG";
 268 $priv{"entersub"}{32} = "TARG";
 269 @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
 270 $priv{"gv"}{32} = "EARLYCV";
 271 $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
 272 $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv");
 273 $priv{$_}{16} = "TARGMY"
 274   for (map(($_,"s$_"),"chop", "chomp"),
 275        map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
 276            "add", "subtract", "negate"), "pow", "concat", "stringify",
 277        "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
 278        "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
 279        "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
 280        "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
 281        "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
 282        "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
 283        "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
 284        "setpriority", "time", "sleep");
 285 @{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN");
 286 $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
 287 $priv{"list"}{64} = "GUESSED";
 288 $priv{"delete"}{64} = "SLICE";
 289 $priv{"exists"}{64} = "SUB";
 290 $priv{$_}{64} = "LOCALE"
 291   for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
 292        "scmp", "lc", "uc", "lcfirst", "ucfirst");
 293 @{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV");
 294 $priv{"threadsv"}{64} = "SVREFd";
 295 $priv{$_}{16} = "INBIN" for ("open", "backtick");
 296 $priv{$_}{32} = "INCR" for ("open", "backtick");
 297 $priv{$_}{64} = "OUTBIN" for ("open", "backtick");
 298 $priv{$_}{128} = "OUTCR" for ("open", "backtick");
 299 $priv{"exit"}{128} = "VMS";
 300
 301 sub private_flags {
 302     my($name, $x) = @_;
 303     my @s;
 304     for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
 305         if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
 306             $x -= $flag;
 307             push @s, $priv{$name}{$flag};
 308         }
 309     }
 310     push @s, $x if $x;
 311     return join(",", @s);
 312 }
 313
 314 sub concise_op {
 315     my ($op, $level, $format) = @_;
 316     my %h;
 317     $h{exname} = $h{name} = $op->name;
 318     $h{NAME} = uc $h{name};
 319     $h{class} = class($op);
 320     $h{extarg} = $h{targ} = $op->targ;
 321     $h{extarg} = "" unless $h{extarg};
 322     if ($h{name} eq "null" and $h{targ}) {
 323         $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
 324         $h{extarg} = "";
 325     } elsif ($h{targ}) {
 326         my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
 327         if (defined $padname and class($padname) ne "SPECIAL") {
 328             $h{targarg}  = $padname->PV;
 329             my $intro = $padname->NVX - $cop_seq_base;
 330             my $finish = int($padname->IVX) - $cop_seq_base;
 331             $finish = "end" if $finish == 999999999 - $cop_seq_base;
 332             $h{targarglife} = "$h{targarg}:$intro,$finish";
 333         } else {
 334             $h{targarglife} = $h{targarg} = "t" . $h{targ};
 335         }
 336     }
 337     $h{arg} = "";
 338     $h{svclass} = $h{svaddr} = $h{svval} = "";
 339     if ($h{class} eq "PMOP") {
 340         my $precomp = $op->precomp;
 341         $precomp = defined($precomp) ? "/$precomp/" : "";
 342         my $pmreplstart;
 343         if ($ {$op->pmreplstart}) {
 344             undef $lastnext;
 345             $pmreplstart = "replstart->" . seq($op->pmreplstart);
 346             $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
 347         } else {
 348             $h{arg} = "($precomp)";
 349         }
 350     } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
 351         $h{arg} = '("' . $op->pv . '")';
 352         $h{svval} = '"' . $op->pv . '"';
 353     } elsif ($h{class} eq "COP") {
 354         my $label = $op->label;
 355         $label = $label ? "$label: " : "";
 356         my $loc = $op->file;
 357         $loc =~ s[.*/][];
 358         $loc .= ":" . $op->line;
 359         my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
 360         my $arybase = $op->arybase;
 361         $arybase = $arybase ? ' $[=' . $arybase : "";
 362         $h{arg} = "($label$stash $cseq $loc$arybase)";
 363     } elsif ($h{class} eq "LOOP") {
 364         $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
 365           . " redo->" . seq($op->redoop) . ")";
 366     } elsif ($h{class} eq "LOGOP") {
 367         undef $lastnext;
 368         $h{arg} = "(other->" . seq($op->other) . ")";
 369     } elsif ($h{class} eq "SVOP") {
 370         my $sv = $op->sv;
 371         $h{svclass} = class($sv);
 372         $h{svaddr} = sprintf("%#x", $$sv);
 373         if ($h{svclass} eq "GV") {
 374             my $gv = $sv;
 375             my $stash = $gv->STASH->NAME;
 376             if ($stash eq "main") {
 377                 $stash = "";
 378             } else {
 379                 $stash = $stash . "::";
 380             }
 381             $h{arg} = "(*$stash" . $gv->NAME . ")";
 382             $h{svval} = "*$stash" . $gv->NAME;
 383         } else {
 384             while (class($sv) eq "RV") {
 385                 $h{svval} .= "\\";
 386                 $sv = $sv->RV;
 387             }
 388             if (class($sv) eq "SPECIAL") {
 389                 $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
 390             } elsif ($sv->FLAGS & SVf_NOK) {
 391                 $h{svval} = $sv->NV;
 392             } elsif ($sv->FLAGS & SVf_IOK) {
 393                 $h{svval} = $sv->IV;
 394             } elsif ($sv->FLAGS & SVf_POK) {
 395                 $h{svval} = cstring($sv->PV);
 396             }
 397             $h{arg} = "($h{svclass} $h{svval})";
 398         }
 399     }
 400     $h{seq} = $h{hyphseq} = seq($op);
 401     $h{seq} = "" if $h{seq} eq "-";
 402     $h{seqnum} = $op->seq;
 403     $h{next} = $op->next;
 404     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
 405     $h{nextaddr} = sprintf("%#x", $ {$op->next});
 406     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
 407     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
 408     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
 409
 410     $h{classsym} = $opclass{$h{class}};
 411     $h{flagval} = $op->flags;
 412     $h{flags} = op_flags($op->flags);
 413     $h{privval} = $op->private;
 414     $h{private} = private_flags($h{name}, $op->private);
 415     $h{addr} = sprintf("%#x", $$op);
 416     $h{label} = $labels{$op->seq};
 417     $h{typenum} = $op->type;
 418     $h{noise} = $linenoise[$op->type];
 419     return fmt_line(\%h, $format, $level);
 420 }
 421
 422 sub B::OP::concise {
 423     my($op, $level) = @_;
 424     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
 425         my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
 426                  "addr" => sprintf("%#x", $$lastnext)};
 427         print fmt_line($h, $gotofmt, $level+1);
 428     }
 429     $lastnext = $op->next;
 430     print concise_op($op, $level, $format);
 431 }
 432
 433 sub tree {
 434     my $op = shift;
 435     my $level = shift;
 436     my $style = $tree_decorations[$tree_style];
 437     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
 438     my $name = concise_op($op, $level, $treefmt);
 439     if (not $op->flags & OPf_KIDS) {
 440         return $name . "\n";
 441     }
 442     my @lines;
 443     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
 444         push @lines, tree($kid, $level+1);
 445     }
 446     my $i;
 447     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
 448         $lines[$i] = $space . $lines[$i];
 449     }
 450     if ($i > 0) {
 451         $lines[$i] = $last . $lines[$i];
 452         while ($i-- > 1) {
 453             if (substr($lines[$i], 0, 1) eq " ") {
 454                 $lines[$i] = $nokid . $lines[$i];
 455             } else {
 456                 $lines[$i] = $kid . $lines[$i];
 457             }
 458         }
 459         $lines[$i] = $kids . $lines[$i];
 460     } else {
 461         $lines[0] = $single . $lines[0];
 462     }
 463     return("$name$lead" . shift @lines,
 464            map(" " x (length($name)+$size) . $_, @lines));
 465 }
 466
 467 # This is a bit of a hack; the 2 and 15 were determined empirically.
 468 # These need to stay the last things in the module.
 469 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2;
 470 $seq_base = svref_2object(eval 'sub{}')->START->seq + 15;
 471
 472 1;
 473
 474 __END__
 475
 476 =head1 NAME
 477
 478 B::Concise - Walk Perl syntax tree, printing concise info about ops
 479
 480 =head1 SYNOPSIS
 481
 482     perl -MO=Concise[,OPTIONS] foo.pl
 483
 484 =head1 DESCRIPTION
 485
 486 This compiler backend prints the internal OPs of a Perl program's syntax
 487 tree in one of several space-efficient text formats suitable for debugging
 488 the inner workings of perl or other compiler backends. It can print OPs in
 489 the order they appear in the OP tree, in the order they will execute, or
 490 in a text approximation to their tree structure, and the format of the
 491 information displyed is customizable. Its function is similar to that of
 492 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
 493 sophisticated and flexible.
 494
 495 =head1 OPTIONS
 496
 497 Arguments that don't start with a hyphen are taken to be the names of
 498 subroutines to print the OPs of; if no such functions are specified, the
 499 main body of the program (outside any subroutines, and not including use'd
 500 or require'd files) is printed.
 501
 502 =over 4
 503
 504 =item B<-basic>
 505
 506 Print OPs in the order they appear in the OP tree (a preorder
 507 traversal, starting at the root). The indentation of each OP shows its
 508 level in the tree.  This mode is the default, so the flag is included
 509 simply for completeness.
 510
 511 =item B<-exec>
 512
 513 Print OPs in the order they would normally execute (for the majority
 514 of constructs this is a postorder traversal of the tree, ending at the
 515 root). In most cases the OP that usually follows a given OP will
 516 appear directly below it; alternate paths are shown by indentation. In
 517 cases like loops when control jumps out of a linear path, a 'goto'
 518 line is generated.
 519
 520 =item B<-tree>
 521
 522 Print OPs in a text approximation of a tree, with the root of the tree
 523 at the left and 'left-to-right' order of children transformed into
 524 'top-to-bottom'. Because this mode grows both to the right and down,
 525 it isn't suitable for large programs (unless you have a very wide
 526 terminal).
 527
 528 =item B<-compact>
 529
 530 Use a tree format in which the minimum amount of space is used for the
 531 lines connecting nodes (one character in most cases). This squeezes out
 532 a few precious columns of screen real estate.
 533
 534 =item B<-loose>
 535
 536 Use a tree format that uses longer edges to separate OP nodes. This format
 537 tends to look better than the compact one, especially in ASCII, and is
 538 the default.
 539
 540 =item B<-vt>
 541
 542 Use tree connecting characters drawn from the VT100 line-drawing set.
 543 This looks better if your terminal supports it.
 544
 545 =item B<-ascii>
 546
 547 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
 548 look as clean as the VT100 characters, but they'll work with almost any
 549 terminal (or the horizontal scrolling mode of less(1)) and are suitable
 550 for text documentation or email. This is the default.
 551
 552 =item B<-main>
 553
 554 Include the main program in the output, even if subroutines were also
 555 specified.
 556
 557 =item B<-base>I<n>
 558
 559 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
 560 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
 561 for 37 will be 'A', and so on until 62. Values greater than 62 are not
 562 currently supported. The default is 36.
 563
 564 =item B<-bigendian>
 565
 566 Print sequence numbers with the most significant digit first. This is the
 567 usual convention for Arabic numerals, and the default.
 568
 569 =item B<-littleendian>
 570
 571 Print seqence numbers with the least significant digit first.
 572
 573 =item B<-concise>
 574
 575 Use the author's favorite set of formatting conventions. This is the
 576 default, of course.
 577
 578 =item B<-terse>
 579
 580 Use formatting conventions that emulate the ouput of B<B::Terse>. The
 581 basic mode is almost indistinguishable from the real B<B::Terse>, and the
 582 exec mode looks very similar, but is in a more logical order and lacks
 583 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
 584 is only vaguely reminiscient of B<B::Terse>.
 585
 586 =item B<-linenoise>
 587
 588 Use formatting conventions in which the name of each OP, rather than being
 589 written out in full, is represented by a one- or two-character abbreviation.
 590 This is mainly a joke.
 591
 592 =item B<-debug>
 593
 594 Use formatting conventions reminiscient of B<B::Debug>; these aren't
 595 very concise at all.
 596
 597 =item B<-env>
 598
 599 Use formatting conventions read from the environment variables
 600 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
 601
 602 =back
 603
 604 =head1 FORMATTING SPECIFICATIONS
 605
 606 For each general style ('concise', 'terse', 'linenoise', etc.) there are
 607 three specifications: one of how OPs should appear in the basic or exec
 608 modes, one of how 'goto' lines should appear (these occur in the exec
 609 mode only), and one of how nodes should appear in tree mode. Each has the
 610 same format, described below. Any text that doesn't match a special
 611 pattern is copied verbatim.
 612
 613 =over 4
 614
 615 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
 616
 617 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
 618
 619 =item B<(*(>I<text>B<)*)>
 620
 621 Generates one copy of I<text> for each indentation level.
 622
 623 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
 624
 625 Generates one fewer copies of I<text1> than the indentation level, followed
 626 by one copy of I<text2> if the indentation level is more than 0.
 627
 628 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
 629
 630 If the value of I<var> is true (not empty or zero), generates the
 631 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
 632 nothing.
 633
 634 =item B<#>I<var>
 635
 636 Generates the value of the variable I<var>.
 637
 638 =item B<#>I<var>I<N>
 639
 640 Generates the value of I<var>, left jutified to fill I<N> spaces.
 641
 642 =item B<~>
 643
 644 Any number of tildes and surrounding whitespace will be collapsed to
 645 a single space.
 646
 647 =back
 648
 649 The following variables are recognized:
 650
 651 =over 4
 652
 653 =item B<#addr>
 654
 655 The address of the OP, in hexidecimal.
 656
 657 =item B<#arg>
 658
 659 The OP-specific information of the OP (such as the SV for an SVOP, the
 660 non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
 661
 662 =item B<#class>
 663
 664 The B-determined class of the OP, in all caps.
 665
 666 =item B<#classym>
 667
 668 A single symbol abbreviating the class of the OP.
 669
 670 =item B<#exname>
 671
 672 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
 673
 674 =item B<#extarg>
 675
 676 The target of the OP, or nothing for a nulled OP.
 677
 678 =item B<#firstaddr>
 679
 680 The address of the OP's first child, in hexidecimal.
 681
 682 =item B<#flags>
 683
 684 The OP's flags, abbreviated as a series of symbols.
 685
 686 =item B<#flagval>
 687
 688 The numeric value of the OP's flags.
 689
 690 =item B<#hyphenseq>
 691
 692 The sequence number of the OP, or a hyphen if it doesn't have one.
 693
 694 =item B<#label>
 695
 696 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
 697 mode, or empty otherwise.
 698
 699 =item B<#lastaddr>
 700
 701 The address of the OP's last child, in hexidecimal.
 702
 703 =item B<#name>
 704
 705 The OP's name.
 706
 707 =item B<#NAME>
 708
 709 The OP's name, in all caps.
 710
 711 =item B<#next>
 712
 713 The sequence number of the OP's next OP.
 714
 715 =item B<#nextaddr>
 716
 717 The address of the OP's next OP, in hexidecimal.
 718
 719 =item B<#noise>
 720
 721 The two-character abbreviation for the OP's name.
 722
 723 =item B<#private>
 724
 725 The OP's private flags, rendered with abbreviated names if possible.
 726
 727 =item B<#privval>
 728
 729 The numeric value of the OP's private flags.
 730
 731 =item B<#seq>
 732
 733 The sequence number of the OP.
 734
 735 =item B<#seqnum>
 736
 737 The real sequence number of the OP, as a regular number and not adjusted
 738 to be relative to the start of the real program. (This will generally be
 739 a fairly large number because all of B<B::Concise> is compiled before
 740 your program is).
 741
 742 =item B<#sibaddr>
 743
 744 The address of the OP's next youngest sibling, in hexidecimal.
 745
 746 =item B<#svaddr>
 747
 748 The address of the OP's SV, if it has an SV, in hexidecimal.
 749
 750 =item B<#svclass>
 751
 752 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
 753
 754 =item B<#svval>
 755
 756 The value of the OP's SV, if it has one, in a short human-readable format.
 757
 758 =item B<#targ>
 759
 760 The numeric value of the OP's targ.
 761
 762 =item B<#targarg>
 763
 764 The name of the variable the OP's targ refers to, if any, otherwise the
 765 letter t followed by the OP's targ in decimal.
 766
 767 =item B<#targarglife>
 768
 769 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
 770 the variable's lifetime (or 'end' for a variable in an open scope) for a
 771 variable.
 772
 773 =item B<#typenum>
 774
 775 The numeric value of the OP's type, in decimal.
 776
 777 =back
 778
 779 =head1 ABBREVIATIONS
 780
 781 =head2 OP flags abbreviations
 782
 783     v      OPf_WANT_VOID    Want nothing (void context)
 784     s      OPf_WANT_SCALAR  Want single value (scalar context)
 785     l      OPf_WANT_LIST    Want list of any length (list context)
 786     K      OPf_KIDS         There is a firstborn child.
 787     P      OPf_PARENS       This operator was parenthesized.
 788                              (Or block needs explicit scope entry.)
 789     R      OPf_REF          Certified reference.
 790                              (Return container, not containee).
 791     M      OPf_MOD          Will modify (lvalue).
 792     S      OPf_STACKED      Some arg is arriving on the stack.
 793     *      OPf_SPECIAL      Do something weird for this op (see op.h)
 794
 795 =head2 OP class abbreviations
 796
 797     0      OP (aka BASEOP)  An OP with no children
 798     1      UNOP             An OP with one child
 799     2      BINOP            An OP with two children
 800     |      LOGOP            A control branch OP
 801     @      LISTOP           An OP that could have lots of children
 802     /      PMOP             An OP with a regular expression
 803     $      SVOP             An OP with an SV
 804     "      PVOP             An OP with a string
 805     {      LOOP             An OP that holds pointers for a loop
 806     ;      COP              An OP that marks the start of a statement
 807
 808 =head1 AUTHOR
 809
 810 Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
 811
 812 =cut