deparse.pm

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

sub pp_orassign { logassignop(@_, "||=") }

sub listop {
    my $self = shift;
    my($op, $cx, $name) = @_;
    my(@exprs);
    my $parens = ($cx >= 5) || $self->{'parens'};
    my $kid = $op->first->sibling;
    return $name if null $kid;
    my $first = $self->deparse($kid, 6);
    $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
    push @exprs, $first;
    $kid = $kid->sibling;
    for (; !null($kid); $kid = $kid->sibling) {
	push @exprs, $self->deparse($kid, 6);
    }
    if ($parens) {
	return "$name(" . join(", ", @exprs) . ")";
    } else {
	return "$name " . join(", ", @exprs);
    }
}

sub pp_bless { listop(@_, "bless") }
sub pp_atan2 { listop(@_, "atan2") }
sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
sub pp_index { listop(@_, "index") }
sub pp_rindex { listop(@_, "rindex") }
sub pp_sprintf { listop(@_, "sprintf") }
sub pp_formline { listop(@_, "formline") } # see also deparse_format
sub pp_crypt { listop(@_, "crypt") }
sub pp_unpack { listop(@_, "unpack") }
sub pp_pack { listop(@_, "pack") }
sub pp_join { listop(@_, "join") }
sub pp_splice { listop(@_, "splice") }
sub pp_push { listop(@_, "push") }
sub pp_unshift { listop(@_, "unshift") }
sub pp_reverse { listop(@_, "reverse") }
sub pp_warn { listop(@_, "warn") }
sub pp_die { listop(@_, "die") }
# Actually, return is exempt from the LLAFR (see examples in this very
# module!), but for consistency's sake, ignore that fact
sub pp_return { listop(@_, "return") }
sub pp_open { listop(@_, "open") }
sub pp_pipe_op { listop(@_, "pipe") }
sub pp_tie { listop(@_, "tie") }
sub pp_dbmopen { listop(@_, "dbmopen") }
sub pp_sselect { listop(@_, "select") }
sub pp_select { listop(@_, "select") }
sub pp_read { listop(@_, "read") }
sub pp_sysopen { listop(@_, "sysopen") }
sub pp_sysseek { listop(@_, "sysseek") }
sub pp_sysread { listop(@_, "sysread") }
sub pp_syswrite { listop(@_, "syswrite") }
sub pp_send { listop(@_, "send") }
sub pp_recv { listop(@_, "recv") }
sub pp_seek { listop(@_, "seek") }
sub pp_fcntl { listop(@_, "fcntl") }
sub pp_ioctl { listop(@_, "ioctl") }
sub pp_flock { listop(@_, "flock") }
sub pp_socket { listop(@_, "socket") }
sub pp_sockpair { listop(@_, "sockpair") }
sub pp_bind { listop(@_, "bind") }
sub pp_connect { listop(@_, "connect") }
sub pp_listen { listop(@_, "listen") }
sub pp_accept { listop(@_, "accept") }
sub pp_shutdown { listop(@_, "shutdown") }
sub pp_gsockopt { listop(@_, "getsockopt") }
sub pp_ssockopt { listop(@_, "setsockopt") }
sub pp_chown { listop(@_, "chown") }
sub pp_unlink { listop(@_, "unlink") }
sub pp_chmod { listop(@_, "chmod") }
sub pp_utime { listop(@_, "utime") }
sub pp_rename { listop(@_, "rename") }
sub pp_link { listop(@_, "link") }
sub pp_symlink { listop(@_, "symlink") }
sub pp_mkdir { listop(@_, "mkdir") }
sub pp_open_dir { listop(@_, "opendir") }
sub pp_seekdir { listop(@_, "seekdir") }
sub pp_waitpid { listop(@_, "waitpid") }
sub pp_system { listop(@_, "system") }
sub pp_exec { listop(@_, "exec") }
sub pp_kill { listop(@_, "kill") }
sub pp_setpgrp { listop(@_, "setpgrp") }
sub pp_getpriority { listop(@_, "getpriority") }
sub pp_setpriority { listop(@_, "setpriority") }
sub pp_shmget { listop(@_, "shmget") }
sub pp_shmctl { listop(@_, "shmctl") }
sub pp_shmread { listop(@_, "shmread") }
sub pp_shmwrite { listop(@_, "shmwrite") }
sub pp_msgget { listop(@_, "msgget") }
sub pp_msgctl { listop(@_, "msgctl") }
sub pp_msgsnd { listop(@_, "msgsnd") }
sub pp_msgrcv { listop(@_, "msgrcv") }
sub pp_semget { listop(@_, "semget") }
sub pp_semctl { listop(@_, "semctl") }
sub pp_semop { listop(@_, "semop") }
sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
sub pp_gpbynumber { listop(@_, "getprotobynumber") }
sub pp_gsbyname { listop(@_, "getservbyname") }
sub pp_gsbyport { listop(@_, "getservbyport") }
sub pp_syscall { listop(@_, "syscall") }

sub pp_glob {
    my $self = shift;
    my($op, $cx) = @_;
    my $text = $self->dq($op->first->sibling);  # skip pushmark
    if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
	or $text =~ /[<>]/) { 
	return 'glob(' . single_delim('qq', '"', $text) . ')';
    } else {
	return '<' . $text . '>';
    }
}

# Truncate is special because OPf_SPECIAL makes a bareword first arg
# be a filehandle. This could probably be better fixed in the core
# by moving the GV lookup into ck_truc.

sub pp_truncate {
    my $self = shift;
    my($op, $cx) = @_;
    my(@exprs);
    my $parens = ($cx >= 5) || $self->{'parens'};
    my $kid = $op->first->sibling;
    my($fh, $len);
    if ($op->flags & OPf_SPECIAL) {
	# $kid is an OP_CONST
	$fh = $kid->sv->PV;
    } else {
	$fh = $self->deparse($kid, 6);
        $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
    }
    my $len = $self->deparse($kid->sibling, 6);
    if ($parens) {
	return "truncate($fh, $len)";
    } else {
	return "truncate $fh, $len";
    }

}

sub indirop {
    my $self = shift;
    my($op, $cx, $name) = @_;
    my($expr, @exprs);
    my $kid = $op->first->sibling;
    my $indir = "";
    if ($op->flags & OPf_STACKED) {
	$indir = $kid;
	$indir = $indir->first; # skip rv2gv
	if (is_scope($indir)) {
	    $indir = "{" . $self->deparse($indir, 0) . "}";
	} else {
	    $indir = $self->deparse($indir, 24);
	}
	$indir = $indir . " ";
	$kid = $kid->sibling;
    }
    for (; !null($kid); $kid = $kid->sibling) {
	$expr = $self->deparse($kid, 6);
	push @exprs, $expr;
    }
    return $self->maybe_parens_func($name,
				    $indir . join(", ", @exprs),
				    $cx, 5);
}

sub pp_prtf { indirop(@_, "printf") }
sub pp_print { indirop(@_, "print") }
sub pp_sort { indirop(@_, "sort") }

sub mapop {
    my $self = shift;
    my($op, $cx, $name) = @_;
    my($expr, @exprs);
    my $kid = $op->first; # this is the (map|grep)start
    $kid = $kid->first->sibling; # skip a pushmark
    my $code = $kid->first; # skip a null
    if (is_scope $code) {
	$code = "{" . $self->deparse($code, 1) . "} ";
    } else {
	$code = $self->deparse($code, 24) . ", ";
    }
    $kid = $kid->sibling;
    for (; !null($kid); $kid = $kid->sibling) {
	$expr = $self->deparse($kid, 6);
	push @exprs, $expr if $expr;
    }
    return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
}

sub pp_mapwhile { mapop(@_, "map") }   
sub pp_grepwhile { mapop(@_, "grep") }   

sub pp_list {
    my $self = shift;
    my($op, $cx) = @_;
    my($expr, @exprs);
    my $kid = $op->first->sibling; # skip pushmark
    my $lop;
    my $local = "either"; # could be local(...) or my(...)
    for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
	# This assumes that no other private flags equal 128, and that
	# OPs that store things other than flags in their op_private,
	# like OP_AELEMFAST, won't be immediate children of a list.
	unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
	{
	    $local = ""; # or not
	    last;
	}
	if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
	    ($local = "", last) if $local eq "local";
	    $local = "my";
	} elsif ($lop->ppaddr ne "pp_undef") { # local()
	    ($local = "", last) if $local eq "my";
	    $local = "local";
	}
    }
    $local = "" if $local eq "either"; # no point if it's all undefs
    return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
    for (; !null($kid); $kid = $kid->sibling) {
	if ($local) {
	    if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
		$lop = $kid->first;
	    } else {
		$lop = $kid;
	    }
	    $self->{'avoid_local'}{$$lop}++;
	    $expr = $self->deparse($kid, 6);
	    delete $self->{'avoid_local'}{$$lop};
	} else {
	    $expr = $self->deparse($kid, 6);
	}
	push @exprs, $expr;
    }
    if ($local) {
	return "$local(" . join(", ", @exprs) . ")";
    } else {
	return $self->maybe_parens( join(", ", @exprs), $cx, 6);	
    }
}

sub pp_cond_expr {
    my $self = shift;
    my($op, $cx) = @_;
    my $cond = $op->first;
    my $true = $cond->sibling;
    my $false = $true->sibling;
    my $cuddle = $self->{'cuddle'};
    unless ($cx == 0 and is_scope($true) and is_scope($false)) {
	$cond = $self->deparse($cond, 8);
	$true = $self->deparse($true, 8);
	$false = $self->deparse($false, 8);
	return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
    } 
    $cond = $self->deparse($cond, 1);
    $true = $self->deparse($true, 0);    
    if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
	my $head = "if ($cond) {\n\t$true\n\b}";
	my @elsifs;
	while (!null($false) and $false->ppaddr eq "pp_lineseq") {
	    my $newop = $false->first->sibling->first;
	    my $newcond = $newop->first;
	    my $newtrue = $newcond->sibling;
	    $false = $newtrue->sibling; # last in chain is OP_AND => no else
	    $newcond = $self->deparse($newcond, 1);
	    $newtrue = $self->deparse($newtrue, 0);
	    push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
	}
	if (!null($false)) {	    
	    $false = $cuddle . "else {\n\t" .
	      $self->deparse($false, 0) . "\n\b}\cK";
	} else {
	    $false = "\cK";
	}
	return $head . join($cuddle, "", @elsifs) . $false; 
    }
    $false = $self->deparse($false, 0);
    return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
}

sub pp_leaveloop {
    my $self = shift;
    my($op, $cx) = @_;
    my $enter = $op->first;
    my $kid = $enter->sibling;
    local($self->{'curstash'}) = $self->{'curstash'};
    my $head = "";
    my $bare = 0;
    if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop 
	if (is_state $kid->last) { # infinite
	    $head = "for (;;) "; # shorter than while (1)
	} else {
	    $bare = 1;
	}
    } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
	my $ary = $enter->first->sibling; # first was pushmark
	my $var = $ary->sibling;
	if ($enter->flags & OPf_STACKED
	    and not null $ary->first->sibling->sibling)
	{
	    $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
	      $self->deparse($ary->first->sibling->sibling, 9);
	} else {
	    $ary = $self->deparse($ary, 1);
	}
	if (null $var) {
	    if ($enter->flags & OPf_SPECIAL) { # thread special var
		$var = $self->pp_threadsv($enter, 1);
	    } else { # regular my() variable
		$var = $self->pp_padsv($enter, 1);
		if ($self->padname_sv($enter->targ)->IVX ==
		    $kid->first->first->sibling->last->cop_seq)
		{
		    # If the scope of this variable closes at the last
		    # statement of the loop, it must have been
		    # declared here.
		    $var = "my " . $var;
		}
	    }
	} elsif ($var->ppaddr eq "pp_rv2gv") {
	    $var = $self->pp_rv2sv($var, 1);
	} elsif ($var->ppaddr eq "pp_gv") {
	    $var = "\$" . $self->deparse($var, 1);
	}
	$head = "foreach $var ($ary) ";
	$kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
    } elsif ($kid->ppaddr eq "pp_null") { # while/until
	$kid = $kid->first;
	my $name = {"pp_and" => "while", "pp_or" => "until"}
	            ->{$kid->ppaddr};
	$head = "$name (" . $self->deparse($kid->first, 1) . ") ";
	$kid = $kid->first->sibling;
    } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
	return "{;}"; # {} could be a hashref
    }
    # The third-to-last kid is the continue block if the pointer used
    # by `next BLOCK' points to its first OP, which happens to be the
    # the op_next of the head of the _previous_ statement. 
    # Unless it's a bare loop, in which case it's last, since there's
    # no unstack or extra nextstate.
    # Except if the previous head isn't null but the first kid is
    # (because it's a nulled out nextstate in a scope), in which
    # case the head's next is advanced past the null but the nextop's
    # isn't, so we need to try nextop->next.
    my($cont, $precont);
    if ($bare) {
	$cont = $kid->first;
	while (!null($cont->sibling)) {
	    $precont = $cont;
	    $cont = $cont->sibling;
	}	
    } else {
	$cont = $kid->first;
	while (!null($cont->sibling->sibling->sibling)) {
	    $precont = $cont;
	    $cont = $cont->sibling;
	}
    }
    if ($precont and $ {$precont->next} == $ {$enter->nextop}
	|| $ {$precont->next} == $ {$enter->nextop->next} )
    {
       my $state = $kid->first;
       my $cuddle = $self->{'cuddle'};
       my($expr, @exprs);
       for (; $$state != $$cont; $state = $state->sibling) {
	   $expr = "";
	   if (is_state $state) {
	       $expr = $self->deparse($state, 0);
	       $state = $state->sibling;
	       last if null $kid;
	   }
	   $expr .= $self->deparse($state, 0);
	   push @exprs, $expr if $expr;
       }
       $kid = join(";\n", @exprs);
       $cont = $cuddle . "continue {\n\t" .
	 $self->deparse($cont, 0) . "\n\b}\cK";
    } else {
	$cont = "\cK";
	$kid = $self->deparse($kid, 0);
    }
    return $head . "{\n\t" . $kid . "\n\b}" . $cont;
}

sub pp_leavetry {
    my $self = shift;
    return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}

sub OP_CONST () { 5 }

# XXX need a better way to do this
sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 }

sub pp_null {
    my $self = shift;
    my($op, $cx) = @_;
    if (class($op) eq "OP") {
	return "'???'" if $op->targ == OP_CONST; # old value is lost
    } elsif ($op->first->ppaddr eq "pp_pushmark") {
	return $self->pp_list($op, $cx);
    } elsif ($op->first->ppaddr eq "pp_enter") {
	return $self->pp_leave($op, $cx);
    } elsif ($op->targ == OP_STRINGIFY) {
	return $self->dquote($op);
    } elsif (!null($op->first->sibling) and
	     $op->first->sibling->ppaddr eq "pp_readline" and
	     $op->first->sibling->flags & OPf_STACKED) {
	return $self->maybe_parens($self->deparse($op->first, 7) . " = "
				   . $self->deparse($op->first->sibling, 7),
				   $cx, 7);
    } elsif (!null($op->first->sibling) and
	     $op->first->sibling->ppaddr eq "pp_trans" and
	     $op->first->sibling->flags & OPf_STACKED) {
	return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
				   . $self->deparse($op->first->sibling, 20),
				   $cx, 20);
    } else {
	return $self->deparse($op->first, $cx);
    }
}

sub padname {
    my $self = shift;
    my $targ = shift;
    my $str = $self->padname_sv($targ)->PV;
    return padname_fix($str);
}

sub padany {
    my $self = shift;
    my $op = shift;
    return substr($self->padname($op->targ), 1); # skip $/@/%
}