B-DeparseTree
view release on metacpan or search on metacpan
doc/OLD_CHANGES.md view on Meta::CPAN
* support for method attributes was added
* some warnings fixed
* separate recognition of constant subs
* rewrote continue block handling, now recognizing for loops
* added more control of expanding control structures
# Changes between 0.60 and 0.61 (mostly by Robin Houston)
* many bug-fixes
* support for pragmas and 'use'
* support for the little-used $[ variable
* support for `__DATA__` sections
* UTF-8 support
* `BEGIN`, `CHECK`, `INIT` and `END` blocks
* scoping of subroutine declarations fixed
* compile-time output from the input program can be suppressed, so that the output is just the deparsed code. (a change to O.pm in fact)
* `our()` declarations
* *all* the known bugs are now listed in the BUGS section
* comprehensive test mechanism (TEST -deparse)
# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
lib/B/DeparseTree/P518.pm view on Meta::CPAN
# Like dq(), but different
sub re_dq {
my $self = shift;
my ($op, $extended) = @_;
my ($re_dq_info, $fmt);
my $type = $op->name;
my ($re, @texts);
my $opts = {};
if ($type eq "const") {
return info_from_text($op, $self, '$[', 're_dq_const', {})
if $op->private & OPpCONST_ARYBASE;
my $unbacked = B::Deparse::re_unback($self->const_sv($op)->as_string);
return B::Deparse::re_uninterp_extended(escape_extended_re($unbacked))
if $extended;
return B::Deparse::re_uninterp(B::Deparse::escape_str($unbacked));
} elsif ($type eq "concat") {
my $first = $self->re_dq($op->first, $extended);
my $last = $self->re_dq($op->last, $extended);
return B::Deparse::re_dq_disambiguate($first, $last);
} elsif ($type eq "uc") {
lib/B/DeparseTree/P522.pm view on Meta::CPAN
# Like dq(), but different
sub re_dq {
my $self = shift;
my ($op, $extended) = @_;
my ($re_dq_info, $fmt);
my $type = $op->name;
my ($re, @texts);
my $opts = {};
if ($type eq "const") {
return info_from_text($op, $self, '$[', 're_dq_const', {})
if $op->private & OPpCONST_ARYBASE;
my $unbacked = B::Deparse::re_unback($self->const_sv($op)->as_string);
return B::Deparse::re_uninterp_extended(escape_extended_re($unbacked))
if $extended;
return B::Deparse::re_uninterp(B::Deparse::escape_str($unbacked));
} elsif ($type eq "concat") {
my $first = $self->re_dq($op->first, $extended);
my $last = $self->re_dq($op->last, $extended);
return B::Deparse::re_dq_disambiguate($first, $last);
} elsif ($type eq "uc") {
lib/B/DeparseTree/P526.pm view on Meta::CPAN
}
# Like dq(), but different
sub re_dq {
my $self = shift;
my ($op) = @_;
my ($re_dq_info, $fmt);
my $type = $op->name;
if ($type eq "const") {
return '$[' if $op->private & OPpCONST_ARYBASE;
my $unbacked = B::Deparse::re_unback($self->const_sv($op)->as_string);
return B::Deparse::re_uninterp(escape_re($unbacked));
} elsif ($type eq "concat") {
my $first = $self->re_dq($op->first);
my $last = $self->re_dq($op->last);
return B::Deparse::re_dq_disambiguate($first, $last);
} elsif ($type eq "uc") {
$re_dq_info = $self->re_dq($op->first->sibling);
$fmt = '\U%c\E';
$type .= ' uc';
lib/B/DeparseTree/P526c.pm view on Meta::CPAN
}
# Like dq(), but different
sub re_dq {
my $self = shift;
my ($op) = @_;
my ($re_dq_info, $fmt);
my $type = $op->name;
if ($type eq "const") {
return '$[' if $op->private & OPpCONST_ARYBASE;
my $unbacked = B::Deparse::re_unback($self->const_sv($op)->as_string);
return B::Deparse::re_uninterp(escape_re($unbacked));
} elsif ($type eq "concat") {
my $first = $self->re_dq($op->first);
my $last = $self->re_dq($op->last);
return B::Deparse::re_dq_disambiguate($first, $last);
} elsif ($type eq "uc") {
$re_dq_info = $self->re_dq($op->first->sibling);
$fmt = '\U%c\E';
$type .= ' uc';
lib/B/DeparseTree/PP.pm view on Meta::CPAN
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.
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
}
elsif (ref $val) {
@names = @$val;
}
else {
@names = split' ', $val;
}
$hint_bits |= $strict_bits{$_} for @names;
}
elsif ($name eq '$[') {
if (OPpCONST_ARYBASE) {
$arybase = $val;
} else {
croak "\$[ can't be non-zero on this perl" unless $val == 0;
}
}
elsif ($name eq 'integer'
|| $name eq 'bytes'
|| $name eq 'utf8') {
require "$name.pm";
if ($val) {
$hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
}
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
my $lhs = $self->deparse_binop_left($op, $left, $prec);
my $rhs = $self->deparse_binop_right($op, $right, $prec);
return $self->info_from_template(".$eq", $op,
"%c .$eq %c", undef, [$lhs, $rhs],
{maybe_parens => [$self, $cx, $prec]});
}
# Handle pp_dbstate, and pp_nextstate and COP ops.
#
# Notice how subs and formats are inserted between statements here;
# also $[ assignments and pragmas.
sub cops
{
my ($self, $op, $cx, $name) = @_;
$self->{'curcop'} = $op;
my @texts = ();
my $opts = {};
my @args_spec = ();
my $fmt = '%;';
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
$opts->{'omit_next_semicolon'} = 1;
}
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @texts, $self->keyword("package") . " $stash;";
$self->{'curstash'} = $stash;
}
if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
push @texts, '$[ = '. $op->arybase .";";
$self->{'arybase'} = $op->arybase;
}
my $warnings = $op->warnings;
my $warning_bits;
if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
$warning_bits = $warnings::Bits{"all"} & WARN_MASK;
}
elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
$warning_bits = $warnings::NONE;
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
return "/$from/$to/";
}
}
sub dq($$$)
{
my ($self, $op, $parent) = @_;
my $type = $op->name;
my $info;
if ($type eq "const") {
return info_from_text($op, $self, '$[', 'dq constant ary', {}) if $op->private & OPpCONST_ARYBASE;
return info_from_text($op, $self,
B::Deparse::uninterp(B::Deparse::escape_str(B::Deparse::unback($self->const_sv($op)->as_string))),
'dq constant', {});
} elsif ($type eq "concat") {
my $first = $self->dq($op->first, $op);
my $last = $self->dq($op->last, $op);
# FIXME: convert to newer conventions
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
($last->{text} =~ /^[A-Z\\\^\[\]_?]/ &&
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
Carp::confess("unhandled condition in maybe_parens_unop");
}
sub maybe_qualify {
my ($self,$prefix,$name) = @_;
my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
return $name if !$prefix || $name =~ /::/;
return $self->{'curstash'}.'::'. $name
if
$name =~ /^(?!\d)\w/ # alphabetic
&& $v !~ /^\$[ab]\z/ # not $a or $b
&& !$globalnames{$name} # not a global name
&& $self->{hints} & $strict_bits{vars} # strict vars
&& !$self->B::Deparse::lex_in_scope($v,1) # no "our"
or $self->B::Deparse::lex_in_scope($v); # conflicts with "my" variable
return $name;
}
# FIXME: need a way to pass in skipped_ops
# FIXME: see if we can move to some 5.xx-specific module
sub maybe_targmy
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
my @text;
my $stash = $op->stashpv;
if ($stash ne $self->{'curstash'}) {
push @text, $self->keyword("package") . " $stash;\n";
$self->{'curstash'} = $stash;
}
if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
push @text, '$[ = '. $op->arybase .";\n";
$self->{'arybase'} = $op->arybase;
}
my $warnings = $op->warnings;
my $warning_bits;
if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
$warning_bits = $warnings::Bits{"all"} & WARN_MASK;
}
elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
$warning_bits = $warnings::NONE;
( run in 0.535 second using v1.01-cache-2.11-cpan-b61123c0432 )