From: Stephen McCamant Date: Sat, 6 Jan 2001 20:18:05 +0000 (-0800) Subject: B::Concise -- an improved replacement for B::Terse X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c99ca59a5ccc5001ce682c48b817515fa72f07ab;p=p5sagit%2Fp5-mst-13.2.git B::Concise -- an improved replacement for B::Terse Message-ID: <14935.43597.962940.803717@soda.csua.berkeley.edu> p4raw-id: //depot/perl@8424 --- diff --git a/MANIFEST b/MANIFEST index 18ae760..b948d38 100644 --- a/MANIFEST +++ b/MANIFEST @@ -111,6 +111,7 @@ ext/B/B/Bblock.pm Compiler basic block analysis support ext/B/B/Bytecode.pm Compiler Bytecode backend ext/B/B/C.pm Compiler C backend ext/B/B/CC.pm Compiler CC backend +ext/B/B/Concise.pm Compiler Concise backend ext/B/B/Debug.pm Compiler Debug backend ext/B/B/Deparse.pm Compiler Deparse backend ext/B/B/Disassembler.pm Compiler Disassembler backend diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm new file mode 100644 index 0000000..9f53955 --- /dev/null +++ b/ext/B/B/Concise.pm @@ -0,0 +1,812 @@ +package B::Concise; +# Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved. +# This program is free software; you can redistribute and/or modify it +# under the same terms as Perl itself. + +our $VERSION = "0.50"; +use strict; +use B qw(class ppname main_start main_root main_cv cstring svref_2object + SVf_IOK SVf_NOK SVf_POK OPf_KIDS); + +my %style = + ("terse" => + ["(?(#label =>\n)?)(*( )*)#class (#addr) pp_#name " + . "(?([#targ])?) #svclass~(?((#svaddr))?)~#svval\n", + "(*( )*)goto #class (#addr)\n", + "#class pp_#name"], + "concise" => + ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", + " (*( )*) goto #seq\n", + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], + "linenoise" => + ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", + "gt_#seq ", + "(?(#seq)?)#noise#arg(?([#targarg])?)"], + "debug" => + ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" + . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" + . "(?(\top_sv\t\t#svaddr\n)?)", + " GOTO #addr\n", + "#addr"], + "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, + $ENV{B_CONCISE_TREE_FORMAT}], + ); + +my($format, $gotofmt, $treefmt); +my $curcv; +my($seq_base, $cop_seq_base); + +sub concise_cv { + my ($order, $cvref) = @_; + my $cv = svref_2object($cvref); + $curcv = $cv; + if ($order eq "exec") { + walk_exec($cv->START); + } elsif ($order eq "basic") { + walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); + } else { + print tree($cv->ROOT, 0) + } +} + +my $start_sym = "\e(0"; # "\cN" sometimes also works +my $end_sym = "\e(B"; # "\cO" respectively + +my @tree_decorations = + ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], + [" ", "-", "+", "+", "|", "`", "", 0], + [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], + [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], + ); +my $tree_style = 0; + +my $base = 36; +my $big_endian = 1; + +my $order = "basic"; + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + my $do_main = 0; + ($format, $gotofmt, $treefmt) = @{$style{"concise"}}; + for my $o (@options) { + if ($o eq "-basic") { + $order = "basic"; + } elsif ($o eq "-exec") { + $order = "exec"; + } elsif ($o eq "-tree") { + $order = "tree"; + } elsif ($o eq "-compact") { + $tree_style |= 1; + } elsif ($o eq "-loose") { + $tree_style &= ~1; + } elsif ($o eq "-vt") { + $tree_style |= 2; + } elsif ($o eq "-ascii") { + $tree_style &= ~2; + } elsif ($o eq "-main") { + $do_main = 1; + } elsif ($o =~ /^-base(\d+)$/) { + $base = $1; + } elsif ($o eq "-bigendian") { + $big_endian = 1; + } elsif ($o eq "-littleendian") { + $big_endian = 0; + } elsif (exists $style{substr($o, 1)}) { + ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}}; + } else { + warn "Option $o unrecognized"; + } + } + if (@args) { + return sub { + for my $objname (@args) { + $objname = "main::" . $objname unless $objname =~ /::/; + eval "concise_cv(\$order, \\&$objname)"; + die "concise_cv($order, \\&$objname) failed: $@" if $@; + } + } + } + if (!@args or $do_main) { + if ($order eq "exec") { + return sub { return if class(main_start) eq "NULL"; + $curcv = main_cv; + walk_exec(main_start) } + } elsif ($order eq "tree") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + print tree(main_root, 0) } + } elsif ($order eq "basic") { + return sub { return if class(main_root) eq "NULL"; + $curcv = main_cv; + walk_topdown(main_root, + sub { $_[0]->concise($_[1]) }, 0); } + } + } +} + +my %labels; +my $lastnext; + +my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", + 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", + 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";"); + +my @linenoise = + qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl + ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I + -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< + > i> <= i, >= i. == i= != i! s, s. s= s! s? b& b^ b| -0 -i + ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy + uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ + a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} + v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o + ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v + ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r + -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd + co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 + g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e + e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn + Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>'; + +my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; + +sub op_flags { + my($x) = @_; + my(@v); + push @v, "v" if ($x & 3) == 1; + push @v, "s" if ($x & 3) == 2; + push @v, "l" if ($x & 3) == 3; + push @v, "K" if $x & 4; + push @v, "P" if $x & 8; + push @v, "R" if $x & 16; + push @v, "M" if $x & 32; + push @v, "S" if $x & 64; + push @v, "*" if $x & 128; + return join("", @v); +} + +sub base_n { + my $x = shift; + return "-" . base_n(-$x) if $x < 0; + my $str = ""; + do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); + $str = reverse $str if $big_endian; + return $str; +} + +sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" } + +sub walk_topdown { + my($op, $sub, $level) = @_; + $sub->($op, $level); + if ($op->flags & OPf_KIDS) { + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + walk_topdown($kid, $sub, $level + 1); + } + } + if (class($op) eq "PMOP" and $ {$op->pmreplroot}) { + walk_topdown($op->pmreplroot, $sub, $level + 1); + } +} + +sub walklines { + my($ar, $level) = @_; + for my $l (@$ar) { + if (ref($l) eq "ARRAY") { + walklines($l, $level + 1); + } else { + $l->concise($level); + } + } +} + +sub walk_exec { + my($top, $level) = @_; + my %opsseen; + my @lines; + my @todo = ([$top, \@lines]); + while (@todo and my($op, $targ) = @{shift @todo}) { + for (; $$op; $op = $op->next) { + last if $opsseen{$$op}++; + push @$targ, $op; + my $name = $op->name; + if ($name + =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->other, $ar]; + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->pmreplstart, $ar]; + } elsif ($name =~ /^enter(loop|iter)$/) { + $labels{$op->nextop->seq} = "NEXT"; + $labels{$op->lastop->seq} = "LAST"; + $labels{$op->redoop->seq} = "REDO"; + } + } + } + walklines(\@lines, 0); +} + +sub fmt_line { + my($hr, $fmt, $level) = @_; + my $text = $fmt; + $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ + $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; + $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; + $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; + $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; + $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; + $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg; + $text =~ s/[ \t]*~+[ \t]*/ /g; + return $text; +} + +my %priv; +$priv{$_}{128} = "LVINTRO" + for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", + "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", + "padav", "padhv"); +$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); +$priv{"aassign"}{64} = "COMMON"; +$priv{"aassign"}{32} = "PHASH"; +$priv{"sassign"}{64} = "BKWARD"; +$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont"); +@{$priv{"trans"}}{1,2,4,8,16,64} = ("UTF", "IDENT", "SQUASH", "DEL", + "COMPL", "GROWS"); +$priv{"repeat"}{64} = "DOLIST"; +$priv{"leaveloop"}{64} = "CONT"; +@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") + for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem"); +$priv{"entersub"}{16} = "DBG"; +$priv{"entersub"}{32} = "TARG"; +@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); +$priv{"gv"}{32} = "EARLYCV"; +$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; +$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv"); +$priv{$_}{16} = "TARGMY" + for (map(($_,"s$_"),"chop", "chomp"), + map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", + "add", "subtract", "negate"), "pow", "concat", "stringify", + "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", + "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", + "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", + "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", + "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", + "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", + "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", + "setpriority", "time", "sleep"); +@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN"); +$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; +$priv{"list"}{64} = "GUESSED"; +$priv{"delete"}{64} = "SLICE"; +$priv{"exists"}{64} = "SUB"; +$priv{$_}{64} = "LOCALE" + for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", + "scmp", "lc", "uc", "lcfirst", "ucfirst"); +@{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV"); +$priv{"threadsv"}{64} = "SVREFd"; +$priv{$_}{16} = "INBIN" for ("open", "backtick"); +$priv{$_}{32} = "INCR" for ("open", "backtick"); +$priv{$_}{64} = "OUTBIN" for ("open", "backtick"); +$priv{$_}{128} = "OUTCR" for ("open", "backtick"); +$priv{"exit"}{128} = "VMS"; + +sub private_flags { + my($name, $x) = @_; + my @s; + for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { + if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { + $x -= $flag; + push @s, $priv{$name}{$flag}; + } + } + push @s, $x if $x; + return join(",", @s); +} + +sub concise_op { + my ($op, $level, $format) = @_; + my %h; + $h{exname} = $h{name} = $op->name; + $h{NAME} = uc $h{name}; + $h{class} = class($op); + $h{extarg} = $h{targ} = $op->targ; + $h{extarg} = "" unless $h{extarg}; + if ($h{name} eq "null" and $h{targ}) { + $h{exname} = "ex-" . substr(ppname($h{targ}), 3); + $h{extarg} = ""; + } elsif ($h{targ}) { + my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; + if (defined $padname and class($padname) ne "SPECIAL") { + $h{targarg} = $padname->PV; + my $intro = $padname->NVX - $cop_seq_base; + my $finish = int($padname->IVX) - $cop_seq_base; + $finish = "end" if $finish == 999999999 - $cop_seq_base; + $h{targarglife} = "$h{targarg}:$intro,$finish"; + } else { + $h{targarglife} = $h{targarg} = "t" . $h{targ}; + } + } + $h{arg} = ""; + $h{svclass} = $h{svaddr} = $h{svval} = ""; + if ($h{class} eq "PMOP") { + my $precomp = $op->precomp; + $precomp = defined($precomp) ? "/$precomp/" : ""; + my $pmreplstart; + if ($ {$op->pmreplstart}) { + undef $lastnext; + $pmreplstart = "replstart->" . seq($op->pmreplstart); + $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; + } else { + $h{arg} = "($precomp)"; + } + } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { + $h{arg} = '("' . $op->pv . '")'; + $h{svval} = '"' . $op->pv . '"'; + } elsif ($h{class} eq "COP") { + my $label = $op->label; + $label = $label ? "$label: " : ""; + my $loc = $op->file; + $loc =~ s[.*/][]; + $loc .= ":" . $op->line; + my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); + my $arybase = $op->arybase; + $arybase = $arybase ? ' $[=' . $arybase : ""; + $h{arg} = "($label$stash $cseq $loc$arybase)"; + } elsif ($h{class} eq "LOOP") { + $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) + . " redo->" . seq($op->redoop) . ")"; + } elsif ($h{class} eq "LOGOP") { + undef $lastnext; + $h{arg} = "(other->" . seq($op->other) . ")"; + } elsif ($h{class} eq "SVOP") { + my $sv = $op->sv; + $h{svclass} = class($sv); + $h{svaddr} = sprintf("%#x", $$sv); + if ($h{svclass} eq "GV") { + my $gv = $sv; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + $h{arg} = "(*$stash" . $gv->NAME . ")"; + $h{svval} = "*$stash" . $gv->NAME; + } else { + while (class($sv) eq "RV") { + $h{svval} .= "\\"; + $sv = $sv->RV; + } + if (class($sv) eq "SPECIAL") { + $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + } elsif ($sv->FLAGS & SVf_NOK) { + $h{svval} = $sv->NV; + } elsif ($sv->FLAGS & SVf_IOK) { + $h{svval} = $sv->IV; + } elsif ($sv->FLAGS & SVf_POK) { + $h{svval} = cstring($sv->PV); + } + $h{arg} = "($h{svclass} $h{svval})"; + } + } + $h{seq} = $h{hyphseq} = seq($op); + $h{seq} = "" if $h{seq} eq "-"; + $h{seqnum} = $op->seq; + $h{next} = $op->next; + $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); + $h{nextaddr} = sprintf("%#x", $ {$op->next}); + $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); + $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); + $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); + + $h{classsym} = $opclass{$h{class}}; + $h{flagval} = $op->flags; + $h{flags} = op_flags($op->flags); + $h{privval} = $op->private; + $h{private} = private_flags($h{name}, $op->private); + $h{addr} = sprintf("%#x", $$op); + $h{label} = $labels{$op->seq}; + $h{typenum} = $op->type; + $h{noise} = $linenoise[$op->type]; + return fmt_line(\%h, $format, $level); +} + +sub B::OP::concise { + my($op, $level) = @_; + if ($order eq "exec" and $lastnext and $$lastnext != $$op) { + my $h = {"seq" => seq($lastnext), "class" => class($lastnext), + "addr" => sprintf("%#x", $$lastnext)}; + print fmt_line($h, $gotofmt, $level+1); + } + $lastnext = $op->next; + print concise_op($op, $level, $format); +} + +sub tree { + my $op = shift; + my $level = shift; + my $style = $tree_decorations[$tree_style]; + my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; + my $name = concise_op($op, $level, $treefmt); + if (not $op->flags & OPf_KIDS) { + return $name . "\n"; + } + my @lines; + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + push @lines, tree($kid, $level+1); + } + my $i; + for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { + $lines[$i] = $space . $lines[$i]; + } + if ($i > 0) { + $lines[$i] = $last . $lines[$i]; + while ($i-- > 1) { + if (substr($lines[$i], 0, 1) eq " ") { + $lines[$i] = $nokid . $lines[$i]; + } else { + $lines[$i] = $kid . $lines[$i]; + } + } + $lines[$i] = $kids . $lines[$i]; + } else { + $lines[0] = $single . $lines[0]; + } + return("$name$lead" . shift @lines, + map(" " x (length($name)+$size) . $_, @lines)); +} + +# This is a bit of a hack; the 2 and 15 were determined empirically. +# These need to stay the last things in the module. +$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2; +$seq_base = svref_2object(eval 'sub{}')->START->seq + 15; + +1; + +__END__ + +=head1 NAME + +B::Concise - Walk Perl syntax tree, printing concise info about ops + +=head1 SYNOPSIS + + perl -MO=Concise[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend prints the internal OPs of a Perl program's syntax +tree in one of several space-efficient text formats suitable for debugging +the inner workings of perl or other compiler backends. It can print OPs in +the order they appear in the OP tree, in the order they will execute, or +in a text approximation to their tree structure, and the format of the +information displyed is customizable. Its function is similar to that of +perl's B<-Dx> debugging flag or the B module, but it is more +sophisticated and flexible. + +=head1 OPTIONS + +Arguments that don't start with a hyphen are taken to be the names of +subroutines to print the OPs of; if no such functions are specified, the +main body of the program (outside any subroutines, and not including use'd +or require'd files) is printed. + +=over 4 + +=item B<-basic> + +Print OPs in the order they appear in the OP tree (a preorder +traversal, starting at the root). The indentation of each OP shows its +level in the tree. This mode is the default, so the flag is included +simply for completeness. + +=item B<-exec> + +Print OPs in the order they would normally execute (for the majority +of constructs this is a postorder traversal of the tree, ending at the +root). In most cases the OP that usually follows a given OP will +appear directly below it; alternate paths are shown by indentation. In +cases like loops when control jumps out of a linear path, a 'goto' +line is generated. + +=item B<-tree> + +Print OPs in a text approximation of a tree, with the root of the tree +at the left and 'left-to-right' order of children transformed into +'top-to-bottom'. Because this mode grows both to the right and down, +it isn't suitable for large programs (unless you have a very wide +terminal). + +=item B<-compact> + +Use a tree format in which the minimum amount of space is used for the +lines connecting nodes (one character in most cases). This squeezes out +a few precious columns of screen real estate. + +=item B<-loose> + +Use a tree format that uses longer edges to separate OP nodes. This format +tends to look better than the compact one, especially in ASCII, and is +the default. + +=item B<-vt> + +Use tree connecting characters drawn from the VT100 line-drawing set. +This looks better if your terminal supports it. + +=item B<-ascii> + +Draw the tree with standard ASCII characters like C<+> and C<|>. These don't +look as clean as the VT100 characters, but they'll work with almost any +terminal (or the horizontal scrolling mode of less(1)) and are suitable +for text documentation or email. This is the default. + +=item B<-main> + +Include the main program in the output, even if subroutines were also +specified. + +=item B<-base>I + +Print OP sequence numbers in base I. If I is greater than 10, the +digit for 11 will be 'a', and so on. If I is greater than 36, the digit +for 37 will be 'A', and so on until 62. Values greater than 62 are not +currently supported. The default is 36. + +=item B<-bigendian> + +Print sequence numbers with the most significant digit first. This is the +usual convention for Arabic numerals, and the default. + +=item B<-littleendian> + +Print seqence numbers with the least significant digit first. + +=item B<-concise> + +Use the author's favorite set of formatting conventions. This is the +default, of course. + +=item B<-terse> + +Use formatting conventions that emulate the ouput of B. The +basic mode is almost indistinguishable from the real B, and the +exec mode looks very similar, but is in a more logical order and lacks +curly brackets. B doesn't have a tree mode, so the tree mode +is only vaguely reminiscient of B. + +=item B<-linenoise> + +Use formatting conventions in which the name of each OP, rather than being +written out in full, is represented by a one- or two-character abbreviation. +This is mainly a joke. + +=item B<-debug> + +Use formatting conventions reminiscient of B; these aren't +very concise at all. + +=item B<-env> + +Use formatting conventions read from the environment variables +C, C, and C. + +=back + +=head1 FORMATTING SPECIFICATIONS + +For each general style ('concise', 'terse', 'linenoise', etc.) there are +three specifications: one of how OPs should appear in the basic or exec +modes, one of how 'goto' lines should appear (these occur in the exec +mode only), and one of how nodes should appear in tree mode. Each has the +same format, described below. Any text that doesn't match a special +pattern is copied verbatim. + +=over 4 + +=item B<(x(>IB<;>IB<)x)> + +Generates I in exec mode, or I in basic mode. + +=item B<(*(>IB<)*)> + +Generates one copy of I for each indentation level. + +=item B<(*(>IB<;>IB<)*)> + +Generates one fewer copies of I than the indentation level, followed +by one copy of I if the indentation level is more than 0. + +=item B<(?(>IB<#>IIB<)?)> + +If the value of I is true (not empty or zero), generates the +value of I surrounded by I and I, otherwise +nothing. + +=item B<#>I + +Generates the value of the variable I. + +=item B<#>II + +Generates the value of I, left jutified to fill I spaces. + +=item B<~> + +Any number of tildes and surrounding whitespace will be collapsed to +a single space. + +=back + +The following variables are recognized: + +=over 4 + +=item B<#addr> + +The address of the OP, in hexidecimal. + +=item B<#arg> + +The OP-specific information of the OP (such as the SV for an SVOP, the +non-local exit pointers for a LOOP, etc.) enclosed in paretheses. + +=item B<#class> + +The B-determined class of the OP, in all caps. + +=item B<#classym> + +A single symbol abbreviating the class of the OP. + +=item B<#exname> + +The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. + +=item B<#extarg> + +The target of the OP, or nothing for a nulled OP. + +=item B<#firstaddr> + +The address of the OP's first child, in hexidecimal. + +=item B<#flags> + +The OP's flags, abbreviated as a series of symbols. + +=item B<#flagval> + +The numeric value of the OP's flags. + +=item B<#hyphenseq> + +The sequence number of the OP, or a hyphen if it doesn't have one. + +=item B<#label> + +'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec +mode, or empty otherwise. + +=item B<#lastaddr> + +The address of the OP's last child, in hexidecimal. + +=item B<#name> + +The OP's name. + +=item B<#NAME> + +The OP's name, in all caps. + +=item B<#next> + +The sequence number of the OP's next OP. + +=item B<#nextaddr> + +The address of the OP's next OP, in hexidecimal. + +=item B<#noise> + +The two-character abbreviation for the OP's name. + +=item B<#private> + +The OP's private flags, rendered with abbreviated names if possible. + +=item B<#privval> + +The numeric value of the OP's private flags. + +=item B<#seq> + +The sequence number of the OP. + +=item B<#seqnum> + +The real sequence number of the OP, as a regular number and not adjusted +to be relative to the start of the real program. (This will generally be +a fairly large number because all of B is compiled before +your program is). + +=item B<#sibaddr> + +The address of the OP's next youngest sibling, in hexidecimal. + +=item B<#svaddr> + +The address of the OP's SV, if it has an SV, in hexidecimal. + +=item B<#svclass> + +The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). + +=item B<#svval> + +The value of the OP's SV, if it has one, in a short human-readable format. + +=item B<#targ> + +The numeric value of the OP's targ. + +=item B<#targarg> + +The name of the variable the OP's targ refers to, if any, otherwise the +letter t followed by the OP's targ in decimal. + +=item B<#targarglife> + +Same as B<#targarg>, but followed by the COP sequence numbers that delimit +the variable's lifetime (or 'end' for a variable in an open scope) for a +variable. + +=item B<#typenum> + +The numeric value of the OP's type, in decimal. + +=back + +=head1 ABBREVIATIONS + +=head2 OP flags abbreviations + + v OPf_WANT_VOID Want nothing (void context) + s OPf_WANT_SCALAR Want single value (scalar context) + l OPf_WANT_LIST Want list of any length (list context) + K OPf_KIDS There is a firstborn child. + P OPf_PARENS This operator was parenthesized. + (Or block needs explicit scope entry.) + R OPf_REF Certified reference. + (Return container, not containee). + M OPf_MOD Will modify (lvalue). + S OPf_STACKED Some arg is arriving on the stack. + * OPf_SPECIAL Do something weird for this op (see op.h) + +=head2 OP class abbreviations + + 0 OP (aka BASEOP) An OP with no children + 1 UNOP An OP with one child + 2 BINOP An OP with two children + | LOGOP A control branch OP + @ LISTOP An OP that could have lots of children + / PMOP An OP with a regular expression + $ SVOP An OP with an SV + " PVOP An OP with a string + { LOOP An OP that holds pointers for a loop + ; COP An OP that marks the start of a statement + +=head1 AUTHOR + +Stephen McCamant, C + +=cut diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index a7a071e..2a2806f 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,132 +1,11 @@ package B::Terse; -use strict; -use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow - main_start main_root cstring svref_2object); -use B::Asmdata qw(@specialsv_name); - -sub terse { - my ($order, $cvref) = @_; - my $cv = svref_2object($cvref); - if ($order eq "exec") { - walkoptree_exec($cv->START, "terse"); - } else { - walkoptree_slow($cv->ROOT, "terse"); - } -} +use B::Concise; sub compile { - my $order = shift; - my @options = @_; - B::clearsym(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "terse(\$order, \\&$objname)"; - die "terse($order, \\&$objname) failed: $@" if $@; - } - } - } else { - if ($order eq "exec") { - return sub { walkoptree_exec(main_start, "terse") } - } else { - return sub { walkoptree_slow(main_root, "terse") } - } - } -} - -sub indent { - my $level = shift; - return " " x $level; -} - -sub B::OP::terse { - my ($op, $level) = @_; - my $targ = $op->targ; - $targ = ($targ > 0) ? " [$targ]" : ""; - print indent($level), peekop($op), $targ, "\n"; -} - -sub B::SVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->sv->terse(0); -} - -sub B::PADOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " ", $op->padix, "\n"; -} - -sub B::PMOP::terse { - my ($op, $level) = @_; - my $precomp = $op->precomp; - print indent($level), peekop($op), - defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; - -} - -sub B::PVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " ", cstring($op->pv), "\n"; -} - -sub B::COP::terse { - my ($op, $level) = @_; - my $label = $op->label; - if ($label) { - $label = " label ".cstring($label); - } - print indent($level), peekop($op), $label || "", "\n"; -} - -sub B::PV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); -} - -sub B::AV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; -} - -sub B::GV::terse { - my ($gv, $level) = @_; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; -} - -sub B::IV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; -} - -sub B::NV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; -} - -sub B::NULL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx)\n", class($sv), $$sv; -} - -sub B::SPECIAL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; + my @args = @_; + $args[0] = "-exec" if $args[0] eq "exec"; + unshift @args, "-terse"; + B::Concise::compile(@args); } 1; @@ -139,14 +18,18 @@ B::Terse - Walk Perl syntax tree, printing terse info about ops =head1 SYNOPSIS - perl -MO=Terse[,OPTIONS] foo.pl + perl -MO=Terse[,OPTIONS] foo.pl =head1 DESCRIPTION -See F. +This version of B::Terse is really just a wrapper that calls B::Concise +with the B<-terse> option. It is provided for compatibility with old scripts +(and habits) but using B::Concise directly is now recommended instead. =head1 AUTHOR -Malcolm Beattie, C +The original version of B::Terse was written by Malcolm Beattie, +C. This wrapper was written by Stephen McCamant, +C. =cut