use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
+ OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
- OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
- OPpREVERSE_INPLACE OPpCONST_NOVER
+ OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
- PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_NONDESTRUCT
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
- ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
- ($] < 5.011 ? 'CVf_LOCKED' : ());
-$VERSION = 0.99;
+ ($] < 5.008004 ? () : 'OPpSORT_INPLACE'),
+ ($] < 5.008006 ? () : qw(OPpSORT_DESCEND OPpITER_REVERSED)),
+ ($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
+ ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
+ ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
+ ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
+$VERSION = "1.04";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
BEGIN {
- # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
- # be to fake up a dummy CVf_LOCKED that will never actually be true.
- *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
+ # Easiest way to keep this code portable between version looks to
+ # be to fake up a dummy constant that will never actually be true.
+ foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
+ OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
+ PMf_NONDESTRUCT)) {
+ no strict 'refs';
+ *{$_} = sub () {0} unless *{$_}{CODE};
+ }
}
# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
# - fixed reference constants (\"str")
# - handle empty programs gracefully
-# - handle infinte loops (for (;;) {}, while (1) {})
+# - handle infinite loops (for (;;) {}, while (1) {})
# - differentiate between `for my $x ...' and `my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
# - added support for Ilya's OPpTARGET_MY optimization
# - elided arrows before `()' subscripts when possible
# Changes between 0.59 and 0.60
-# - support for method attribues was added
+# - support for method attributes was added
# - some warnings fixed
# - separate recognition of constant subs
-# - rewrote continue block handling, now recoginizing for loops
+# - 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
# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
# op/getpid 2 - can't assign to shared my() declaration (threads only)
# 'my $x : shared = 5'
-# op/override 7 - parens on overriden require change v-string interpretation
+# op/override 7 - parens on overridden require change v-string interpretation
# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
# c.f. 'BEGIN { *f = sub {0} }; f 2'
# op/pat 774 - losing Unicode-ness of Latin1-only strings
#
# subs_declared
# keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
+# That means we can omit parentheses from the arguments. It also means we
+# need to put CORE:: on core functions of the same name.
#
# subs_deparsed
# Keeps track of fully qualified names of all deparsed subs.
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
- $stash = \%$pack;
+ $stash = \%{"main::$pack"};
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
my $op = shift;
# This OP might be almost anything, though it won't be a
# nextstate. (It's the initialization, so in the canonical case it
- # will be an sassign.) The sibling is a lineseq whose first child
- # is a nextstate and whose second is a leaveloop.
+ # will be an sassign.) The sibling is (old style) a lineseq whose
+ # first child is a nextstate and whose second is a leaveloop, or
+ # (new style) an unstack whose sibling is a leaveloop.
my $lseq = $op->sibling;
- if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
+ return 0 unless !is_state($op) and !null($lseq);
+ if ($lseq->name eq "lineseq") {
if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
&& (my $sib = $lseq->first->sibling)) {
return (!null($sib) && $sib->name eq "leaveloop");
}
+ } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
+ my $sib = $lseq->sibling;
+ return $sib && !null($sib) && $sib->name eq "leaveloop";
}
return 0;
}
if ($name eq "umask" && $kid =~ /^\d+$/) {
$kid = sprintf("%#o", $kid);
}
- return "$name($kid)";
+ return $self->keyword($name) . "($kid)";
} else {
$kid = $self->deparse($kid, 16);
if ($name eq "umask" && $kid =~ /^\d+$/) {
$kid = sprintf("%#o", $kid);
}
+ $name = $self->keyword($name);
if (substr($kid, 0, 1) eq "\cS") {
# use kid's parens
return $name . substr($kid, 1);
and not $self->{'avoid_local'}{$$op}) {
my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
if( $our_local eq 'our' ) {
- # XXX This assertion fails code with non-ASCII identifiers,
- # like ./ext/Encode/t/jperl.t
- die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
+ if ( $text !~ /^\W(\w+::)*\w+\z/
+ and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
+ ) {
+ die "Unexpected our($text)\n";
+ }
$text =~ s/(\w+::)+//;
}
if (want_scalar($op)) {
}
}
if (is_for_loop($kids[$i])) {
- $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
+ $callback->($expr . $self->for_loop($kids[$i], 0),
+ $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
next;
}
$expr .= $self->deparse($kids[$i], (@kids != 1)/2);
$self->{'warnings'} = $warning_bits;
}
- if ($self->{'hints'} != $op->hints) {
- push @text, declare_hints($self->{'hints'}, $op->hints);
- $self->{'hints'} = $op->hints;
+ my $hints = $] < 5.008009 ? $op->private : $op->hints;
+ if ($self->{'hints'} != $hints) {
+ push @text, declare_hints($self->{'hints'}, $hints);
+ $self->{'hints'} = $hints;
}
# hack to check that the hint hash hasn't changed
sub pp_unstack { return "" } # see also leaveloop
+sub keyword {
+ my $self = shift;
+ my $name = shift;
+ return $name if $name =~ /^CORE::/; # just in case
+ if (
+ $name !~ /^(?:chom?p|exec|system)\z/
+ && !defined eval{prototype "CORE::$name"}
+ ) { return $name }
+ if (
+ exists $self->{subs_declared}{$name}
+ or
+ exists &{"$self->{curstash}::$name"}
+ ) {
+ return "CORE::$name"
+ }
+ return $name;
+}
+
sub baseop {
my $self = shift;
my($op, $cx, $name) = @_;
- return $name;
+ return $self->keyword($name);
}
sub pp_stub {
my $self = shift;
my($op, $cx) = @_;
if ($cx <= 4) {
- $self->pfixop($op, $cx, "not ", 4);
+ $self->pfixop($op, $cx, $self->keyword("not")." ", 4);
} else {
$self->pfixop($op, $cx, "!", 21);
}
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ return $self->keyword($name)
+ . ($op->flags & OPf_SPECIAL ? "()" : "");
}
}
sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_keys { unop(@_, "keys") }
+{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
sub pp_boolkeys {
# no name because its an optimisation op that has no keyword
unop(@_,"");
sub pp_next { loopex(@_, "next") }
sub pp_redo { loopex(@_, "redo") }
sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
+sub pp_dump { loopex(@_, $_[0]->keyword("dump")) }
sub ftst {
my $self = shift;
my(@exprs);
my $parens = ($cx >= 5) || $self->{'parens'};
my $kid = $op->first->sibling;
- return $name if null $kid;
+ return $self->keyword($name) if null $kid;
my $first;
$name = "socketpair" if $name eq "sockpair";
+ my $fullname = $self->keyword($name);
my $proto = prototype("CORE::$name");
if (defined $proto
&& $proto =~ /^;?\*/
push @exprs, $self->deparse($kid, 6);
}
if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
- return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
+ return "$exprs[0] = $fullname"
+ . ($parens ? "($exprs[0])" : " $exprs[0]");
}
if ($parens) {
- return "$name(" . join(", ", @exprs) . ")";
+ return "$fullname(" . join(", ", @exprs) . ")";
} else {
- return "$name " . join(", ", @exprs);
+ return "$fullname " . join(", ", @exprs);
}
}
sub pp_glob {
my $self = shift;
my($op, $cx) = @_;
+ if ($op->flags & OPf_SPECIAL) {
+ return $self->deparse($op->first->sibling);
+ }
my $text = $self->dq($op->first->sibling); # skip pushmark
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
or $text =~ /[<>]/) {
$fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
}
my $len = $self->deparse($kid->sibling, 6);
+ my $name = $self->keyword('truncate');
if ($parens) {
- return "truncate($fh, $len)";
+ return "$name($fh, $len)";
} else {
- return "truncate $fh, $len";
+ return "$name $fh, $len";
}
}
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
}
- my $name2 = $name;
+ my $name2;
if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
- $name2 = 'reverse sort';
+ $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
}
+ else { $name2 = $self->keyword($name) }
if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
return "$exprs[0] = $name2 $indir $exprs[0]";
}
$ary = $self->deparse($ary, 1);
}
if (null $var) {
- if ($enter->flags & OPf_SPECIAL) { # thread special var
+ if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
+ # thread special var, under 5005threads
$var = $self->pp_threadsv($enter, 1);
} else { # regular my() variable
$var = $self->pp_padsv($enter, 1);
my $self = shift;
my($op, $cx) = @_;
my $init = $self->deparse($op, 1);
- return $self->loop_common($op->sibling->first->sibling, $cx, $init);
+ my $s = $op->sibling;
+ my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
+ return $self->loop_common($ll, $cx, $init);
}
sub pp_leavetry {
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
-my @threadsv_names;
-
-BEGIN {
- @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
- "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
- "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
- "!", "@");
-}
-
+my @threadsv_names = B::threadsv_names;
sub pp_threadsv {
my $self = shift;
my($op, $cx) = @_;
return $prefix . $amper. $kid;
}
} else {
- # glob() invocations can be translated into calls of
- # CORE::GLOBAL::glob with a second parameter, a number.
- # Reverse this.
- if ($kid eq "CORE::GLOBAL::glob") {
- $kid = "glob";
- $args =~ s/\s*,[^,]+$//;
- }
-
- # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
+ # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
# so it must have been translated from a keyword call. Translate
# it back.
$kid =~ s/^CORE::GLOBAL:://;
# skip pushmark if it exists (readpipe() vs ``)
my $child = $op->first->sibling->isa('B::NULL')
? $op->first : $op->first->sibling;
- return single_delim("qx", '`', $self->dq($child));
+ if ($self->pure_string($child)) {
+ return single_delim("qx", '`', $self->dq($child, 1));
+ }
+ unop($self, @_, "readpipe");
}
sub dquote {
my $self = shift;
my($op, $cx) = @_;
my($from, $to);
- if (class($op) eq "PVOP") {
- ($from, $to) = tr_decode_byte($op->pv, $op->private);
+ my $class = class($op);
+ my $priv_flags = $op->private;
+ if ($class eq "PVOP") {
+ ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
+ } elsif ($class eq "PADOP") {
+ ($from, $to)
+ = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
} else { # class($op) eq "SVOP"
- ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
+ ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
}
my $flags = "";
- $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
- $flags .= "d" if $op->private & OPpTRANS_DELETE;
+ $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
+ $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
$to = "" if $from eq $to and $flags eq "";
- $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
return "tr" . double_delim($from, $to) . $flags;
}
+sub pp_transr { &pp_trans . 'r' }
+
sub re_dq_disambiguate {
my ($first, $last) = @_;
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
=item *
-If a keyword is over-ridden, and your program explicitly calls
-the built-in version by using CORE::keyword, the output of B::Deparse
-will not reflect this. If you run the resulting code, it will call
-the over-ridden version rather than the built-in one. (Maybe there
-should be an option to B<always> print keyword calls as C<CORE::name>.)
-
-=item *
-
Some constants don't print correctly either with or without B<-d>.
For instance, neither B::Deparse nor Data::Dumper know how to print
dual-valued scalars correctly, as in:
Lexical (my) variables declared in scopes external to a subroutine
appear in code2ref output text as package variables. This is a tricky
-problem, as perl has no native facility for refering to a lexical variable
+problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
=item *