view release on metacpan or  search on metacpan

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

	# Tried and true fallback method:
	# a method has been defined for this pp_op special.
	# call that.
	$meth = "pp_" . $name;
	$info = $self->$meth($op, $cx);
    }

    Carp::confess("nonref return for $meth deparse: $info") if !ref($info);
    Carp::confess("not B::DeparseTree:Node returned for $meth: $info")
	if !$info->isa("B::DeparseTree::TreeNode");
    $info->{parent} = $$parent if $parent;
    $info->{cop} = $self->{'curcop'};
    my $got_op = $info->{op};
    if ($got_op) {
	if ($got_op != $op) {
	    # Do something here?
	    # printf("XX final op 0x%x is not requested 0x%x\n",
	    # 	   $$op, $$got_op);
	}
    } else {
	$info->{op} = $op;
    }
    $self->{optree}{$$op} = $info;
    if ($info->{other_ops}) {
	foreach my $other (@{$info->{other_ops}}) {
	    if (!ref $other) {
		Carp::confess "$meth returns invalid other $other";
	    } elsif ($other->isa("B::DeparseTree::TreeNode")) {
		# "$other" has been set up to mark a particular portion
		# of the info.
		$self->{optree}{$other->{addr}} = $other;
		$other->{parent} = $$op;
	    } else {
	    	# "$other" is just the OP. Have it mark everything
	    	# or "info".
	    	$self->{optree}{$$other} = $info;
	    }
	}
    }
    return $info;
}

# Deparse a subroutine
sub deparse_sub($$$$)
{
    my ($self, $cv, $start_op) = @_;

    # Sanity checks..
    Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
    Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");

    # First get protype and sub attribute information
    local $self->{'curcop'} = $self->{'curcop'};
    my $proto = '';
    if ($cv->FLAGS & SVf_POK) {
	$proto .= "(". $cv->PV . ")";
    }
    if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
        $proto .= ":";
        $proto .= " lvalue" if $cv->CvFLAGS & CVf_LVALUE;
        $proto .= " locked" if $cv->CvFLAGS & CVf_LOCKED;
        $proto .= " method" if $cv->CvFLAGS & CVf_METHOD;
    }

    local($self->{'curcv'}) = $cv;
    local($self->{'curcvlex'});
    local(@$self{qw'curstash warnings hints hinthash'})
	= @$self{qw'curstash warnings hints hinthash'};

    # Now deparse subroutine body

    my $root = $cv->ROOT;
    my ($body, $node);

    local $B::overlay = {};
    if (not B::Deparse::null $root) {
	$self->pessimise($root, $cv->START);
	my $lineseq = $root->first;
	if ($lineseq->name eq "lineseq") {
	    my @ops;
	    for(my $o=$lineseq->first; $$o; $o=$o->sibling) {
		push @ops, $o;
	    }
	    $body = $self->lineseq($root, 0, @ops);
	    my $scope_en = $self->find_scope_en($lineseq);
	}
	elsif ($start_op) {
	    $body = $self->deparse($start_op, 0, $lineseq);
	} else {
	    $body = $self->deparse($root->first, 0, $lineseq);
	}

	my $fn_name = $cv->GV->NAME;
	$node = $self->info_from_template("sub $fn_name$proto",
					  $lineseq,
					  "$proto\n%|{\n%+%c\n%-}",
					  [0], [$body]);
	$body->{parent} = $$lineseq;
	$self->{optree}{$$lineseq} = $node;

    } else {
	my $sv = $cv->const_sv;
	if ($$sv) {
	    # uh-oh. inlinable sub... format it differently
	    $node = $self->info_from_template('inline sub', $sv,
					      "$proto\n%|{\n%+%c\n%-}",
					      [0], [$self->const($sv, 0)]);
	} else {
	    # XSUB? (or just a declaration)
	    $node = $self->info_from_string("XSUB or sub declaration", $proto);
	}
    }


    # Should we create a real node for this instead of the copy?
    $self->{optree}{$$root} = $node;

    # Add additional DeparseTree tracking info
    if ($start_op) {
	$node->{op} = $start_op;
	$self->{'optree'}{$$start_op} = $node;