view release on metacpan or  search on metacpan

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

    my $self = shift;
    my($op, $cx) = @_;
    my $cond = $op->first;
    my $true = $cond->sibling;
    my $false = $true->sibling;
    my $cuddle = $self->{'cuddle'};
    my $type = 'if';
    unless ($cx < 1 and (B::Deparse::is_scope($true) and $true->name ne "null") and
	    (B::Deparse::is_scope($false) || B::Deparse::is_ifelse_cont($false))
	    and $self->{'expand'} < 7) {
	# FIXME: turn into template
	my $cond_info = $self->deparse($cond, 8, $op);
	my $true_info = $self->deparse($true, 6, $op);
	my $false_info = $self->deparse($false, 8, $op);
	return $self->info_from_template('ternary ?', $op, "%c ? %c : %c",
					 [0, 1, 2],
					 [$cond_info, $true_info, $false_info],
					 {maybe_parens => [$self, $cx, 8]});
    }

    my $cond_info = $self->deparse($cond, 1, $op);
    my $true_info = $self->deparse($true, 0, $op);
    my $fmt = "%|if (%c) {\n%+%c\n%-}";
    my @exprs = ($cond_info, $true_info);
    my @args_spec = (0, 1);

    my $i;
    for ($i=0; !B::Deparse::null($false) and B::Deparse::is_ifelse_cont($false); $i++) {
	my $newop = $false->first;
	my $newcond = $newop->first;
	my $newtrue = $newcond->sibling;
	$false = $newtrue->sibling; # last in chain is OP_AND => no else
	if ($newcond->name eq "lineseq")
	{
	    # lineseq to ensure correct line numbers in elsif()
	    # Bug #37302 fixed by change #33710.
	    $newcond = $newcond->first->sibling;
	}
	my $newcond_info = $self->deparse($newcond, 1, $op);
	my $newtrue_info = $self->deparse($newtrue, 0, $op);
	push @args_spec, scalar(@args_spec), scalar(@args_spec)+1;
	push @exprs, $newcond_info, $newtrue_info;
	$fmt .= " elsif ( %c ) {\n%+%c\n\%-}";
    }
    $type .= " elsif($i)" if $i;
    my $false_info;
    if (!B::Deparse::null($false)) {
	$false_info = $self->deparse($false, 0, $op);
	$fmt .= "${cuddle}else {\n%+%c\n%-}";
	push @args_spec, scalar(@args_spec);
	push @exprs, $false_info;
	$type .= ' else';
    }
    return $self->info_from_template($type, $op, $fmt, \@args_spec, \@exprs);
}

sub pp_const {
    my $self = shift;
    my($op, $cx) = @_;
    if ($op->private & OPpCONST_ARYBASE) {
        return $self->info_from_string('const $[', $op, '$[');
    }
    # if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
    # 	return $self->const_sv($op)->PV;
    # }
    my $sv = $self->const_sv($op);
    return $self->const($sv, $cx);;
}

# Handle subroutine calls. These are a bit complicated.
# NOTE: this is not right for CPerl, so it needs to be split out.
sub pp_entersub
{
    my($self, $op, $cx) = @_;
    return $self->e_method($op, $self->_method($op, $cx))
        unless B::Deparse::null $op->first->sibling;
    my $prefix = "";
    my $amper = "";
    my($kid, @exprs, @args_spec);
    if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
	$prefix = "do ";
    } elsif ($op->private & OPpENTERSUB_AMPER) {
	$amper = "&";
    }

    $kid = $op->first;

    my $other_ops = [$kid, $kid->first];
    $kid = $kid->first->sibling; # skip ex-list, pushmark

    my $kid_start = $kid;
    # FIXME: phase this out.
    for (; not B::Deparse::null $kid->sibling; $kid = $kid->sibling) {
	push @exprs, $kid;
    }
    my ($simple, $proto, $subname_info) = (0, undef, undef);
    if (B::Deparse::is_scope($kid)) {
	$amper = "&";
	$subname_info = $self->deparse($kid, 0, $op);
	$subname_info->{texts} = ['{', $subname_info->texts, '}'];
	$subname_info->{text} = join('', @$subname_info->{texts});
    } elsif ($kid->first->name eq "gv") {
	my $gv = $self->gv_or_padgv($kid->first);
	my $cv;
	if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
	 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
	    $proto = $cv->PV if $cv->FLAGS & SVf_POK;
	}
	$simple = 1; # only calls of named functions can be prototyped
	$subname_info = $self->deparse($kid, 24, $op);
	my $fq;
	# Fully qualify any sub name that conflicts with a lexical.
	if ($self->lex_in_scope("&$kid")
	 || $self->lex_in_scope("&$kid", 1))
	{
	    $fq++;
	} elsif (!$amper) {
	    if ($subname_info->{text} eq 'main::') {
		$subname_info->{text} = '::';
	    } else {
	      if ($kid !~ /::/ && $kid ne 'x') {