deparse.pm

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

    my $self = shift;
    my($text, $cx, $prec) = @_;
    if ($prec < $cx              # unary ops nest just fine
	or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
	or $self->{'parens'})
    {
	$text = "($text)";
	# In a unop, let parent reuse our parens; see maybe_parens_unop
	$text = "\cS" . $text if $cx == 16;
	return $text;
    } else {
	return $text;
    }
}

# same as above, but get around the `if it looks like a function' rule
sub maybe_parens_unop {
    my $self = shift;
    my($name, $kid, $cx) = @_;
    if ($cx > 16 or $self->{'parens'}) {
	return "$name(" . $self->deparse($kid, 1) . ")";
    } else {
	$kid = $self->deparse($kid, 16);
	if (substr($kid, 0, 1) eq "\cS") {
	    # use kid's parens
	    return $name . substr($kid, 1);
	} elsif (substr($kid, 0, 1) eq "(") {
	    # avoid looks-like-a-function trap with extra parens
	    # (`+' can lead to ambiguities)
	    return "$name(" . $kid  . ")";
	} else {
	    return "$name $kid";
	}
    }
}

sub maybe_parens_func {
    my $self = shift;
    my($func, $text, $cx, $prec) = @_;
    if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
	return "$func($text)";
    } else {
	return "$func $text";
    }
}

sub OPp_LVAL_INTRO () { 128 }

sub maybe_local {
    my $self = shift;
    my($op, $cx, $text) = @_;
    if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
	return $self->maybe_parens_func("local", $text, $cx, 16);
    } else {
	return $text;
    }
}

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

sub maybe_my {
    my $self = shift;
    my($op, $cx, $text) = @_;
    if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
	return $self->maybe_parens_func("my", $text, $cx, 16);
    } else {
	return $text;
    }
}

# The following OPs don't have functions:

# pp_padany -- does not exist after parsing
# pp_rcatline -- does not exist

sub pp_enter { # see also leave
    cluck "unexpected OP_ENTER";
    return "XXX";
}

sub pp_pushmark { # see also list
    cluck "unexpected OP_PUSHMARK";
    return "XXX";
}

sub pp_leavesub { # see also deparse_sub
    cluck "unexpected OP_LEAVESUB";
    return "XXX";
}

sub pp_leavewrite { # see also deparse_format
    cluck "unexpected OP_LEAVEWRITE";
    return "XXX";
}

sub pp_method { # see also entersub
    cluck "unexpected OP_METHOD";
    return "XXX";
}

sub pp_regcmaybe { # see also regcomp
    cluck "unexpected OP_REGCMAYBE";
    return "XXX";
}

sub pp_regcreset { # see also regcomp
    cluck "unexpected OP_REGCRESET";
    return "XXX";
}

sub pp_substcont { # see also subst
    cluck "unexpected OP_SUBSTCONT";
    return "XXX";
}

sub pp_grepstart { # see also grepwhile
    cluck "unexpected OP_GREPSTART";
    return "XXX";
}

sub pp_mapstart { # see also mapwhile
    cluck "unexpected OP_MAPSTART";
    return "XXX";
}

sub pp_flip { # see also flop
    cluck "unexpected OP_FLIP";
    return "XXX";
}

sub pp_iter { # see also leaveloop
    cluck "unexpected OP_ITER";
    return "XXX";
}

sub pp_enteriter { # see also leaveloop
    cluck "unexpected OP_ENTERITER";
    return "XXX";
}

sub pp_enterloop { # see also leaveloop
    cluck "unexpected OP_ENTERLOOP";
    return "XXX";
}

sub pp_leaveeval { # see also entereval
    cluck "unexpected OP_LEAVEEVAL";
    return "XXX";
}

sub pp_entertry { # see also leavetry
    cluck "unexpected OP_ENTERTRY";
    return "XXX";
}

# leave and scope/lineseq should probably share code
sub pp_leave {
    my $self = shift;
    my($op, $cx) = @_;
    my ($kid, $expr);
    my @exprs;
    local($self->{'curstash'}) = $self->{'curstash'};
    $kid = $op->first->sibling; # skip enter
    if (is_miniwhile($kid)) {
	my $top = $kid->first;
	my $name = $top->ppaddr;
	if ($name eq "pp_and") {
	    $name = "while";
	} elsif ($name eq "pp_or") {
	    $name = "until";
	} else { # no conditional -> while 1 or until 0
	    return $self->deparse($top->first, 1) . " while 1";
	}
	my $cond = $top->first;
	my $body = $cond->sibling->first; # skip lineseq
	$cond = $self->deparse($cond, 1);
	$body = $self->deparse($body, 1);
	return "$body $name $cond";
    }
    for (; !null($kid); $kid = $kid->sibling) {
	$expr = "";
	if (is_state $kid) {
	    $expr = $self->deparse($kid, 0);
	    $kid = $kid->sibling;
	    last if null $kid;
	}
	$expr .= $self->deparse($kid, 0);
	push @exprs, $expr if $expr;
    }
    if ($cx > 0) { # inside an expression
	return "do { " . join(";\n", @exprs) . " }";
    } else {
	return join(";\n", @exprs) . ";";
    }
}

sub pp_scope {
    my $self = shift;
    my($op, $cx) = @_;
    my ($kid, $expr);
    my @exprs;
    for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
	$expr = "";
	if (is_state $kid) {
	    $expr = $self->deparse($kid, 0);
	    $kid = $kid->sibling;
	    last if null $kid;
	}
	$expr .= $self->deparse($kid, 0);
	push @exprs, $expr if $expr;
    }
    if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
	return "do { " . join(";\n", @exprs) . " }";
    } else {
	return join(";\n", @exprs) . ";";
    }
}

sub pp_lineseq { pp_scope(@_) }

# The BEGIN {} is used here because otherwise this code isn't executed
# when you run B::Deparse on itself.
my %globalnames;
BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
	    "ENV", "ARGV", "ARGVOUT", "_"); }

sub gv_name {
    my $self = shift;
    my $gv = shift;
    my $stash = $gv->STASH->NAME;
    my $name = $gv->NAME;
    if ($stash eq $self->{'curstash'} or $globalnames{$name}
	or $name =~ /^[^A-Za-z_]/)
    {
	$stash = "";
    } else {
	$stash = $stash . "::";
    }
    if ($name =~ /^([\cA-\cZ])$/) {
	$name = "^" . chr(64 + ord($1));
    }
    return $stash . $name;
}

# Notice how subs and formats are inserted between statements here
sub pp_nextstate {
    my $self = shift;
    my($op, $cx) = @_;
    my @text;
    @text = $op->label . ": " if $op->label;
    my $seq = $op->cop_seq;
    while (scalar(@{$self->{'subs_todo'}})
	   and $seq > $self->{'subs_todo'}[0][0]) {
	push @text, $self->next_todo;
    }
    my $stash = $op->stash->NAME;
    if ($stash ne $self->{'curstash'}) {
	push @text, "package $stash;\n";
	$self->{'curstash'} = $stash;
    }
    if ($self->{'linenums'}) {
	push @text, "\f#line " . $op->line . 
	  ' "' . substr($op->filegv->NAME, 2), qq'"\n';
    }
    return join("", @text);
}

sub pp_dbstate { pp_nextstate(@_) }

sub pp_unstack { return "" } # see also leaveloop

sub baseop {
    my $self = shift;
    my($op, $cx, $name) = @_;
    return $name;
}

sub pp_stub { baseop(@_, "()") }
sub pp_wantarray { baseop(@_, "wantarray") }
sub pp_fork { baseop(@_, "fork") }
sub pp_wait { baseop(@_, "wait") }
sub pp_getppid { baseop(@_, "getppid") }
sub pp_time { baseop(@_, "time") }
sub pp_tms { baseop(@_, "times") }
sub pp_ghostent { baseop(@_, "gethostent") }
sub pp_gnetent { baseop(@_, "getnetent") }
sub pp_gprotoent { baseop(@_, "getprotoent") }
sub pp_gservent { baseop(@_, "getservent") }
sub pp_ehostent { baseop(@_, "endhostent") }
sub pp_enetent { baseop(@_, "endnetent") }
sub pp_eprotoent { baseop(@_, "endprotoent") }
sub pp_eservent { baseop(@_, "endservent") }
sub pp_gpwent { baseop(@_, "getpwent") }
sub pp_spwent { baseop(@_, "setpwent") }
sub pp_epwent { baseop(@_, "endpwent") }
sub pp_ggrent { baseop(@_, "getgrent") }
sub pp_sgrent { baseop(@_, "setgrent") }
sub pp_egrent { baseop(@_, "endgrent") }
sub pp_getlogin { baseop(@_, "getlogin") }

sub POSTFIX () { 1 }

# I couldn't think of a good short name, but this is the category of
# symbolic unary operators with interesting precedence

sub pfixop {
    my $self = shift;
    my($op, $cx, $name, $prec, $flags) = (@_, 0);
    my $kid = $op->first;
    $kid = $self->deparse($kid, $prec);
    return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
			       $cx, $prec);
}

sub pp_preinc { pfixop(@_, "++", 23) }
sub pp_predec { pfixop(@_, "--", 23) }
sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
sub pp_i_preinc { pfixop(@_, "++", 23) }
sub pp_i_predec { pfixop(@_, "--", 23) }
sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
sub pp_complement { pfixop(@_, "~", 21) }

sub pp_negate {
    my $self = shift;
    my($op, $cx) = @_;
    if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
	# avoid --$x
	$self->pfixop($op, $cx, "-", 21.5);
    } else {
	$self->pfixop($op, $cx, "-", 21);	
    }
}
sub pp_i_negate { pp_negate(@_) }

sub pp_not {
    my $self = shift;
    my($op, $cx) = @_;
    if ($cx <= 4) {
	$self->pfixop($op, $cx, "not ", 4);
    } else {
	$self->pfixop($op, $cx, "!", 21);	
    }
}

sub OPf_SPECIAL () { 128 }

sub unop {
    my $self = shift;
    my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
    my $kid;
    if ($op->flags & OPf_KIDS) {
	$kid = $op->first;
	return $self->maybe_parens_unop($name, $kid, $cx);
    } else {
	return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");       
    }
}

sub pp_chop { unop(@_, "chop") }
sub pp_chomp { unop(@_, "chomp") }
sub pp_schop { unop(@_, "chop") }
sub pp_schomp { unop(@_, "chomp") }
sub pp_defined { unop(@_, "defined") }
sub pp_undef { unop(@_, "undef") }
sub pp_study { unop(@_, "study") }
sub pp_ref { unop(@_, "ref") }
sub pp_pos { maybe_local(@_, unop(@_, "pos")) }

sub pp_sin { unop(@_, "sin") }
sub pp_cos { unop(@_, "cos") }
sub pp_rand { unop(@_, "rand") }
sub pp_srand { unop(@_, "srand") }
sub pp_exp { unop(@_, "exp") }
sub pp_log { unop(@_, "log") }
sub pp_sqrt { unop(@_, "sqrt") }
sub pp_int { unop(@_, "int") }
sub pp_hex { unop(@_, "hex") }
sub pp_oct { unop(@_, "oct") }
sub pp_abs { unop(@_, "abs") }

sub pp_length { unop(@_, "length") }
sub pp_ord { unop(@_, "ord") }
sub pp_chr { unop(@_, "chr") }
sub pp_ucfirst { unop(@_, "ucfirst") }
sub pp_lcfirst { unop(@_, "lcfirst") }
sub pp_uc { unop(@_, "uc") }
sub pp_lc { unop(@_, "lc") }
sub pp_quotemeta { unop(@_, "quotemeta") }

sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_keys { unop(@_, "keys") }
sub pp_pop { unop(@_, "pop") }
sub pp_shift { unop(@_, "shift") }

sub pp_caller { unop(@_, "caller") }
sub pp_reset { unop(@_, "reset") }
sub pp_exit { unop(@_, "exit") }
sub pp_prototype { unop(@_, "prototype") }

sub pp_close { unop(@_, "close") }
sub pp_fileno { unop(@_, "fileno") }
sub pp_umask { unop(@_, "umask") }
sub pp_binmode { unop(@_, "binmode") }
sub pp_untie { unop(@_, "untie") }
sub pp_tied { unop(@_, "tied") }
sub pp_dbmclose { unop(@_, "dbmclose") }
sub pp_getc { unop(@_, "getc") }
sub pp_eof { unop(@_, "eof") }
sub pp_tell { unop(@_, "tell") }
sub pp_getsockname { unop(@_, "getsockname") }
sub pp_getpeername { unop(@_, "getpeername") }

sub pp_chdir { unop(@_, "chdir") }
sub pp_chroot { unop(@_, "chroot") }
sub pp_readlink { unop(@_, "readlink") }
sub pp_rmdir { unop(@_, "rmdir") }
sub pp_readdir { unop(@_, "readdir") }
sub pp_telldir { unop(@_, "telldir") }
sub pp_rewinddir { unop(@_, "rewinddir") }
sub pp_closedir { unop(@_, "closedir") }
sub pp_getpgrp { unop(@_, "getpgrp") }
sub pp_localtime { unop(@_, "localtime") }
sub pp_gmtime { unop(@_, "gmtime") }
sub pp_alarm { unop(@_, "alarm") }
sub pp_sleep { unop(@_, "sleep") }

sub pp_dofile { unop(@_, "do") }
sub pp_entereval { unop(@_, "eval") }

sub pp_ghbyname { unop(@_, "gethostbyname") }
sub pp_gnbyname { unop(@_, "getnetbyname") }
sub pp_gpbyname { unop(@_, "getprotobyname") }