deparse.pm

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

sub pp_shostent { unop(@_, "sethostent") }
sub pp_snetent { unop(@_, "setnetent") }
sub pp_sprotoent { unop(@_, "setprotoent") }
sub pp_sservent { unop(@_, "setservent") }
sub pp_gpwnam { unop(@_, "getpwnam") }
sub pp_gpwuid { unop(@_, "getpwuid") }
sub pp_ggrnam { unop(@_, "getgrnam") }
sub pp_ggrgid { unop(@_, "getgrgid") }

sub pp_lock { unop(@_, "lock") }

sub pp_exists {
    my $self = shift;
    my($op, $cx) = @_;
    return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
				    $cx, 16);
}

sub OPpSLICE () { 64 }

sub pp_delete {
    my $self = shift;
    my($op, $cx) = @_;
    my $arg;
    if ($op->private & OPpSLICE) {
	return $self->maybe_parens_func("delete",
					$self->pp_hslice($op->first, 16),
					$cx, 16);
    } else {
	return $self->maybe_parens_func("delete",
					$self->pp_helem($op->first, 16),
					$cx, 16);
    }
}

sub OPp_CONST_BARE () { 64 }

sub pp_require {
    my $self = shift;
    my($op, $cx) = @_;
    if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
	and $op->first->private & OPp_CONST_BARE)
    {
	my $name = $op->first->sv->PV;
	$name =~ s[/][::]g;
	$name =~ s/\.pm//g;
	return "require($name)";
    } else {	
	$self->unop($op, $cx, "require");
    }
}

sub pp_scalar { 
    my $self = shift;
    my($op, $cv) = @_;
    my $kid = $op->first;
    if (not null $kid->sibling) {
	# XXX Was a here-doc
	return $self->dquote($op);
    }
    $self->unop(@_, "scalar");
}


sub padval {
    my $self = shift;
    my $targ = shift;
    return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
}

sub OPf_REF () { 16 }

sub pp_refgen {
    my $self = shift;	
    my($op, $cx) = @_;
    my $kid = $op->first;
    if ($kid->ppaddr eq "pp_null") {
	$kid = $kid->first;
	if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
	    my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
				 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
	    my($expr, @exprs);
	    $kid = $kid->first->sibling; # skip pushmark
	    for (; !null($kid); $kid = $kid->sibling) {
		$expr = $self->deparse($kid, 6);
		push @exprs, $expr;
	    }
	    return $pre . join(", ", @exprs) . $post;
	} elsif (!null($kid->sibling) and 
		 $kid->sibling->ppaddr eq "pp_anoncode") {
	    return "sub " .
		$self->deparse_sub($self->padval($kid->sibling->targ));
	} elsif ($kid->ppaddr eq "pp_pushmark"
		 and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
		 and not $kid->sibling->flags & OPf_REF) {
	    # The @a in \(@a) isn't in ref context, but only when the
	    # parens are there.
	    return "\\(" . $self->deparse($kid->sibling, 1) . ")";
	}
    }
    $self->pfixop($op, $cx, "\\", 20);
}

sub pp_srefgen { pp_refgen(@_) }

sub pp_readline {
    my $self = shift;
    my($op, $cx) = @_;
    my $kid = $op->first;
    $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
    if ($kid->ppaddr eq "pp_rv2gv") {
	$kid = $kid->first;
    }
    return "<" . $self->deparse($kid, 1) . ">";
}

sub loopex {
    my $self = shift;
    my ($op, $cx, $name) = @_;
    if (class($op) eq "PVOP") {
	return "$name " . $op->pv;
    } elsif (class($op) eq "OP") {
	return $name;
    } elsif (class($op) eq "UNOP") {
	# Note -- loop exits are actually exempt from the
	# looks-like-a-func rule, but a few extra parens won't hurt
	return $self->maybe_parens_unop($name, $op->first, $cx);
    }
}

sub pp_last { loopex(@_, "last") }
sub pp_next { loopex(@_, "next") }
sub pp_redo { loopex(@_, "redo") }
sub pp_goto { loopex(@_, "goto") }
sub pp_dump { loopex(@_, "dump") }

sub ftst {
    my $self = shift;
    my($op, $cx, $name) = @_;
    if (class($op) eq "UNOP") {
	# Genuine `-X' filetests are exempt from the LLAFR, but not
	# l?stat(); for the sake of clarity, give'em all parens
	return $self->maybe_parens_unop($name, $op->first, $cx);
    } elsif (class($op) eq "GVOP") {
	return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
    } else { # I don't think baseop filetests ever survive ck_ftst, but...
	return $name;
    }
}

sub pp_lstat { ftst(@_, "lstat") }
sub pp_stat { ftst(@_, "stat") }
sub pp_ftrread { ftst(@_, "-R") }
sub pp_ftrwrite { ftst(@_, "-W") }
sub pp_ftrexec { ftst(@_, "-X") }
sub pp_fteread { ftst(@_, "-r") }
sub pp_ftewrite { ftst(@_, "-r") }
sub pp_fteexec { ftst(@_, "-r") }
sub pp_ftis { ftst(@_, "-e") }
sub pp_fteowned { ftst(@_, "-O") }
sub pp_ftrowned { ftst(@_, "-o") }
sub pp_ftzero { ftst(@_, "-z") }
sub pp_ftsize { ftst(@_, "-s") }
sub pp_ftmtime { ftst(@_, "-M") }
sub pp_ftatime { ftst(@_, "-A") }
sub pp_ftctime { ftst(@_, "-C") }
sub pp_ftsock { ftst(@_, "-S") }
sub pp_ftchr { ftst(@_, "-c") }
sub pp_ftblk { ftst(@_, "-b") }
sub pp_ftfile { ftst(@_, "-f") }
sub pp_ftdir { ftst(@_, "-d") }
sub pp_ftpipe { ftst(@_, "-p") }
sub pp_ftlink { ftst(@_, "-l") }
sub pp_ftsuid { ftst(@_, "-u") }
sub pp_ftsgid { ftst(@_, "-g") }
sub pp_ftsvtx { ftst(@_, "-k") }
sub pp_fttty { ftst(@_, "-t") }
sub pp_fttext { ftst(@_, "-T") }
sub pp_ftbinary { ftst(@_, "-B") }

sub SWAP_CHILDREN () { 1 }
sub ASSIGN () { 2 } # has OP= variant

sub OPf_STACKED () { 64 }

my(%left, %right);

sub assoc_class {
    my $op = shift;
    my $name = $op->ppaddr;
    if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
	# avoid spurious `=' -- see comment in pp_concat
	return "pp_concat";
    }
    if ($name eq "pp_null" and class($op) eq "UNOP"
	and $op->first->ppaddr =~ /^pp_(and|x?or)$/
	and null $op->first->sibling)
    {
	# Like all conditional constructs, OP_ANDs and OP_ORs are topped
	# with a null that's used as the common end point of the two
	# flows of control. For precedence purposes, ignore it.
	# (COND_EXPRs have these too, but we don't bother with
	# their associativity).
	return assoc_class($op->first);
    }
    return $name . ($op->flags & OPf_STACKED ? "=" : "");
}

# Left associative operators, like `+', for which
# $a + $b + $c is equivalent to ($a + $b) + $c

BEGIN {
    %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
	     'pp_divide' => 19, 'pp_i_divide' => 19,
	     'pp_modulo' => 19, 'pp_i_modulo' => 19,
	     'pp_repeat' => 19,
	     'pp_add' => 18, 'pp_i_add' => 18,
	     'pp_subtract' => 18, 'pp_i_subtract' => 18,
	     'pp_concat' => 18,
	     'pp_left_shift' => 17, 'pp_right_shift' => 17,
	     'pp_bit_and' => 13,
	     'pp_bit_or' => 12, 'pp_bit_xor' => 12,
	     'pp_and' => 3,
	     'pp_or' => 2, 'pp_xor' => 2,
	    );
}

sub deparse_binop_left {
    my $self = shift;
    my($op, $left, $prec) = @_;
    if ($left{assoc_class($op)}
	and $left{assoc_class($op)} == $left{assoc_class($left)})
    {
	return $self->deparse($left, $prec - .00001);
    } else {
	return $self->deparse($left, $prec);	
    }
}

# Right associative operators, like `=', for which
# $a = $b = $c is equivalent to $a = ($b = $c)

BEGIN {
    %right = ('pp_pow' => 22,
	      'pp_sassign=' => 7, 'pp_aassign=' => 7,
	      'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
	      'pp_divide=' => 7, 'pp_i_divide=' => 7,
	      'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
	      'pp_repeat=' => 7,
	      'pp_add=' => 7, 'pp_i_add=' => 7,
	      'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
	      'pp_concat=' => 7,
	      'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
	      'pp_bit_and=' => 7,
	      'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
	      'pp_andassign' => 7,
	      'pp_orassign' => 7,
	     );
}

sub deparse_binop_right {
    my $self = shift;
    my($op, $right, $prec) = @_;
    if ($right{assoc_class($op)}
	and $right{assoc_class($op)} == $right{assoc_class($right)})
    {
	return $self->deparse($right, $prec - .00001);
    } else {
	return $self->deparse($right, $prec);	
    }
}

sub binop {
    my $self = shift;
    my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
    my $left = $op->first;
    my $right = $op->last;
    my $eq = "";
    if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
	$eq = "=";
	$prec = 7;
    }
    if ($flags & SWAP_CHILDREN) {
	($left, $right) = ($right, $left);
    }
    $left = $self->deparse_binop_left($op, $left, $prec);
    $right = $self->deparse_binop_right($op, $right, $prec);
    return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
}

sub pp_add { binop(@_, "+", 18, ASSIGN) }
sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
sub pp_subtract { binop(@_, "-",18,  ASSIGN) }
sub pp_divide { binop(@_, "/", 19, ASSIGN) }
sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
sub pp_pow { binop(@_, "**", 22, ASSIGN) }

sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }

sub pp_eq { binop(@_, "==", 14) }
sub pp_ne { binop(@_, "!=", 14) }
sub pp_lt { binop(@_, "<", 15) }
sub pp_gt { binop(@_, ">", 15) }
sub pp_ge { binop(@_, ">=", 15) }
sub pp_le { binop(@_, "<=", 15) }
sub pp_ncmp { binop(@_, "<=>", 14) }
sub pp_i_eq { binop(@_, "==", 14) }
sub pp_i_ne { binop(@_, "!=", 14) }
sub pp_i_lt { binop(@_, "<", 15) }
sub pp_i_gt { binop(@_, ">", 15) }
sub pp_i_ge { binop(@_, ">=", 15) }
sub pp_i_le { binop(@_, "<=", 15) }
sub pp_i_ncmp { binop(@_, "<=>", 14) }

sub pp_seq { binop(@_, "eq", 14) }
sub pp_sne { binop(@_, "ne", 14) }
sub pp_slt { binop(@_, "lt", 15) }
sub pp_sgt { binop(@_, "gt", 15) }
sub pp_sge { binop(@_, "ge", 15) }
sub pp_sle { binop(@_, "le", 15) }
sub pp_scmp { binop(@_, "cmp", 14) }

sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }

# `.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
# programmer had written `($a . $b) .= $c', except legal.
sub pp_concat {
    my $self = shift;
    my($op, $cx) = @_;
    my $left = $op->first;
    my $right = $op->last;
    my $eq = "";
    my $prec = 18;
    if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
	$eq = "=";
	$prec = 7;
    }
    $left = $self->deparse_binop_left($op, $left, $prec);
    $right = $self->deparse_binop_right($op, $right, $prec);
    return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}

# `x' is weird when the left arg is a list
sub pp_repeat {
    my $self = shift;
    my($op, $cx) = @_;
    my $left = $op->first;
    my $right = $op->last;
    my $eq = "";
    my $prec = 19;
    if ($op->flags & OPf_STACKED) {
	$eq = "=";
	$prec = 7;
    }
    if (null($right)) { # list repeat; count is inside left-side ex-list
	my $kid = $left->first->sibling; # skip pushmark
	my @exprs;
	for (; !null($kid->sibling); $kid = $kid->sibling) {
	    push @exprs, $self->deparse($kid, 6);
	}
	$right = $kid;
	$left = "(" . join(", ", @exprs). ")";
    } else {
	$left = $self->deparse_binop_left($op, $left, $prec);
    }
    $right = $self->deparse_binop_right($op, $right, $prec);
    return $self->maybe_parens("$left x$eq $right", $cx, $prec);
}

sub range {
    my $self = shift;
    my ($op, $cx, $type) = @_;
    my $left = $op->first;
    my $right = $left->sibling;
    $left = $self->deparse($left, 9);
    $right = $self->deparse($right, 9);
    return $self->maybe_parens("$left $type $right", $cx, 9);
}

sub pp_flop {
    my $self = shift;
    my($op, $cx) = @_;
    my $flip = $op->first;
    my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
    return $self->range($flip->first, $cx, $type);
}

# one-line while/until is handled in pp_leave

sub logop {
    my $self = shift;
    my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
    my $left = $op->first;
    my $right = $op->first->sibling;
    if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
	$left = $self->deparse($left, 1);
	$right = $self->deparse($right, 0);
	return "$blockname ($left) {\n\t$right\n\b}\cK";
    } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
	$right = $self->deparse($right, 1);
	$left = $self->deparse($left, 1);
	return "$right $blockname $left";
    } elsif ($cx > $lowprec and $highop) { # $a && $b
	$left = $self->deparse_binop_left($op, $left, $highprec);
	$right = $self->deparse_binop_right($op, $right, $highprec);
	return $self->maybe_parens("$left $highop $right", $cx, $highprec);
    } else { # $a and $b
	$left = $self->deparse_binop_left($op, $left, $lowprec);
	$right = $self->deparse_binop_right($op, $right, $lowprec);
	return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 
    }
}

sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
sub pp_or {  logop(@_, "or",  2, "||", 10, "unless") }
sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }

sub logassignop {
    my $self = shift;
    my ($op, $cx, $opname) = @_;
    my $left = $op->first;
    my $right = $op->first->sibling->first; # skip sassign
    $left = $self->deparse($left, 7);
    $right = $self->deparse($right, 7);
    return $self->maybe_parens("$left $opname $right", $cx, 7);
}

sub pp_andassign { logassignop(@_, "&&=") }