view release on metacpan or  search on metacpan

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

	$kid = $kid->sibling;
    }
    elsif (my $targ = $op->targ) {
	$binop = 1;
	$var = $self->padname($targ);
    }
    my $flags = "";
    my $pmflags = $op->pmflags;
    if (B::Deparse::null($op->pmreplroot)) {
	$repl = $kid;
	$kid = $kid->sibling;
    } else {
	push @other_ops, $op->pmreplroot;
	$repl = $op->pmreplroot->first; # skip substcont
    }
    while ($repl->name eq "entereval") {
	push @other_ops, $repl;
	$repl = $repl->first;
	    $flags .= "e";
    }
    {
	local $self->{in_subst_repl} = 1;
	if ($pmflags & PMf_EVAL) {
	    $repl_info = $self->deparse($repl->first, 0, $repl);
	} else {
	    $repl_info = $self->dq($repl);
	}
    }
    if (not B::Deparse::null my $code_list = $op->code_list) {
	$re = $self->code_list($code_list);
    } elsif (B::Deparse::null $kid) {
	$re = B::Deparse::re_uninterp(B::Deparse::escape_re(B::Deparse::re_unback($op->precomp)));
    } else {
	my ($re_info, $junk) = $self->regcomp($kid, 1);
	$re = $re_info->{text};
    }
    $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
    $flags .= "e" if $pmflags & PMf_EVAL;
    $flags .= $self->re_flags($op);
    $flags = join '', sort split //, $flags;
    $flags = $substwords{$flags} if $substwords{$flags};
    my $core_s = $self->keyword("s"); # maybe CORE::s

    # FIXME: we need to attach the $repl_info someplace.
    my $repl_text = $repl_info->{text};
    my $opts->{other_ops} = \@other_ops if @other_ops;
    my $find_replace_re = double_delim($re, $repl_text);

    if ($binop) {
	return $self->info_from_template("=~ s///", $op,
					 "%c =~ ${core_s}%c$flags",
					 undef,
					 [$var, $find_replace_re],
					 {maybe_parens => [$self, $cx, 20]});
    } else {
	return $self->info_from_string("s///", $op, "${core_s}${find_replace_re}$flags");
    }
    Carp::confess("unhandled condition in pp_subst");
}

# This handles the category of unary operators, e.g. alarm(), caller(),
# close()..
sub unop
{
    my($self, $op, $cx, $name, $nollafr) = @_;
    my $kid;
    my $opts = {};
    if ($op->flags & B::OPf_KIDS) {
	my $parent = $op;
	$kid = $op->first;
 	if (not $name) {
 	    # this deals with 'boolkeys' right now
	    my $kid_node = $self->deparse($kid, $cx, $parent);
	    $opts->{prev_expr} = $kid_node;
	    return $self->info_from_template("unop, see child", $op, "%c",
					     undef, [$kid_node], $opts);
 	}
	my $builtinname = $name;
	$builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
	if (defined prototype($builtinname)
	   && $builtinname ne 'CORE::readline'
	   && prototype($builtinname) =~ /^;?\*/
	    && $kid->name eq "rv2gv") {
	    my $rv2gv = $kid;
	    $parent = $rv2gv;
	    $kid = $kid->first;
	    $opts->{other_ops} = [$rv2gv];
	}

	if ($nollafr) {
	    $kid = $self->deparse($kid, 16, $parent);
	    $opts->{maybe_parens} = [$self, $cx, 16],
	    my $fullname = $self->keyword($name);
	    return $self->info_from_template("unary operator $name noallafr", $op,
					     "$fullname %c", undef, [$kid], $opts);
	}
	return $self->maybe_parens_unop($name, $kid, $cx, $parent, $opts)

    } else {
	$opts->{maybe_parens} = [$self, $cx, 16];
	my $fullname = ($self->keyword($name));
	my $fmt = "$fullname";
	$fmt .= '()' if $op->flags & B::OPf_SPECIAL;
	return $self->info_from_template("unary operator $name", $op, $fmt,
					 undef, [], $opts);
    }
}

# This handles category of symbolic prefix and postfix unary operators,
# e.g $x++, -r, +$x.
sub pfixop
{
    my $self = shift;
    my($op, $cx, $operator, $prec, $flags) = (@_, 0);
    my $operand = $self->deparse($op->first, $prec, $op);
    my ($type, $fmt);
    my @nodes;
    if ($flags & POSTFIX) {
	@nodes = ($operand, $operator);
	$type = "prefix $operator";
	$fmt = "%c%c";