view release on metacpan or  search on metacpan

lib/B/DeparseTree/PPfns.pm  view on Meta::CPAN

sub elem
{
    my ($self, $op, $cx, $left, $right, $padname) = @_;
    my($array, $idx) = ($op->first, $op->first->sibling);

    my $idx_info = $self->elem_or_slice_single_index($idx, $op);
    my $opts = {body => [$idx_info]};

    unless ($array->name eq $padname) { # Maybe this has been fixed
	$opts->{other_ops} = [$array];
	$array = $array->first; # skip rv2av (or ex-rv2av in _53+)
    }
    my @texts = ();
    my $info;
    my $array_name=$self->elem_or_slice_array_name($array, $left, $padname, 1);
    if ($array_name) {
	if ($array_name !~ /->\z/) {
	    if ($array_name eq '#') {
		$array_name = '${#}';
	    }  else {
		$array_name = '$' . $array_name ;
	    }
	}
	push @texts, $array_name;
	push @texts, $left if $left;
	push @texts, $idx_info->{text}, $right;
	return info_from_list($op, $self, \@texts, '', 'elem', $opts)
    } else {
	# $x[20][3]{hi} or expr->[20]
	my $type;
	my $array_info = $self->deparse($array, 24, $op);
	push @{$info->{body}}, $array_info;
	@texts = ($array_info->{text});
	if (is_subscriptable($array)) {
	    push @texts, $left, $idx_info->{text}, $right;
	    $type = 'elem_no_arrow';
	} else {
	    push @texts, '->', $left, $idx_info->{text}, $right;
	    $type = 'elem_arrow';
	}
	return info_from_list($op, $self, \@texts, '', $type, $opts);
    }
    Carp::confess("unhandled condition in elem");
}

sub e_anoncode($$)
{
    my ($self, $info) = @_;
    my $sub_info = $self->deparse_sub($info->{code});
    return $self->info_from_template('sub anonymous', $sub_info->{op},
				     'sub %c', [0], [$sub_info]);
}

# Handle filetest operators -r, stat, etc.
sub filetest
{
    my($self, $op, $cx, $name) = @_;
    if (B::class($op) eq "UNOP") {
	# Genuine '-X' filetests are exempt from the LLAFR, but not
	# l?stat()
	if ($name =~ /^-/) {
	    my $kid = $self->deparse($op->first, 16, $op);
	    return $self->info_from_template("filetest $name", $op,
					     "$name %c", undef, [$kid],
					     {maybe_parens => [$self, $cx, 16]});
	}
	return $self->maybe_parens_unop($name, $op->first, $cx, $op);
    } elsif (B::class($op) =~ /^(SV|PAD)OP$/) {
	my ($fmt, $type);
	my $gv_node = $self->pp_gv($op, 1);
	if ($self->func_needs_parens($gv_node->{text}, $cx, 16)) {
	    $fmt = "$name(%c)";
	    $type = "filetest $name()";
	} else {
	    $fmt = "$name %c";
	    $type = "filetest $name";
	}
	return $self->info_from_template($type, $op, $fmt, undef, [$gv_node]);
    } else {
	# I don't think baseop filetests ever survive ck_filetest, but...
	return $self->info_from_string("filetest $name", $op, $name);
    }
}

sub for_loop($$$$) {
    my ($self, $op, $cx, $parent) = @_;
    my $init = $self->deparse($op, 1, $parent);
    my $s = $op->sibling;
    my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
    return $self->loop_common($ll, $cx, $init);
}

# Returns in function (whose name is not passed as a parameter) will
# need to surround its argements (the first argument is $first_param)
# in parenthesis. To determine this, we also pass in the operator
# precedence, $prec, and the current expression context value, $cx
sub func_needs_parens($$$$)
{
    my($self, $first_param, $cx, $prec) = @_;
    return ($prec <= $cx) || (substr($first_param, 0, 1) eq "(") || $self->{'parens'};
}

sub givwhen
{
    my($self, $op, $cx, $give_when) = @_;

    my @arg_spec = ();
    my @nodes = ();
    my $enterop = $op->first;
    my $fmt;
    my ($head, $block);
    if ($enterop->flags & B::OPf_SPECIAL) {
	$head = $self->keyword("default");
	$fmt = "$give_when ($head)\n\%+%c\n%-}\n";
	$block = $self->deparse($enterop->first, 0, $enterop, $op);
    }
    else {
	my $cond = $enterop->first;
	my $cond_node = $self->deparse($cond, 1, $enterop, $op);
	push @nodes, $cond_node;