B-DeparseTree
view release on metacpan or search on metacpan
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
$limit_seq = $nseq if !defined($limit_seq)
or defined($nseq) && $nseq < $limit_seq;
}
$limit_seq = $self->{'limit_seq'}
if defined($self->{'limit_seq'})
&& (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
local $self->{'limit_seq'} = $limit_seq;
my $fn = sub {
my ($exprs, $i, $info, $parent) = @_;
my $op = $ops[$i];
$info->{type} = $op->name unless $info->{type};
$info->{child_pos} = $i;
$info->{op} = $op;
if ($parent) {
Carp::confess("nonref parent, op: $op->name") if !ref($parent);
$info->{parent} = $$parent ;
}
$self->{optree}{$$op} = $info;
push @$exprs, $info;
};
return $self->walk_lineseq($root, \@ops, $fn);
}
# _pessimise_walk(): recursively walk the optree of a sub,
# possibly undoing optimisations along the way.
# walk tree in root-to-branch order
# We add parent pointers in the process.
sub _pessimise_walk {
my ($self, $startop) = @_;
return unless $$startop;
my ($op, $parent_op);
for ($op = $startop; $$op; $op = $op->sibling) {
my $ppname = $op->name;
$self->{ops}{$$op} ||= {};
$self->{ops}{$$op}{op} = $op;
$self->{ops}{$$op}{parent_op} = $startop;
# pessimisations start here
if ($ppname eq "padrange") {
# remove PADRANGE:
# the original optimisation either (1) changed this:
# pushmark -> (various pad and list and null ops) -> the_rest
# or (2), for the = @_ case, changed this:
# pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
# into this:
# padrange ----------------------------------------> the_rest
# so we just need to convert the padrange back into a
# pushmark, and in case (1), set its op_next to op_sibling,
# which is the head of the original chain of optimised-away
# pad ops, or for (2), set it to sibling->first, which is
# the original gv[_].
$B::overlay->{$$op} = {
type => OP_PUSHMARK,
name => 'pushmark',
private => ($op->private & OPpLVAL_INTRO),
};
}
# pessimisations end here
if (class($op) eq 'PMOP'
&& ref($op->pmreplroot)
&& ${$op->pmreplroot}
&& $op->pmreplroot->isa( 'B::OP' ))
{
$self-> _pessimise_walk($op->pmreplroot);
}
if ($op->flags & OPf_KIDS) {
$self-> _pessimise_walk($op->first);
}
}
}
# _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
# possibly undoing optimisations along the way.
# walk tree in execution order
sub _pessimise_walk_exe {
my ($self, $startop, $visited) = @_;
return unless $$startop;
return if $visited->{$$startop};
my $op;
for ($op = $startop; $$op; $op = $op->next) {
last if $visited->{$$op};
$visited->{$$op} = 1;
$self->{ops}{$$op} ||= {};
$self->{ops}{$$op}{op} = $op;
my $ppname = $op->name;
if ($ppname =~
/^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
# entertry is also a logop, but its op_other invariably points
# into the same chain as the main execution path, so we skip it
) {
$self->_pessimise_walk_exe($op->other, $visited);
}
elsif ($ppname eq "subst") {
$self->_pessimise_walk_exe($op->pmreplstart, $visited);
}
elsif ($ppname =~ /^(enter(loop|iter))$/) {
# redoop and nextop will already be covered by the main block
# of the loop
$self->_pessimise_walk_exe($op->lastop, $visited);
}
# pessimisations start here
}
}
# Go through an optree and "remove" some optimisations by using an
# overlay to selectively modify or un-null some ops. Deparsing in the
# absence of those optimisations is then easier.
#
# Note that older optimisations are not removed, as Deparse was already
# written to recognise them before the pessimise/overlay system was added.
sub pessimise {
my ($self, $root, $start) = @_;
no warnings 'recursion';
# walk tree in root-to-branch order
$self->_pessimise_walk($root);
my %visited;
# walk tree in execution order
$self->_pessimise_walk_exe($start, \%visited);
}
sub style_opts
{
my ($self, $opts) = @_;
my $opt;
while (length($opt = substr($opts, 0, 1))) {
if ($opt eq "C") {
$self->{'cuddle'} = " ";
$opts = substr($opts, 1);
} elsif ($opt eq "i") {
$opts =~ s/^i(\d+)//;
$self->{'indent_size'} = $1;
} elsif ($opt eq "T") {
$self->{'use_tabs'} = 1;
$opts = substr($opts, 1);
} elsif ($opt eq "v") {
$opts =~ s/^v([^.]*)(.|$)//;
$self->{'ex_const'} = $1;
}
}
}
# B::Deparse name is print_protos
sub extract_prototypes($)
{
my $self = shift;
my $ar;
my @ret;
foreach $ar (@{$self->{'protos_todo'}}) {
my $body;
if (defined $ar->[1]) {
if (ref $ar->[1]) {
# FIXME: better optree tracking?
# And use formatting markup?
my $node = $self->const($ar->[1]->RV,0);
my $body_node =
$self->info_from_template("protos", undef,
"() {\n %c;\n}",
undef, [$node]);
$body = $body_node->{text};
} else {
$body = sprintf " (%s);", $ar->[1];
}
} else {
$body = ";";
}
push @ret, sprintf "sub %s%s\n", $ar->[0], $body;
}
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
}
# This gets called automatically when option:
# -MO="DeparseTree,sC" is added
# Running this prints out the program text.
sub compile {
my(@args) = @_;
return sub {
my $self = B::DeparseTree->new(@args);
# First deparse command-line args
if (defined $^I) { # deparse -i
print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
}
if ($^W) { # deparse -w
print qq(BEGIN { \$^W = $^W; }\n);
}
if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
my $fs = perlstring($/) || 'undef';
my $bs = perlstring($O::savebackslash) || 'undef';
print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
}
my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
? B::unitcheck_av->ARRAY
: ();
my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
if ($] < 5.020) {
for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
$self->B::Deparse::todo($block, 0);
}
} else {
my @names = qw(BEGIN UNITCHECK CHECK INIT END);
my @blocks = (\@BEGINs, \@UNITCHECKs, \@CHECKs, \@INITs, \@ENDs);
while (@names) {
my ($name, $blocks) = (shift @names, shift @blocks);
for my $block (@$blocks) {
$self->todo($block, 0, $name);
}
}
}
$self->B::Deparse::stash_subs();
local($SIG{"__DIE__"}) =
sub {
if ($self->{'curcop'}) {
my $cop = $self->{'curcop'};
my($line, $file) = ($cop->line, $cop->file);
print STDERR "While deparsing $file near line $line,\n";
}
use Data::Printer;
my @bt = caller(1);
p @bt;
};
$self->{'curcv'} = main_cv;
$self->{'curcvlex'} = undef;
print $self->extract_prototypes;
@{$self->{'subs_todo'}} =
sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
my $root = main_root;
local $B::overlay = {};
if ($] < 5.021) {
unless (B::Deparse::null $root) {
$self->pessimise($root, main_start);
# Print deparsed program
print $self->deparse_root($root)->{text}, "\n";
}
} else {
unless (B::Deparse::null $root) {
$self->B::Deparse::pad_subs($self->{'curcv'});
# Check for a stub-followed-by-ex-cop, resulting from a program
# consisting solely of sub declarations. For backward-compati-
# bility (and sane output) we don’t want to emit the stub.
# leave
# enter
# stub
# ex-nextstate (or ex-dbstate)
my $kid;
if ( $root->name eq 'leave'
and ($kid = $root->first)->name eq 'enter'
and !B::Deparse::null($kid = $kid->sibling) and $kid->name eq 'stub'
and !B::Deparse::null($kid = $kid->sibling) and $kid->name eq 'null'
and class($kid) eq 'COP' and B::Deparse::null $kid->sibling )
{
# ignore deparsing routine
} else {
$self->pessimise($root, main_start);
# Print deparsed program
my $root_tree = $self->deparse_root($root);
print $root_tree->{text}, "\n";
}
}
}
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
push @text, $self->next_todo->{text};
}
print join("", @text), "\n" if @text;
# Print __DATA__ section, if necessary
no strict 'refs';
my $laststash = defined $self->{'curcop'}
? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
if (defined *{$laststash."::DATA"}{IO}) {
print $self->keyword("package") . " $laststash;\n"
unless $laststash eq $self->{'curstash'};
print $self->keyword("__DATA__") . "\n";
print readline(*{$laststash."::DATA"});
}
}
}
# "deparse()" is the main function to call to produces a depare tree
# for a give B::OP. This method is the inner loop.
# Rocky's comment with respect to:
# so try to keep it simple
#
# Most normal Perl programs really aren't that big. Yeah, I know there
# are a couple of big pigs like the B::Deparse code itself. The perl5
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
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;
}
$node->{cop} = undef;
$node->{'parent'} = $cv;
return $node;
}
# We have a TODO list of things that must be handled
# at the top level. There are things like
# format statements, "BEGIN" and "use" statements.
# Here we handle the next one.
sub next_todo
{
my ($self, $parent) = @_;
my $ent = shift @{$self->{'subs_todo'}};
( run in 1.102 second using v1.01-cache-2.11-cpan-39bf76dae61 )