view release on metacpan or  search on metacpan

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

}

sub const_dumper
{
    my $self = shift;
    my($sv, $cx) = @_;
    my $ref = $sv->object_2svref();
    my $dumper = Data::Dumper->new([$$ref], ['$v']);
    $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
    my $str = $dumper->Dump();
    if ($str =~ /^\$v/) {
	# FIXME: ???
        return info_from_text($sv, $self, ['${my', $str, '\$v}'], 'const_dumper_my', {});
    } else {
        return $self->info_from_string("constant string", $sv, $str);
    }
}

# This is a special case of scopeop and lineseq, for the case of the
# main_root.
sub deparse_root {
    my $self = shift;
    my($op) = @_;
    local(@$self{qw'curstash warnings hints hinthash'})
      = @$self{qw'curstash warnings hints hinthash'};
    my @ops;
    return if B::Deparse::null $op->first; # Can happen, e.g., for Bytecode without -k
    for (my $kid = $op->first->sibling; !B::Deparse::null($kid); $kid = $kid->sibling) {
	push @ops, $kid;
    }
    my $fn = sub {
	my ($exprs, $i, $info, $parent) = @_;
	my $text = $info->{text};
	my $op = $ops[$i];
	$text =~ s/\f//;
	$text =~ s/\n$//;
	$text =~ s/;\n?\z//;
	$text =~ s/^\((.+)\)$/$1/;
	$info->{type} = $op->name;
	$info->{op} = $op;

	$self->{optree}{$$op} = $info;

	$info->{text} = $text;
	$info->{parent} = $$parent if $parent;
	push @$exprs, $info;
    };
    my $info = $self->walk_lineseq($op, \@ops, $fn);
    my @skipped_ops;
    if (exists $info->{other_ops}) {
	@skipped_ops = @{$info->{other_ops}};
	push @skipped_ops, $op->first;
    } else {
	@skipped_ops = ($op->first);
    }
    $info->{other_ops} = \@skipped_ops;
    return $info;

}

sub update_node($$$$)
{
    my ($self, $node, $prev_expr, $op) = @_;
    $node->{prev_expr} = $prev_expr;
    my $addr = $prev_expr->{addr};
    if ($addr && ! exists $self->{optree}{$addr}) {
	$self->{optree}{$addr} = $node if $op;
    }
}

sub walk_lineseq
{
    my ($self, $op, $kids, $callback) = @_;
    my @kids = @$kids;
    my @body = (); # Accumulated node structures
    my $expr;
    my $prev_expr = undef;
    my $fix_cop = undef;
    for (my $i = 0; $i < @kids; $i++) {
	if (B::Deparse::is_state $kids[$i]) {
	    $expr = ($self->deparse($kids[$i], 0, $op));
	    $callback->(\@body, $i, $expr, $op);
	    $prev_expr = $expr;
	    if ($fix_cop) {
		$fix_cop->{text} = $expr->{text};
	    }
	    $i++;
	    if ($i > $#kids) {
		last;
	    }
	}
	if (B::Deparse::is_for_loop($kids[$i])) {
	    print "YYY for loop\n" if $ENV{'DEBUG_DEPARSETREE'};
	    my $loop_expr = $self->for_loop($kids[$i], 0);
	    $callback->(\@body,
			$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1,
			$loop_expr);
	    $prev_expr = $loop_expr;
	    next;
	}
	$expr = $self->deparse($kids[$i], (@kids != 1)/2, $op);

	# Perform semantic action on $expr accumulating the result
	# in @body. $op is the parent, and $i is the child position
	$callback->(\@body, $i, $expr, $op);
	unless (exists $expr->{prev_expr}) {
	    $self->update_node($expr, $prev_expr, $op);
	}
	$prev_expr = $expr;
	if ($fix_cop) {
	    $fix_cop->{text} = $expr->{text};
	}

	# If the text portion of a COP is empty, set up to fill it in
	# from the text portion of the next node.
	if (B::class($op) eq "COP" && !$expr->{text}) {
	    $fix_cop = $op;
	} else {
	    $fix_cop = undef;
	}
    }