view release on metacpan or  search on metacpan

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

    }
    if (@a == 1) {
	return $self->info_from_template('list const: one item',
					 $op, "(%c)", undef, [$a[0]]);
    }

    my @texts = map $_->{text}, @a;
    if ( @a > 2 and !grep(!/^-?\d+$/, @texts)) {
	# collapse a consecutive sequence like (-1,0,1,2) into a range like (-1..2)
	my $first = $texts[0];
	my $i = $first;
	return $self->info_from_template('list const ..', $op,
					 "%c..%c", undef,
					 [$a[0], $a[-1]],
					 {maybe_parens => [$self, $cx, 9]})
	    unless grep $i++ != $_, @texts;
    }
    return $self->info_from_template('list const, more than one item',
				     $op, "%C", [[0, $#a, ', ']], \@a,
				     {maybe_parens => [$self, $cx, $prec]});
}

# This handle list ops: "open", "pack", "return" ...
sub listop
{
    my($self, $op, $cx, $name, $kid, $nollafr) = @_;
    my(@exprs, @new_nodes, @skipped_ops);
    my $parens = ($cx >= 5) || $self->{'parens'};

    unless ($kid) {
	push @skipped_ops, $op->first;
	$kid = $op->first->sibling;
    }

    # If there are no arguments, add final parentheses (or parenthesize the
    # whole thing if the llafr does not apply) to account for cases like
    # (return)+1 or setpgrp()+1.  When the llafr does not apply, we use a
    # precedence of 6 (< comma), as "return, 1" does not need parentheses.
    if (B::Deparse::null $kid) {
	my $fullname = $self->keyword($name);
	my $text = $nollafr
	    ? $self->maybe_parens($fullname, $cx, 7)
	    : $fullname . '()' x (7 < $cx);
	return $self->info_from_string("listop $name", $op, $text);
    }
    my $first;
    my $fullname = $self->keyword($name);
    my $proto = prototype("CORE::$name");
    if (
	 (     (defined $proto && $proto =~ /^;?\*/)
	    || $name eq 'select' # select(F) doesn't have a proto
	 )
	 && $kid->name eq "rv2gv"
	 && !($kid->private & B::OPpLVAL_INTRO)
    ) {
	$first = $self->rv2gv_or_string($kid->first, $op);
    }
    else {
	$first = $self->deparse($kid, 6, $op);
    }
    if ($name eq "chmod" && $first->{text} =~ /^\d+$/) {
	my $transform_fn = sub {sprintf("%#o", $self->info2str(shift))};
	$first = $self->info_from_template("chmod octal", undef,
					   "%F", [[0, $transform_fn]],
					   [$first], {'relink_children' => [0]});
	push @new_nodes, $first;
    }

    # FIXME: fold this into a template
    $first->{text} = "+" + $first->{text}
	if not $parens and not $nollafr and substr($first->{text}, 0, 1) eq "(";

    push @exprs, $first;
    $kid = $kid->sibling;
    if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
	&& !($kid->private & B::OPpLVAL_INTRO)) {
	$first = $self->rv2gv_or_string($kid->first, $op);
	push @exprs, $first;
	$kid = $kid->sibling;
    }

    $self->deparse_op_siblings(\@exprs, $kid, $op, 6);

    if ($name eq "reverse" && ($op->private & B::OPpREVERSE_INPLACE)) {
	my $fmt;
	my $type;
	if ($parens) {
	    $fmt = "%c = $fullname(%c)";
	    $type = "listop reverse ()"
	} else {
	    $fmt = "%c = $fullname(%c)";
	    $type = "listop reverse"
	}
	my @nodes = ($exprs[0], $exprs[0]);
	return $self->info_from_template($type, $op, $fmt, undef,
					 [$exprs[0], $exprs[0]]);
    }

    my $opts = {};
    my $type;
    my $fmt;

    if ($name =~ /^(system|exec)$/
	&& ($op->flags & B::OPf_STACKED)
	&& @exprs > 1)
    {
	# handle the "system(prog a1, a2, ...)" form
	# where there is no ', ' between the first two arguments.
	if ($parens && $nollafr) {
	    $fmt = "($fullname %c %C)";
	    $type = "listop ($fullname)";
	} elsif ($parens) {
	    $fmt = "$fullname(%c %C)";
	    $type = "listop $fullname()";
	} else {
	    $fmt = "$fullname %c %C";
	    $type = "listop $fullname";
	}
	return $self->info_from_template($type, $op, $fmt,
					 [0, [1, $#exprs, ', ']], \@exprs);

    }