view release on metacpan or  search on metacpan

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

sub deparse_binop_right {
    my $self = shift;
    my($op, $right, $prec) = @_;
    if ($right{assoc_class($op)} && $right{assoc_class($right)}
	and $right{assoc_class($op)} == $right{assoc_class($right)})
    {
	return $self->deparse($right, $prec - .00001, $op);
    } else {
	return $self->deparse($right, $prec, $op);
    }
}

# Iterate via sibling links a list of OP nodes starting with
# $first. Each OP is deparsed, with $op and $precedence each to get a
# node. Then the "prev" field in the node is set, and finally it is
# pushed onto the end of the $exprs reference ARRAY.
sub deparse_op_siblings($$$$$)
{
    my ($self, $exprs, $kid, $op, $precedence) = @_;
    my $prev_expr = undef;
    $prev_expr = $exprs->[-1] if scalar @{$exprs};
    for ( ; !B::Deparse::null($kid); $kid = $kid->sibling) {
	my $expr = $self->deparse($kid, $precedence, $op);
	if (defined $expr) {
	    $expr->{prev_expr} = $prev_expr;
	    $prev_expr = $expr;
	    push @$exprs, $expr;
	}
    }
}


# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
# note that tr(from)/to/ is OK, but not tr/from/(to)
sub double_delim {
    my($from, $to) = @_;
    my($succeed, $delim);
    if ($from !~ m[/] and $to !~ m[/]) {
	return "/$from/$to/";
    } elsif (($succeed, $from) = B::Deparse::balanced_delim($from) and $succeed) {
	if (($succeed, $to) = B::Deparse::balanced_delim($to) and $succeed) {
	    return "$from$to";
	} else {
	    for $delim ('/', '"', '#') { # note no "'" -- s''' is special
		return "$from$delim$to$delim" if index($to, $delim) == -1;
	    }
	    $to =~ s[/][\\/]g;
	    return "$from/$to/";
	}
    } else {
	for $delim ('/', '"', '#') { # note no '
	    return "$delim$from$delim$to$delim"
		if index($to . $from, $delim) == -1;
	}
	$from =~ s[/][\\/]g;
	$to =~ s[/][\\/]g;
	return "/$from/$to/";
    }
}

sub dq($$$)
{
    my ($self, $op, $parent) = @_;
    my $type = $op->name;
    my $info;
    if ($type eq "const") {
	return info_from_text($op, $self, '$[', 'dq constant ary', {}) if $op->private & OPpCONST_ARYBASE;
	return info_from_text($op, $self,
			      B::Deparse::uninterp(B::Deparse::escape_str(B::Deparse::unback($self->const_sv($op)->as_string))),
			 'dq constant', {});
    } elsif ($type eq "concat") {
	my $first = $self->dq($op->first, $op);
	my $last  = $self->dq($op->last, $op);

	# FIXME: convert to newer conventions
	# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
	($last->{text} =~ /^[A-Z\\\^\[\]_?]/ &&
	    $first->{text} =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
	    || ($last->{text} =~ /^[:'{\[\w_]/ && #'
		$first->{text} =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);

	return info_from_list($op, $self, [$first->{text}, $last->{text}], '', 'dq_concat',
			      {body => [$first, $last]});
    } elsif ($type eq "join") {
	return $self->deparse($op->last, 26, $op); # was join($", @ary)
    } else {
	return $self->deparse($op, 26, $parent);
    }
    my $kid = $self->dq($op->first->sibling, $op);
    my $kid_text = $kid->{text};
    if ($type eq "uc") {
	$info = info_from_lists(['\U', $kid, '\E'], '', 'dq_uc', {});
    } elsif ($type eq "lc") {
	$info = info_from_lists(['\L', $kid, '\E'], '', 'dq_lc', {});
    } elsif ($type eq "ucfirst") {
	$info = info_from_lists(['\u', $kid, '\E'], '', 'dq_ucfirst', {});
    } elsif ($type eq "lcfirst") {
	$info = info_from_lists(['\l', $kid, '\E'], '', 'dq_lcfirst', {});
    } elsif ($type eq "quotemeta") {
	$info = info_from_lists(['\Q', $kid, '\E'], '', 'dq_quotemeta', {});
    } elsif ($type eq "fc") {
	$info = info_from_lists(['\F', $kid, '\E'], '', 'dq_fc', {});
    }
    $info->{body} = [$kid];
    return $info;
}

# Handle unary operators that can occur as pseudo-listops inside
# double quotes
sub dq_unop
{
    my($self, $op, $cx, $name, $prec, $flags) = (@_, 0, 0);
    my $kid;
    if ($op->flags & B::OPf_KIDS) {
	my $pushmark_op = undef;
	$kid = $op->first;
	if (not B::Deparse::null $kid->sibling) {
	    # If there's more than one kid, the first is an ex-pushmark.
	    $pushmark_op = $kid;
	    $kid = $kid->sibling;
	}