deparse.pm

ARM上的如果你对底层感兴趣

# B::Deparse.pm
# Copyright (c) 1998 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.

# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.

package B::Deparse;
use Carp 'cluck';
use B qw(class main_root main_start main_cv svref_2object);
$VERSION = 0.56;
use strict;

# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
# - fixed reference constants (\"str")
# - handle empty programs gracefully
# - handle infinte loops (for (;;) {}, while (1) {})
# - differentiate between `for my $x ...' and `my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
# - added `-u', like B::C
# - package declarations using cop_stash
# - subs, formats and code sorted by cop_seq
# Changes between 0.51 and 0.52:
# - added pp_threadsv (special variables under USE_THREADS)
# - added documentation
# Changes between 0.52 and 0.53
# - many changes adding precedence contexts and associativity
# - added `-p' and `-s' output style options
# - various other minor fixes
# Changes between 0.53 and 0.54
# - added support for new `for (1..100)' optimization,
#   thanks to Gisle Aas
# Changes between 0.54 and 0.55
# - added support for new qr// construct
# - added support for new pp_regcreset OP
# Changes between 0.55 and 0.56
# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
# - fixed $# on non-lexicals broken in last big rewrite
# - added temporary fix for change in opcode of OP_STRINGIFY
# - fixed problem in 0.54's for() patch in `for (@ary)'
# - fixed precedence in conditional of ?:
# - tweaked list paren elimination in `my($x) = @_'
# - made continue-block detection trickier wrt. null ops
# - fixed various prototype problems in pp_entersub
# - added support for sub prototypes that never get GVs
# - added unquoting for special filehandle first arg in truncate
# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
# - added semicolons at the ends of blocks
# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28

# Todo:
# - {} around variables in strings ("${var}letters")
#   base/lex.t 25-27
#   comp/term.t 11
# - generate symbolic constants directly from core source
# - left/right context
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - ',' => '=>' (auto-unquote?)
# - break long lines ("\r" as discretionary break?)
# - include values of variables (e.g. set in BEGIN)
# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - auto-apply `-u'?
# - while{} with one-statement continue => for(; XXX; XXX) {}?
# - -uPackage:: descend recursively?
# - here-docs?
# - <DATA>?

# Tests that will always fail:
# comp/redef.t -- all (redefinition happens at compile time)

# Object fields (were globals):
#
# avoid_local:
# (local($a), local($b)) and local($a, $b) have the same internal
# representation but the short form looks better. We notice we can
# use a large-scale local when checking the list, but need to prevent
# individual locals too. This hash holds the addresses of OPs that 
# have already had their local-ness accounted for. The same thing
# is done with my().
#
# curcv:
# CV for current sub (or main program) being deparsed
#
# curstash:
# name of the current package for deparsed code
#
# subs_todo:
# array of [cop_seq, GV, is_format?] for subs and formats we still
# want to deparse
#
# protos_todo:
# as above, but [name, prototype] for subs that never got a GV
#
# subs_done, forms_done:
# keys are addresses of GVs for subs and formats we've already
# deparsed (or at least put into subs_todo)
#
# parens: -p
# linenums: -l
# cuddle: ` ' or `\n', depending on -sC

# A little explanation of how precedence contexts and associativity
# work:
#
# deparse() calls each per-op subroutine with an argument $cx (short
# for context, but not the same as the cx* in the perl core), which is
# a number describing the op's parents in terms of precedence, whether
# they're inside an expression or at statement level, etc.  (see
# chart below). When ops with children call deparse on them, they pass
# along their precedence. Fractional values are used to implement
# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
# parentheses hacks. The major disadvantage of this scheme is that
# it doesn't know about right sides and left sides, so say if you
# assign a listop to a variable, it can't tell it's allowed to leave
# the parens off the listop.

# Precedences:
# 26             [TODO] inside interpolation context ("")
# 25 left        terms and list operators (leftward)
# 24 left        ->
# 23 nonassoc    ++ --
# 22 right       **
# 21 right       ! ~ \ and unary + and -
# 20 left        =~ !~
# 19 left        * / % x
# 18 left        + - .
# 17 left        << >>
# 16 nonassoc    named unary operators
# 15 nonassoc    < > <= >= lt gt le ge
# 14 nonassoc    == != <=> eq ne cmp
# 13 left        &
# 12 left        | ^
# 11 left        &&
# 10 left        ||
#  9 nonassoc    ..  ...
#  8 right       ?:
#  7 right       = += -= *= etc.
#  6 left        , =>
#  5 nonassoc    list operators (rightward)
#  4 right       not
#  3 left        and
#  2 left        or xor
#  1             statement modifiers
#  0             statement level

# Nonprinting characters with special meaning:
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
# \t - increase indent
# \b - decrease indent (`outdent')
# \f - flush left (no indent)
# \cK - kill following semicolon, if any

sub null {
    my $op = shift;
    return class($op) eq "NULL";
}

sub todo {
    my $self = shift;
    my($gv, $cv, $is_form) = @_;
    my $seq;
    if (!null($cv->START) and is_state($cv->START)) {
	$seq = $cv->START->cop_seq;
    } else {
	$seq = 0;
    }
    push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
}

sub next_todo {
    my $self = shift;
    my $ent = shift @{$self->{'subs_todo'}};
    my $name = $self->gv_name($ent->[1]);
    if ($ent->[2]) {
	return "format $name =\n"
	    . $self->deparse_format($ent->[1]->FORM). "\n";
    } else {
	return "sub $name " .
	    $self->deparse_sub($ent->[1]->CV);
    }
}

sub OPf_KIDS () { 4 }

sub walk_tree {
    my($op, $sub) = @_;
    $sub->($op);
    if ($op->flags & OPf_KIDS) {
	my $kid;
	for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
	    walk_tree($kid, $sub);
	}
    }
}

sub walk_sub {
    my $self = shift;
    my $cv = shift;
    my $op = $cv->ROOT;
    $op = shift if null $op;
    return if !$op or null $op;
    walk_tree($op, sub {
	my $op = shift;
	if ($op->ppaddr eq "pp_gv") {
	    if ($op->next->ppaddr eq "pp_entersub") {
		next if $self->{'subs_done'}{$ {$op->gv}}++;
		next if class($op->gv->CV) eq "SPECIAL";
		$self->todo($op->gv, $op->gv->CV, 0);
		$self->walk_sub($op->gv->CV);
	    } elsif ($op->next->ppaddr eq "pp_enterwrite"
		     or ($op->next->ppaddr eq "pp_rv2gv"
			 and $op->next->next->ppaddr eq "pp_enterwrite")) {
		next if $self->{'forms_done'}{$ {$op->gv}}++;
		next if class($op->gv->FORM) eq "SPECIAL";
		$self->todo($op->gv, $op->gv->FORM, 1);
		$self->walk_sub($op->gv->FORM);
	    }
	}
    });
}

sub stash_subs {
    my $self = shift;
    my $pack = shift;
    my(%stash, @ret);
    { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
    if ($pack eq "main") {
	$pack = "";
    } else {
	$pack = $pack . "::";
    }
    my($key, $val);
    while (($key, $val) = each %stash) {
	my $class = class($val);
	if ($class eq "PV") {
	    # Just a prototype
	    push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
	} elsif ($class eq "IV") {
	    # Just a name
	    push @{$self->{'protos_todo'}}, [$pack . $key, undef];	    
	} elsif ($class eq "GV") {
	    if (class($val->CV) ne "SPECIAL") {
		next if $self->{'subs_done'}{$$val}++;
		$self->todo($val, $val->CV, 0);
		$self->walk_sub($val->CV);
	    }
	    if (class($val->FORM) ne "SPECIAL") {
		next if $self->{'forms_done'}{$$val}++;
		$self->todo($val, $val->FORM, 1);
		$self->walk_sub($val->FORM);
	    }
	}
    }
}

sub print_protos {
    my $self = shift;
    my $ar;
    my @ret;
    foreach $ar (@{$self->{'protos_todo'}}) {
	my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
	push @ret, "sub " . $ar->[0] .  "$proto;\n";
    }
    delete $self->{'protos_todo'};
    return @ret;
}

sub style_opts {
    my $self = shift;
    my $opts = shift;
    my $opt;
    while (length($opt = substr($opts, 0, 1))) {
	if ($opt eq "C") {
	    $self->{'cuddle'} = " ";
	}
	$opts = substr($opts, 1);
    }
}

sub compile {
    my(@args) = @_;
    return sub { 
	my $self = bless {};
	my $arg;
	$self->{'subs_todo'} = [];
	$self->stash_subs("main");
	$self->{'curcv'} = main_cv;
	$self->{'curstash'} = "main";
	$self->{'cuddle'} = "\n";
	while ($arg = shift @args) {
	    if (substr($arg, 0, 2) eq "-u") {
		$self->stash_subs(substr($arg, 2));
	    } elsif ($arg eq "-p") {
		$self->{'parens'} = 1;
	    } elsif ($arg eq "-l") {
		$self->{'linenums'} = 1;
	    } elsif (substr($arg, 0, 2) eq "-s") {
		$self->style_opts(substr $arg, 2);
	    }
	}
	$self->walk_sub(main_cv, main_start);
	print $self->print_protos;
	@{$self->{'subs_todo'}} =
	    sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
	print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
	my @text;
	while (scalar(@{$self->{'subs_todo'}})) {
	    push @text, $self->next_todo;
	}
	print indent(join("", @text)), "\n" if @text;
    }
}

sub deparse {
    my $self = shift;
    my($op, $cx) = @_;
#    cluck if class($op) eq "NULL";
    my $meth = $op->ppaddr;
    return $self->$meth($op, $cx);
}

sub indent {
    my $txt = shift;
    my @lines = split(/\n/, $txt);
    my $leader = "";
    my $line;
    for $line (@lines) {
	if (substr($line, 0, 1) eq "\t") {
	    $leader = $leader . "    ";
	    $line = substr($line, 1);
	} elsif (substr($line, 0, 1) eq "\b") {
	    $leader = substr($leader, 0, length($leader) - 4);
	    $line = substr($line, 1);
	}
	if (substr($line, 0, 1) eq "\f") {
	    $line = substr($line, 1); # no indent
	} else {
	    $line = $leader . $line;
	}
	$line =~ s/\cK;?//g;
    }
    return join("\n", @lines);
}

sub SVf_POK () {0x40000}

sub deparse_sub {
    my $self = shift;
    my $cv = shift;
    my $proto = "";
    if ($cv->FLAGS & SVf_POK) {
	$proto = "(". $cv->PV . ") ";
    }
    local($self->{'curcv'}) = $cv;
    local($self->{'curstash'}) = $self->{'curstash'};
    if (not null $cv->ROOT) {
	# skip leavesub
	return $proto . "{\n\t" . 
	    $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; 
    } else { # XSUB?
	return $proto  . "{}\n";
    }
}

sub deparse_format {
    my $self = shift;
    my $form = shift;
    my @text;
    local($self->{'curcv'}) = $form;
    local($self->{'curstash'}) = $self->{'curstash'};
    my $op = $form->ROOT;
    my $kid;
    $op = $op->first->first; # skip leavewrite, lineseq
    while (not null $op) {
	$op = $op->sibling; # skip nextstate
	my @exprs;
	$kid = $op->first->sibling; # skip pushmark
	push @text, $kid->sv->PV;
	$kid = $kid->sibling;
	for (; not null $kid; $kid = $kid->sibling) {
	    push @exprs, $self->deparse($kid, 0);
	}
	push @text, join(", ", @exprs)."\n" if @exprs;
	$op = $op->sibling;
    }
    return join("", @text) . ".";
}

# the aassign in-common check messes up SvCUR (always setting it
# to a value >= 100), but it's probably safe to assume there
# won't be any NULs in the names of my() variables. (with
# stash variables, I wouldn't be so sure)
sub padname_fix {
    my $str = shift;
    $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
    return $str;
}

sub is_scope {
    my $op = shift;
    return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
      || $op->ppaddr eq "pp_lineseq"
	|| ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" 
	    && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
}

sub is_state {
    my $name = $_[0]->ppaddr;
    return $name eq "pp_nextstate" || $name eq "pp_dbstate";
}

sub is_miniwhile { # check for one-line loop (`foo() while $y--')
    my $op = shift;
    return (!null($op) and null($op->sibling) 
	    and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
	    and (($op->first->ppaddr =~ /^pp_(and|or)$/
		  and $op->first->first->sibling->ppaddr eq "pp_lineseq")
		 or ($op->first->ppaddr eq "pp_lineseq"
		     and not null $op->first->first->sibling
		     and $op->first->first->sibling->ppaddr eq "pp_unstack")
		 ));
}

sub is_scalar {
    my $op = shift;
    return ($op->ppaddr eq "pp_rv2sv" or
	    $op->ppaddr eq "pp_padsv" or
	    $op->ppaddr eq "pp_gv" or # only in array/hash constructs
	    !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
}

sub maybe_parens {