concise.pm

UNIX下perl实现代码

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.51";
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) #name (?([#targ])?) "
    . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\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! <? i? s< s> 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}
	and $op->pmreplroot->isa("B::OP")) {
	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", ">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->PVX;
	    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 $pmreplroot = $op->pmreplroot;
	my ($pmreplroot, $pmreplstart);
	if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) {
	    # with C<@stash_array = split(/pat/, str);>,
	    #  *stash_array is stored in pmreplroot.
	    $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
	} elsif ($ {$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;
	$h{coplabel} = $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->SAFENAME . ")";
	    $h{svval} = "*$stash" . $gv->SAFENAME;
	} 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});