deparse.pm

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

sub pp_padsv {
    my $self = shift;
    my($op, $cx) = @_;
    return $self->maybe_my($op, $cx, $self->padname($op->targ));
}

sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }

my @threadsv_names;

BEGIN {
    @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
		       "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
		       "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
		       "!", "@");
}

sub pp_threadsv {
    my $self = shift;
    my($op, $cx) = @_;
    return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
}    

sub pp_gvsv {
    my $self = shift;
    my($op, $cx) = @_;
    return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
}

sub pp_gv {
    my $self = shift;
    my($op, $cx) = @_;
    return $self->gv_name($op->gv);
}

sub pp_aelemfast {
    my $self = shift;
    my($op, $cx) = @_;
    my $gv = $op->gv;
    return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
}

sub rv2x {
    my $self = shift;
    my($op, $cx, $type) = @_;
    my $kid = $op->first;
    my $str = $self->deparse($kid, 0);
    return $type . (is_scalar($kid) ? $str : "{$str}");
}

sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }

# skip rv2av
sub pp_av2arylen {
    my $self = shift;
    my($op, $cx) = @_;
    if ($op->first->ppaddr eq "pp_padav") {
	return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
    } else {
	return $self->maybe_local($op, $cx,
				  $self->rv2x($op->first, $cx, '$#'));
    }
}

# skip down to the old, ex-rv2cv
sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }

sub pp_rv2av {
    my $self = shift;
    my($op, $cx) = @_;
    my $kid = $op->first;
    if ($kid->ppaddr eq "pp_const") { # constant list
	my $av = $kid->sv;
	return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
    } else {
	return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
    }
 }


sub elem {
    my $self = shift;
    my ($op, $cx, $left, $right, $padname) = @_;
    my($array, $idx) = ($op->first, $op->first->sibling);
    unless ($array->ppaddr eq $padname) { # Maybe this has been fixed	
	$array = $array->first; # skip rv2av (or ex-rv2av in _53+)
    }
    if ($array->ppaddr eq $padname) {
	$array = $self->padany($array);
    } elsif (is_scope($array)) { # ${expr}[0]
	$array = "{" . $self->deparse($array, 0) . "}";
    } elsif (is_scalar $array) { # $x[0], $$x[0], ...
	$array = $self->deparse($array, 24);
    } else {
	# $x[20][3]{hi} or expr->[20]
	my $arrow;
	$arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
	return $self->deparse($array, 24) . $arrow .
	    $left . $self->deparse($idx, 1) . $right;
    }
    $idx = $self->deparse($idx, 1);
    return "\$" . $array . $left . $idx . $right;
}

sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }

sub pp_gelem {
    my $self = shift;
    my($op, $cx) = @_;
    my($glob, $part) = ($op->first, $op->last);
    $glob = $glob->first; # skip rv2gv
    $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
    my $scope = is_scope($glob);
    $glob = $self->deparse($glob, 0);
    $part = $self->deparse($part, 1);
    return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
}

sub slice {
    my $self = shift;
    my ($op, $cx, $left, $right, $regname, $padname) = @_;
    my $last;
    my(@elems, $kid, $array, $list);
    if (class($op) eq "LISTOP") {
	$last = $op->last;
    } else { # ex-hslice inside delete()
	for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
	$last = $kid;
    }
    $array = $last;
    $array = $array->first
	if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
    if (is_scope($array)) {
	$array = "{" . $self->deparse($array, 0) . "}";
    } elsif ($array->ppaddr eq $padname) {
	$array = $self->padany($array);
    } else {
	$array = $self->deparse($array, 24);
    }
    $kid = $op->first->sibling; # skip pushmark
    if ($kid->ppaddr eq "pp_list") {
	$kid = $kid->first->sibling; # skip list, pushmark
	for (; !null $kid; $kid = $kid->sibling) {
	    push @elems, $self->deparse($kid, 6);
	}
	$list = join(", ", @elems);
    } else {
	$list = $self->deparse($kid, 1);
    }
    return "\@" . $array . $left . $list . $right;
}

sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", 
				      "pp_rv2av", "pp_padav")) }
sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
				      "pp_rv2hv", "pp_padhv")) }

sub pp_lslice {
    my $self = shift;
    my($op, $cx) = @_;
    my $idx = $op->first;
    my $list = $op->last;
    my(@elems, $kid);
    $list = $self->deparse($list, 1);
    $idx = $self->deparse($idx, 1);
    return "($list)" . "[$idx]";
}

sub OPpENTERSUB_AMPER () { 8 }

sub OPf_WANT () { 3 }
sub OPf_WANT_VOID () { 1 }
sub OPf_WANT_SCALAR () { 2 }
sub OPf_WANT_LIST () { 2 }

sub want_scalar {
    my $op = shift;
    return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
}

sub pp_entersub {
    my $self = shift;
    my($op, $cx) = @_;
    my $prefix = "";
    my $amper = "";
    my $proto = undef;
    my $simple = 0;
    my($kid, $args, @exprs);
    if (not null $op->first->sibling) { # method
	$kid = $op->first->sibling; # skip pushmark
	my $obj = $self->deparse($kid, 24);
	$kid = $kid->sibling;
	for (; not null $kid->sibling; $kid = $kid->sibling) {
	    push @exprs, $self->deparse($kid, 6);
	}
	my $meth = $kid->first;
	if ($meth->ppaddr eq "pp_const") {
	    $meth = $meth->sv->PV; # needs to be bare
	} else {
	    $meth = $self->deparse($meth, 1);
	}
	$args = join(", ", @exprs);	
	$kid = $obj . "->" . $meth;
	if ($args) {
	    return $kid . "(" . $args . ")"; # parens mandatory
	} else {
	    return $kid; # toke.c fakes parens
	}
    }
    # else, not a method
    if ($op->flags & OPf_SPECIAL) {
	$prefix = "do ";
    } elsif ($op->private & OPpENTERSUB_AMPER) {
	$amper = "&";
    }
    $kid = $op->first;
    $kid = $kid->first->sibling; # skip ex-list, pushmark
    for (; not null $kid->sibling; $kid = $kid->sibling) {
	push @exprs, $kid;
    }
    if (is_scope($kid)) {
	$amper = "&";
	$kid = "{" . $self->deparse($kid, 0) . "}";
    } elsif ($kid->first->ppaddr eq "pp_gv") {
	my $gv = $kid->first->gv;
	if (class($gv->CV) ne "SPECIAL") {
	    $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
	}
	$simple = 1;
	$kid = $self->deparse($kid, 24);
    } elsif (is_scalar $kid->first) {
	$amper = "&";
	$kid = $self->deparse($kid, 24);
    } else {
	$prefix = "";
	$kid = $self->deparse($kid, 24) . "->";
    }
    if (defined $proto and not $amper) {
	my($arg, $real);
	my $doneok = 0;
	my @args = @exprs;
	my @reals;
	my $p = $proto;
	$p =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
	while ($p) {
	    $p =~ s/^ *([\\]?[\$\@&%*]|;)//;
	    my $chr = $1;
	    if ($chr eq "") {
		undef $proto if @args;
	    } elsif ($chr eq ";") {
		$doneok = 1;
	    } elsif ($chr eq "@" or $chr eq "%") {
		push @reals, map($self->deparse($_, 6), @args);
		@args = ();
	    } else {
		$arg = shift @args;
		last unless $arg;
		if ($chr eq "\$") {
		    if (want_scalar $arg) {
			push @reals, $self->deparse($arg, 6);
		    } else {
			undef $proto;
		    }
		} elsif ($chr eq "&") {
		    if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
			push @reals, $self->deparse($arg, 6);
		    } else {
			undef $proto;
		    }
		} elsif ($chr eq "*") {
		    if ($arg->ppaddr =~ /^pp_s?refgen$/
			and $arg->first->first->ppaddr eq "pp_rv2gv")
		    {
			$real = $arg->first->first; # skip refgen, null
			if ($real->first->ppaddr eq "pp_gv") {
			    push @reals, $self->deparse($real, 6);
			} else {
			    push @reals, $self->deparse($real->first, 6);
			}
		    } else {
			undef $proto;
		    }
		} elsif (substr($chr, 0, 1) eq "\\") {
		    $chr = substr($chr, 1);
		    if ($arg->ppaddr =~ /^pp_s?refgen$/ and
			!null($real = $arg->first) and
			($chr eq "\$" && is_scalar($real->first)
			 or ($chr eq "\@"
			     && $real->first->sibling->ppaddr 
			     =~ /^pp_(rv2|pad)av$/)
			 or ($chr eq "%"
			     && $real->first->sibling->ppaddr
			     =~ /^pp_(rv2|pad)hv$/)
			 #or ($chr eq "&" # This doesn't work
			 #   && $real->first->ppaddr eq "pp_rv2cv")
			 or ($chr eq "*"
			     && $real->first->ppaddr eq "pp_rv2gv")))
		    {
			push @reals, $self->deparse($real, 6);
		    } else {
			undef $proto;
		    }
		}
	    }
	}
	undef $proto if $p and !$doneok;
	undef $proto if @args;
	$args = join(", ", @reals);
	$amper = "";
	unless (defined $proto) {
	    $amper = "&";
	    $args = join(", ", map($self->deparse($_, 6), @exprs));
	}
    } else {
	$args = join(", ", map($self->deparse($_, 6), @exprs));
    }
    if ($prefix or $amper) {
	if ($op->flags & OPf_STACKED) {
	    return $prefix . $amper . $kid . "(" . $args . ")";
	} else {
	    return $prefix . $amper. $kid;
	}
    } else {
	if (defined $proto and $proto eq "") {
	    return $kid;
	} elsif ($proto eq "\$") {
	    return $self->maybe_parens_func($kid, $args, $cx, 16);
	} elsif ($proto or $simple) {
	    return $self->maybe_parens_func($kid, $args, $cx, 5);
	} else {
	    return "$kid(" . $args . ")";
	}
    }
}

sub pp_enterwrite { unop(@_, "write") }

# escape things that cause interpolation in double quotes,
# but not character escapes
sub uninterp {
    my($str) = @_;
    $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
    return $str;
}

# the same, but treat $|, $), and $ at the end of the string differently
sub re_uninterp {
    my($str) = @_;
    $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
    $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
    return $str;
}

# character escapes, but not delimiters that might need to be escaped
sub escape_str { # ASCII
    my($str) = @_;
    $str =~ s/\a/\\a/g;
#    $str =~ s/\cH/\\b/g; # \b means someting different in a regex 
    $str =~ s/\t/\\t/g;
    $str =~ s/\n/\\n/g;
    $str =~ s/\e/\\e/g;
    $str =~ s/\f/\\f/g;
    $str =~ s/\r/\\r/g;
    $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
    $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
    return $str;
}

# Don't do this for regexen
sub unback {
    my($str) = @_;
    $str =~ s/\\/\\\\/g;
    return $str;
}

sub balanced_delim {
    my($str) = @_;
    my @str = split //, $str;
    my($ar, $open, $close, $fail, $c, $cnt);
    for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
	($open, $close) = @$ar;
	$fail = 0; $cnt = 0;
	for $c (@str) {
	    if ($c eq $open) {
		$cnt++;
	    } elsif ($c eq $close) {
		$cnt--;
		if ($cnt < 0) {
		    $fail = 1;
		    last;
		}
	    }
	}
	$fail = 1 if $cnt != 0;
	return ($open, "$open$str$close") if not $fail;
    }
    return ("", $str);
}

sub single_delim {
    my($q, $default, $str) = @_;
    return "$default$str$default" if $default and index($str, $default) == -1;
    my($succeed, $delim);
    ($succeed, $str) = balanced_delim($str);
    return "$q$str" if $succeed;
    for $delim ('/', '"', '#') {
	return "$q$delim" . $str . $delim if index($str, $delim) == -1;
    }
    if ($default) {
	$str =~ s/$default/\\$default/g;
	return "$default$str$default";
    } else {
	$str =~ s[/][\\/]g;
	return "$q/$str/";
    }
}

sub SVf_IOK () {0x10000}
sub SVf_NOK () {0x20000}
sub SVf_ROK () {0x80000}

sub const {
    my $sv = shift;
    if (class($sv) eq "SPECIAL") {
	return ('undef', '1', '0')[$$sv-1];
    } elsif ($sv->FLAGS & SVf_IOK) {
	return $sv->IV;
    } elsif ($sv->FLAGS & SVf_NOK) {
	return $sv->NV;
    } elsif ($sv->FLAGS & SVf_ROK) {
	return "\\(" . const($sv->RV) . ")"; # constant folded
    } else {
	my $str = $sv->PV;
	if ($str =~ /[^ -~]/) { # ASCII
	    return single_de