deparse.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

    my $bare = 0;
    my $body;
    my $cond = undef;
    if ($kid->name eq "lineseq") { # bare or infinite loop 
	if (is_state $kid->last) { # infinite
	    $head = "for (;;) "; # shorter than while (1)
	    $cond = "";
	} else {
	    $bare = 1;
	}
	$body = $kid;
    } elsif ($enter->name eq "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->name eq "rv2gv") {
	    $var = $self->pp_rv2sv($var, 1);
	} elsif ($var->name eq "gv") {
	    $var = "\$" . $self->deparse($var, 1);
	}
	$head = "foreach $var ($ary) ";
	$body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
    } elsif ($kid->name eq "null") { # while/until
	$kid = $kid->first;
	my $name = {"and" => "while", "or" => "until"}->{$kid->name};
	$cond = $self->deparse($kid->first, 1);
	$head = "$name ($cond) ";
	$body = $kid->first->sibling;
    } elsif ($kid->name eq "stub") { # bare and empty
	return "{;}"; # {} could be a hashref
    }
    # If there isn't a continue block, then the next pointer for the loop
    # will point to the unstack, which is kid's penultimate child, except
    # in a bare loop, when it will point to the leaveloop. When neither of
    # these conditions hold, then the third-to-last child in the continue
    # block (or the last in a bare loop).
    my $cont_start = $enter->nextop;
    my $cont;
    if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
	if ($bare) {
	    $cont = $body->last;
	} else {
	    $cont = $body->first;
	    while (!null($cont->sibling->sibling->sibling)) {
		$cont = $cont->sibling;
	    }
	}
	my $state = $body->first;
	my $cuddle = $self->{'cuddle'};
	my @states;
	for (; $$state != $$cont; $state = $state->sibling) {
	    push @states, $state;
	}
	$body = $self->lineseq(@states);
	if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
	    $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
	    $cont = "\cK";
	} else {
	    $cont = $cuddle . "continue {\n\t" .
	      $self->deparse($cont, 0) . "\n\b}\cK";
	}
    } else {
	$cont = "\cK";
	$body = $self->deparse($body, 0);
    }
    return $head . "{\n\t" . $body . "\n\b}" . $cont;
}

sub pp_leaveloop { loop_common(@_, "") }

sub for_loop {
    my $self = shift;
    my($op, $cx) = @_;
    my $init = $self->deparse($op, 1);
    return $self->loop_common($op->sibling, $cx, $init);
}

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

BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }

sub pp_null {
    my $self = shift;
    my($op, $cx) = @_;
    if (class($op) eq "OP") {
	# old value is lost
	return $self->{'ex_const'} if $op->targ == OP_CONST;
    } elsif ($op->first->name eq "pushmark") {
	return $self->pp_list($op, $cx);
    } elsif ($op->first->name eq "enter") {
	return $self->pp_leave($op, $cx);
    } elsif ($op->targ == OP_STRINGIFY) {
	return $self->dquote($op, $cx);
    } elsif (!null($op->first->sibling) and
	     $op->first->sibling->name eq "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->name eq "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;
    return $self->padname_sv($targ)->PVX;
}

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

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 gv_or_padgv {
    my $self = shift;
    my $op = shift;
    if (class($op) eq "PADOP") {
	return $self->padval($op->padix);
    } else { # class($op) eq "SVOP"
	return $op->gv;
    }
}

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

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

sub pp_aelemfast {
    my $self = shift;
    my($op, $cx) = @_;
    my $gv = $self->gv_or_padgv($op);
    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->name eq "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->name eq "const") { # constant list
	my $av = $self->const_sv($kid);
	return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
    } else {
	return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
    }
 }

sub is_subscriptable {
    my $op = shift;
    if ($op->name =~ /^[ahg]elem/) {
	return 1;
    } elsif ($op->name eq "entersub") {
	my $kid = $op->first;
	return 0 unless null $kid->sibling;
	$kid = $kid->first;
	$kid = $kid->sibling until null $kid->sibling;
	return 0 if is_scope($kid);
	$kid = $kid->first;
	return 0 if $kid->name eq "gv";
	return 0 if is_scalar($kid);
	return is_subscriptable($kid);	
    } else {
	return 0;
    }
}

sub elem {
    my $self = shift;
    my ($op, $cx, $left, $right, $padname) = @_;
    my($array, $idx) = ($op->first, $op->first->sibling);
    unless ($array->name eq $padname) { # Maybe this has been fixed	
	$array = $array->first; # skip rv2av (or ex-rv2av in _53+)
    }
    if ($array->name 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 = is_subscriptable($array) ? "" : "->";
	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(@_, "[", "]", "padav")) }
sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "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->name eq "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->name eq $regname or $array->name eq "null";
    if (is_scope($array)) {
	$array = "{" . $self->deparse($array, 0) . "}";
    } elsif ($array->name eq $padname) {
	$array = $self->padany($array);
    } else {
	$array = $self->deparse($array, 24);
    }
    $kid = $op->first->sibling; # skip pushmark
    if ($kid->name eq "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(@_, "[", "]", "rv2av", "padav")) }
sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "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 want_scalar {
    my $op = shift;
    return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
}

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

sub method {
    my $self = shift;
    my($op, $cx) = @_;
    my $kid = $op->first->sibling; # skip pushmark
    my($meth, $obj, @exprs);
    if ($kid->name eq "list" and want_list $kid) {
	# When an indirect object isn't a bareword but the args are in
	# parens, the parens aren't part of the method syntax (the LLAFR
	# doesn't apply), but they make a list with OPf_PARENS set that
	# doesn't get flattened by the append_elem that adds the method,
	# making a (object, arg1, arg2, ...) list where the object
	# usually is. This can be distinguished from 
	# `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
	# object) because in the later the list is in scalar context
	# as the left side of -> always is, while in the former
	# the list is in list context as method arguments always are.
	# (Good thing there aren't method prototypes!)
	$meth = $kid->sibling;
	$kid = $kid->first->sibling; # skip pushmark
	$obj = $kid;
	$kid = $kid->sibling;
	for (; not null $kid; $kid = $kid->sibling) {
	    push @exprs, $self->deparse($kid, 6);
	}
    } else {
	$obj = $kid;
	$kid = $kid->sibling;
	for (; not null $kid->sibling; $kid = $kid->sibling) {
	    push @exprs, $self->deparse($kid, 6);
	}
	$meth = $kid;
    }
    $obj = $self->deparse($obj, 24);
    if ($meth->name eq "method_named") {
	$meth = $self->const_sv($meth)->PV;
    } else {
	$meth = $meth->first;
	if ($meth->name eq "const") {
	    # As of 5.005_58, this case is probably obsoleted by the
	    # method_named case above
	    $meth = $self->const_sv($meth)->PV; # needs to be bare
	} else {
	    $meth = $self->deparse($meth, 1);
	}
    }
    my $args = join(", ", @exprs);	
    $kid = $obj . "->" . $meth;
    if ($args) {
	return $kid . "(" . $args . ")"; # parens mandatory
    } else {
	return $kid;
    }
}

# returns "&" if the prototype doesn't match the args,
# or ("", $args_after_prototype_demunging) if it does.
sub check_proto {
    my $self = shift;
    my($proto, @args) = @_;
    my($arg, $real);
    my $doneok = 0;
    my @reals;
    # An unbackslashed @ or % gobbles up the rest of the args
    $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
    while ($proto) {
	$proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
	my $chr = $1;
	if ($chr eq "") {
	    return "&" if @args;
	} elsif ($chr eq ";") {
	    $doneok = 1;
	} elsif ($chr eq "@" or $chr eq "%") {
	    push @reals, map($self->deparse($_, 6), @args);
	    @args = ();
	} else {
	    $a