This is a live mirror of the Perl 5 development currently hosted at
https://github.com/perl/perl5
https://perl5.git.perl.org
/
perl5.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[perl #74740] Deparse -(f()) correctly
[perl5.git]
/
dist
/
B-Deparse
/
Deparse.pm
diff --git
a/dist/B-Deparse/Deparse.pm
b/dist/B-Deparse/Deparse.pm
index
9bf6606
..
10ab498
100644
(file)
--- a/
dist/B-Deparse/Deparse.pm
+++ b/
dist/B-Deparse/Deparse.pm
@@
-11,38
+11,43
@@
package B::Deparse;
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
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
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
+ OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
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_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
- ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
- ($] < 5.011 ? 'CVf_LOCKED' : ());
-$VERSION = 1.00;
+ PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
+$VERSION = "1.10";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
BEGIN {
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;
+ # List version-specific constants here.
+ # 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 PMf_SKIPWHITE RXf_SKIPWHITE
+ CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
+ PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
+ eval { import B $_ };
+ 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
}
# 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) {})
-# - differentiate between
`for my $x ...' and `
my $x; for $x ...'
+# - handle infin
i
te loops (for (;;) {}, while (1) {})
+# - differentiate between
'for my $x ...' and '
my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
# - various minor cleanups
# - moved globals into an object
-# - added
`
-u', like B::C
+# - added
'
-u', like B::C
# - package declarations using cop_stash
# - subs, formats and code sorted by cop_seq
# Changes between 0.51 and 0.52:
# - package declarations using cop_stash
# - subs, formats and code sorted by cop_seq
# Changes between 0.51 and 0.52:
@@
-50,10
+55,10
@@
BEGIN {
# - added documentation
# Changes between 0.52 and 0.53:
# - many changes adding precedence contexts and associativity
# - added documentation
# Changes between 0.52 and 0.53:
# - many changes adding precedence contexts and associativity
-# - added
`-p' and `
-s' output style options
+# - added
'-p' and '
-s' output style options
# - various other minor fixes
# Changes between 0.53 and 0.54:
# - various other minor fixes
# Changes between 0.53 and 0.54:
-# - added support for new
`
for (1..100)' optimization,
+# - added support for new
'
for (1..100)' optimization,
# thanks to Gisle Aas
# Changes between 0.54 and 0.55:
# - added support for new qr// construct
# thanks to Gisle Aas
# Changes between 0.54 and 0.55:
# - added support for new qr// construct
@@
-62,16
+67,16
@@
BEGIN {
# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
# - fixed $# on non-lexicals broken in last big rewrite
# - added temporary fix for change in opcode of OP_STRINGIFY
# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
# - fixed $# on non-lexicals broken in last big rewrite
# - added temporary fix for change in opcode of OP_STRINGIFY
-# - fixed problem in 0.54's for() patch in
`
for (@ary)'
+# - fixed problem in 0.54's for() patch in
'
for (@ary)'
# - fixed precedence in conditional of ?:
# - fixed precedence in conditional of ?:
-# - tweaked list paren elimination in
`
my($x) = @_'
+# - tweaked list paren elimination in
'
my($x) = @_'
# - made continue-block detection trickier wrt. null ops
# - fixed various prototype problems in pp_entersub
# - added support for sub prototypes that never get GVs
# - added unquoting for special filehandle first arg in truncate
# - made continue-block detection trickier wrt. null ops
# - fixed various prototype problems in pp_entersub
# - added support for sub prototypes that never get GVs
# - added unquoting for special filehandle first arg in truncate
-# - print doubled rv2gv (a bug) as
`*{*GV}' instead of illegal `
**GV'
+# - print doubled rv2gv (a bug) as
'*{*GV}' instead of illegal '
**GV'
# - added semicolons at the ends of blocks
# - added semicolons at the ends of blocks
-# - added -l
`
#line' declaration option -- fixes cmd/subval.t 27,28
+# - added -l
'
#line' declaration option -- fixes cmd/subval.t 27,28
# Changes between 0.56 and 0.561:
# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
# Changes between 0.56 and 0.561:
# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
@@
-84,7
+89,7
@@
BEGIN {
# Changes after 0.57:
# - added parens in \&foo (patch by Albert Dvornik)
# Changes between 0.57 and 0.58:
# Changes after 0.57:
# - added parens in \&foo (patch by Albert Dvornik)
# Changes between 0.57 and 0.58:
-# - fixed
`
0' statements that weren't being printed
+# - fixed
'
0' statements that weren't being printed
# - added methods for use from other programs
# (based on patches from James Duncan and Hugo van der Sanden)
# - added -si and -sT to control indenting (also based on a patch from Hugo)
# - added methods for use from other programs
# (based on patches from James Duncan and Hugo van der Sanden)
# - added -si and -sT to control indenting (also based on a patch from Hugo)
@@
-96,12
+101,12
@@
BEGIN {
# Changes between 0.58 and 0.59
# - added support for Chip's OP_METHOD_NAMED
# - added support for Ilya's OPpTARGET_MY optimization
# Changes between 0.58 and 0.59
# - added support for Chip's OP_METHOD_NAMED
# - added support for Ilya's OPpTARGET_MY optimization
-# - elided arrows before
`
()' subscripts when possible
+# - elided arrows before
'
()' subscripts when possible
# Changes between 0.59 and 0.60
# Changes between 0.59 and 0.60
-# - support for method attribues was added
+# - support for method attribu
t
es was added
# - some warnings fixed
# - separate recognition of constant subs
# - some warnings fixed
# - separate recognition of constant subs
-# - rewrote continue block handling, now recog
i
nizing 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
# - added more control of expanding control structures
# Changes between 0.60 and 0.61 (mostly by Robin Houston)
# - many bug-fixes
@@
-146,7
+151,7
@@
BEGIN {
# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
-# - handle
`
my $x if 0'?
+# - handle
'
my $x if 0'?
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - here-docs?
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - here-docs?
@@
-159,7
+164,7
@@
BEGIN {
# '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'
# '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 overrid
d
en 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
# '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
@@
-235,7
+240,8
@@
BEGIN {
#
# subs_declared
# keys are names of subs for which we've printed declarations.
#
# 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.
#
# subs_deparsed
# Keeps track of fully qualified names of all deparsed subs.
@@
-243,7
+249,7
@@
BEGIN {
# parens: -p
# linenums: -l
# unquote: -q
# parens: -p
# linenums: -l
# unquote: -q
-# cuddle:
` ' or `
\n', depending on -sC
+# cuddle:
' ' or '
\n', depending on -sC
# indent_size: -si
# use_tabs: -sT
# ex_const: -sv
# indent_size: -si
# use_tabs: -sT
# ex_const: -sv
@@
-257,7
+263,7
@@
BEGIN {
# they're inside an expression or at statement level, etc. (see
# chart below). When ops with children call deparse on them, they pass
# along their precedence. Fractional values are used to implement
# they're inside an expression or at statement level, etc. (see
# chart below). When ops with children call deparse on them, they pass
# along their precedence. Fractional values are used to implement
-# associativity (
`($x + $y) + $z' => `
$x + $y + $y') and related
+# associativity (
'($x + $y) + $z' => '
$x + $y + $y') and related
# parentheses hacks. The major disadvantage of this scheme is that
# it doesn't know about right sides and left sides, so say if you
# assign a listop to a variable, it can't tell it's allowed to leave
# parentheses hacks. The major disadvantage of this scheme is that
# it doesn't know about right sides and left sides, so say if you
# assign a listop to a variable, it can't tell it's allowed to leave
@@
-297,7
+303,7
@@
BEGIN {
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
# \t - increase indent
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
# \t - increase indent
-# \b - decrease indent (
`
outdent')
+# \b - decrease indent (
'
outdent')
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
@@
-472,7
+478,7
@@
sub stash_subs {
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
- $stash = \%
$pack
;
+ $stash = \%
{"main::$pack"}
;
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
}
my %stash = svref_2object($stash)->ARRAY;
while (my ($key, $val) = each %stash) {
@@
-728,7
+734,11
@@
sub ambient_pragmas {
}
elsif ($name eq '$[') {
}
elsif ($name eq '$[') {
- $arybase = $val;
+ if (OPpCONST_ARYBASE) {
+ $arybase = $val;
+ } else {
+ croak "\$[ can't be non-zero on this perl" unless $val == 0;
+ }
}
elsif ($name eq 'integer'
}
elsif ($name eq 'integer'
@@
-940,7
+950,7
@@
sub is_state {
return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
}
return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
}
-sub is_miniwhile { # check for one-line loop (
`
foo() while $y--')
+sub is_miniwhile { # check for one-line loop (
'
foo() while $y--')
my $op = shift;
return (!null($op) and null($op->sibling)
and $op->name eq "null" and class($op) eq "UNOP"
my $op = shift;
return (!null($op) and null($op->sibling)
and $op->name eq "null" and class($op) eq "UNOP"
@@
-1000,7
+1010,7
@@
sub maybe_parens {
}
}
}
}
-# same as above, but get around the
`
if it looks like a function' rule
+# same as above, but get around the
'
if it looks like a function' rule
sub maybe_parens_unop {
my $self = shift;
my($name, $kid, $cx) = @_;
sub maybe_parens_unop {
my $self = shift;
my($name, $kid, $cx) = @_;
@@
-1009,18
+1019,19
@@
sub maybe_parens_unop {
if ($name eq "umask" && $kid =~ /^\d+$/) {
$kid = sprintf("%#o", $kid);
}
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);
}
} 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);
} elsif (substr($kid, 0, 1) eq "(") {
# avoid looks-like-a-function trap with extra parens
if (substr($kid, 0, 1) eq "\cS") {
# use kid's parens
return $name . substr($kid, 1);
} elsif (substr($kid, 0, 1) eq "(") {
# avoid looks-like-a-function trap with extra parens
- # (
`
+' can lead to ambiguities)
+ # (
'
+' can lead to ambiguities)
return "$name(" . $kid . ")";
} else {
return "$name $kid";
return "$name(" . $kid . ")";
} else {
return "$name $kid";
@@
-1085,7
+1096,9
@@
sub maybe_my {
my $self = shift;
my($op, $cx, $text) = @_;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
my $self = shift;
my($op, $cx, $text) = @_;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
- my $my = $op->private & OPpPAD_STATE ? "state" : "my";
+ my $my = $op->private & OPpPAD_STATE
+ ? $self->keyword("state")
+ : "my";
if (want_scalar($op)) {
return "$my $text";
} else {
if (want_scalar($op)) {
return "$my $text";
} else {
@@
-1264,7
+1277,7
@@
Carp::confess() unless ref($gv) eq "B::GV";
# If a lexical with the same name is in scope, it may need to be
# fully-qualified.
sub stash_variable {
# If a lexical with the same name is in scope, it may need to be
# fully-qualified.
sub stash_variable {
- my ($self, $prefix, $name) = @_;
+ my ($self, $prefix, $name
, $cx
) = @_;
return "$prefix$name" if $name =~ /::/;
return "$prefix$name" if $name =~ /::/;
@@
-1273,6
+1286,18
@@
sub stash_variable {
return "$prefix$name";
}
return "$prefix$name";
}
+ if ($name =~ /^[^\w+-]$/) {
+ if (defined $cx && $cx == 26) {
+ if ($prefix eq '@') {
+ return "$prefix\{$name}";
+ }
+ elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
+ }
+ if ($prefix eq '$#') {
+ return "\$#{$name}";
+ }
+ }
+
my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
return "$prefix$name";
my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
return "$prefix$name";
@@
-1394,7
+1419,7
@@
sub pp_nextstate {
$self->{'curstash'} = $stash;
}
$self->{'curstash'} = $stash;
}
- if ($self->{'arybase'} != $op->arybase) {
+ if (
OPpCONST_ARYBASE &&
$self->{'arybase'} != $op->arybase) {
push @text, '$[ = '. $op->arybase .";\n";
$self->{'arybase'} = $op->arybase;
}
push @text, '$[ = '. $op->arybase .";\n";
$self->{'arybase'} = $op->arybase;
}
@@
-1420,16
+1445,18
@@
sub pp_nextstate {
$self->{'warnings'} = $warning_bits;
}
$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
if ($] > 5.009 &&
if ($] > 5.009 &&
- "@{[sort %{$self->{'hinthash'} || {}}]}"
- ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
- push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
+ @text != push @text, declare_hinthash(
+ $self->{'hinthash'}, $op->hints_hash->HASH,
+ $self->{indent_size}
+ )
+ ) {
$self->{'hinthash'} = $op->hints_hash->HASH;
}
$self->{'hinthash'} = $op->hints_hash->HASH;
}
@@
-1484,8
+1511,15
@@
sub declare_hinthash {
my @decls;
for my $key (keys %$to) {
next if $ignored_hints{$key};
my @decls;
for my $key (keys %$to) {
next if $ignored_hints{$key};
- if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
- push @decls, qq(\$^H{'$key'} = q($to->{$key}););
+ if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
+ push @decls,
+ qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
+ . (
+ defined $to->{$key}
+ ? single_delim("q", "'", $to->{$key})
+ : 'undef'
+ )
+ . qq(;);
}
}
for my $key (keys %$from) {
}
}
for my $key (keys %$from) {
@@
-1494,7
+1528,7
@@
sub declare_hinthash {
push @decls, qq(delete \$^H{'$key'};);
}
}
push @decls, qq(delete \$^H{'$key'};);
}
}
- @decls or return
''
;
+ @decls or return;
return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
}
return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
}
@@
-1512,10
+1546,45
@@
sub pp_setstate { pp_nextstate(@_) }
sub pp_unstack { return "" } # see also leaveloop
sub pp_unstack { return "" } # see also leaveloop
+my %feature_keywords = (
+ # keyword => 'feature',
+ state => 'state',
+ say => 'say',
+ given => 'switch',
+ when => 'switch',
+ default => 'switch',
+ break => 'switch',
+ evalbytes=>'evalbytes',
+ __SUB__ => '__SUB__',
+);
+
+sub keyword {
+ my $self = shift;
+ my $name = shift;
+ return $name if $name =~ /^CORE::/; # just in case
+ if (exists $feature_keywords{$name}) {
+ return "CORE::$name"
+ if !$self->{'hinthash'}
+ || !$self->{'hinthash'}{"feature_$feature_keywords{$name}"}
+ }
+ if (
+ $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\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) = @_;
sub baseop {
my $self = shift;
my($op, $cx, $name) = @_;
- return $
name
;
+ return $
self->keyword($name)
;
}
sub pp_stub {
}
sub pp_stub {
@@
-1560,7
+1629,13
@@
sub pfixop {
my($op, $cx, $name, $prec, $flags) = (@_, 0);
my $kid = $op->first;
$kid = $self->deparse($kid, $prec);
my($op, $cx, $name, $prec, $flags) = (@_, 0);
my $kid = $op->first;
$kid = $self->deparse($kid, $prec);
- return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
+ return $self->maybe_parens(($flags & POSTFIX)
+ ? "$kid$name"
+ # avoid confusion with filetests
+ : $name eq '-'
+ && $kid =~ /^[a-zA-Z](?!\w)/
+ ? "$name($kid)"
+ : "$name$kid",
$cx, $prec);
}
$cx, $prec);
}
@@
-1591,7
+1666,7
@@
sub pp_not {
my $self = shift;
my($op, $cx) = @_;
if ($cx <= 4) {
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);
}
} else {
$self->pfixop($op, $cx, "!", 21);
}
@@
-1599,7
+1674,7
@@
sub pp_not {
sub unop {
my $self = shift;
sub unop {
my $self = shift;
- my($op, $cx, $name) = @_;
+ my($op, $cx, $name
, $nollafr
) = @_;
my $kid;
if ($op->flags & OPf_KIDS) {
$kid = $op->first;
my $kid;
if ($op->flags & OPf_KIDS) {
$kid = $op->first;
@@
-1615,9
+1690,18
@@
sub unop {
$kid = $kid->first;
}
$kid = $kid->first;
}
+ if ($nollafr) {
+ ($kid = $self->deparse($kid, 16)) =~ s/^\cS//;
+ return $self->maybe_parens(
+ $self->keyword($name) . " $kid", $cx, 16
+ );
+ }
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ return $self->maybe_parens(
+ $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
+ $cx, 16,
+ );
}
}
}
}
@@
-1650,6
+1734,7
@@
sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_keys { unop(@_, "keys") }
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_boolkeys {
# no name because its an optimisation op that has no keyword
unop(@_,"");
@@
-1691,8
+1776,17
@@
sub pp_gmtime { unop(@_, "gmtime") }
sub pp_alarm { unop(@_, "alarm") }
sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
sub pp_alarm { unop(@_, "alarm") }
sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
-sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
+sub pp_dofile {
+ my $code = unop(@_, "do", 1); # llafr does not apply
+ if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
+ $code;
+}
+sub pp_entereval {
+ unop(
+ @_,
+ $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+ )
+}
sub pp_ghbyname { unop(@_, "gethostbyname") }
sub pp_gnbyname { unop(@_, "getnetbyname") }
sub pp_ghbyname { unop(@_, "gethostbyname") }
sub pp_gnbyname { unop(@_, "getnetbyname") }
@@
-1709,11
+1803,7
@@
sub pp_ggrgid { unop(@_, "getgrgid") }
sub pp_lock { unop(@_, "lock") }
sub pp_continue { unop(@_, "continue"); }
sub pp_lock { unop(@_, "lock") }
sub pp_continue { unop(@_, "continue"); }
-sub pp_break {
- my ($self, $op) = @_;
- return "" if $op->flags & OPf_SPECIAL;
- unop(@_, "break");
-}
+sub pp_break { unop(@_, "break"); }
sub givwhen {
my $self = shift;
sub givwhen {
my $self = shift;
@@
-1722,7
+1812,7
@@
sub givwhen {
my $enterop = $op->first;
my ($head, $block);
if ($enterop->flags & OPf_SPECIAL) {
my $enterop = $op->first;
my ($head, $block);
if ($enterop->flags & OPf_SPECIAL) {
- $head =
"default"
;
+ $head =
$self->keyword("default")
;
$block = $self->deparse($enterop->first, 0);
}
else {
$block = $self->deparse($enterop->first, 0);
}
else {
@@
-1737,8
+1827,8
@@
sub givwhen {
"\b}\cK";
}
"\b}\cK";
}
-sub pp_leavegiven { givwhen(@_,
"given"
); }
-sub pp_leavewhen { givwhen(@_,
"when"
); }
+sub pp_leavegiven { givwhen(@_,
$_[0]->keyword("given")
); }
+sub pp_leavewhen { givwhen(@_,
$_[0]->keyword("when")
); }
sub pp_exists {
my $self = shift;
sub pp_exists {
my $self = shift;
@@
-1795,9
+1885,13
@@
sub pp_require {
my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
my $name = $self->const_sv($op->first)->PV;
$name =~ s[/][::]g;
$name =~ s/\.pm//g;
- return
"$opname $name"
;
+ return
$self->maybe_parens("$opname $name", $cx, 16)
;
} else {
} else {
- $self->unop($op, $cx, $op->first->private & OPpCONST_NOVER ? "no" : $opname);
+ $self->unop(
+ $op, $cx,
+ $op->first->private & OPpCONST_NOVER ? "no" : $opname,
+ 1, # llafr does not apply
+ );
}
}
}
}
@@
-1927,28
+2021,32
@@
sub loopex {
my $self = shift;
my ($op, $cx, $name) = @_;
if (class($op) eq "PVOP") {
my $self = shift;
my ($op, $cx, $name) = @_;
if (class($op) eq "PVOP") {
-
return "$name
" . $op->pv;
+
$name .= "
" . $op->pv;
} elsif (class($op) eq "OP") {
} elsif (class($op) eq "OP") {
- return $name;
+ # no-op
} elsif (class($op) eq "UNOP") {
} elsif (class($op) eq "UNOP") {
- # Note -- loop exits are actually exempt from the
- # looks-like-a-func rule, but a few extra parens won't hurt
- return $self->maybe_parens_unop($name, $op->first, $cx);
+ (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
+ $name .= " $kid";
}
}
+ return $self->maybe_parens($name, $cx, 16);
}
sub pp_last { loopex(@_, "last") }
sub pp_next { loopex(@_, "next") }
sub pp_redo { loopex(@_, "redo") }
sub pp_goto { loopex(@_, "goto") }
}
sub pp_last { loopex(@_, "last") }
sub pp_next { loopex(@_, "next") }
sub pp_redo { loopex(@_, "redo") }
sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
+sub pp_dump { loopex(@_, "
CORE::
dump") }
sub ftst {
my $self = shift;
my($op, $cx, $name) = @_;
if (class($op) eq "UNOP") {
sub ftst {
my $self = shift;
my($op, $cx, $name) = @_;
if (class($op) eq "UNOP") {
- # Genuine `-X' filetests are exempt from the LLAFR, but not
- # l?stat(); for the sake of clarity, give'em all parens
+ # Genuine '-X' filetests are exempt from the LLAFR, but not
+ # l?stat()
+ if ($name =~ /^-/) {
+ (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
+ return $self->maybe_parens("$name $kid", $cx, 16);
+ }
return $self->maybe_parens_unop($name, $op->first, $cx);
} elsif (class($op) =~ /^(SV|PAD)OP$/) {
return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
return $self->maybe_parens_unop($name, $op->first, $cx);
} elsif (class($op) =~ /^(SV|PAD)OP$/) {
return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
@@
-1997,7
+2095,7
@@
sub assoc_class {
my $op = shift;
my $name = $op->name;
if ($name eq "concat" and $op->first->name eq "concat") {
my $op = shift;
my $name = $op->name;
if ($name eq "concat" and $op->first->name eq "concat") {
- # avoid spurious
`
=' -- see comment in pp_concat
+ # avoid spurious
'
=' -- see comment in pp_concat
return "concat";
}
if ($name eq "null" and class($op) eq "UNOP"
return "concat";
}
if ($name eq "null" and class($op) eq "UNOP"
@@
-2014,7
+2112,7
@@
sub assoc_class {
return $name . ($op->flags & OPf_STACKED ? "=" : "");
}
return $name . ($op->flags & OPf_STACKED ? "=" : "");
}
-# Left associative operators, like
`
+', for which
+# Left associative operators, like
'
+', for which
# $a + $b + $c is equivalent to ($a + $b) + $c
BEGIN {
# $a + $b + $c is equivalent to ($a + $b) + $c
BEGIN {
@@
-2045,7
+2143,7
@@
sub deparse_binop_left {
}
}
}
}
-# Right associative operators, like
`
=', for which
+# Right associative operators, like
'
=', for which
# $a = $b = $c is equivalent to $a = ($b = $c)
BEGIN {
# $a = $b = $c is equivalent to $a = ($b = $c)
BEGIN {
@@
-2152,9
+2250,9
@@
sub pp_smartmatch {
}
}
}
}
-#
`
.' is special because concats-of-concats are optimized to save copying
+#
'
.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
# by making all but the first concat stacked. The effect is as if the
-# programmer had written
`
($a . $b) .= $c', except legal.
+# programmer had written
'
($a . $b) .= $c', except legal.
sub pp_concat { maybe_targmy(@_, \&real_concat) }
sub real_concat {
my $self = shift;
sub pp_concat { maybe_targmy(@_, \&real_concat) }
sub real_concat {
my $self = shift;
@@
-2172,7
+2270,7
@@
sub real_concat {
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
-#
`
x' is weird when the left arg is a list
+#
'
x' is weird when the left arg is a list
sub pp_repeat {
my $self = shift;
my($op, $cx) = @_;
sub pp_repeat {
my $self = shift;
my($op, $cx) = @_;
@@
-2270,17
+2368,26
@@
sub pp_dorassign { logassignop(@_, "//=") }
sub listop {
my $self = shift;
sub listop {
my $self = shift;
- my($op, $cx, $name) = @_;
+ my($op, $cx, $name
, $kid, $nollafr
) = @_;
my(@exprs);
my $parens = ($cx >= 5) || $self->{'parens'};
my(@exprs);
my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
- return $name if null $kid;
+ $kid ||= $op->first->sibling;
+ # If there are no arguments, add final parentheses (or parenthesize the
+ # whole thing if the llafr does not apply) to account for cases like
+ # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
+ # precedence of 6 (< comma), as "return, 1" does not need parentheses.
+ if (null $kid) {
+ return $nollafr
+ ? $self->maybe_parens($self->keyword($name), $cx, 7)
+ : $self->keyword($name) . '()' x (7 < $cx);
+ }
my $first;
$name = "socketpair" if $name eq "sockpair";
my $first;
$name = "socketpair" if $name eq "sockpair";
+ my $fullname = $self->keyword($name);
my $proto = prototype("CORE::$name");
if (defined $proto
&& $proto =~ /^;?\*/
my $proto = prototype("CORE::$name");
if (defined $proto
&& $proto =~ /^;?\*/
- && $kid->name eq "rv2gv") {
+ && $kid->name eq "rv2gv"
&& !($kid->private & OPpLVAL_INTRO)
) {
$first = $self->deparse($kid->first, 6);
}
else {
$first = $self->deparse($kid->first, 6);
}
else {
@@
-2289,10
+2396,12
@@
sub listop {
if ($name eq "chmod" && $first =~ /^\d+$/) {
$first = sprintf("%#o", $first);
}
if ($name eq "chmod" && $first =~ /^\d+$/) {
$first = sprintf("%#o", $first);
}
- $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ $first = "+$first"
+ if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
push @exprs, $first;
$kid = $kid->sibling;
push @exprs, $first;
$kid = $kid->sibling;
- if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
+ if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
+ && !($kid->private & OPpLVAL_INTRO)) {
push @exprs, $self->deparse($kid->first, 6);
$kid = $kid->sibling;
}
push @exprs, $self->deparse($kid->first, 6);
$kid = $kid->sibling;
}
@@
-2300,18
+2409,30
@@
sub listop {
push @exprs, $self->deparse($kid, 6);
}
if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
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) . ")";
+ if ($parens && $nollafr) {
+ return "($fullname " . join(", ", @exprs) . ")";
+ } elsif ($parens) {
+ return "$fullname(" . join(", ", @exprs) . ")";
} else {
} else {
- return "$name " . join(", ", @exprs);
+ return "$
full
name " . join(", ", @exprs);
}
}
sub pp_bless { listop(@_, "bless") }
sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
}
}
sub pp_bless { listop(@_, "bless") }
sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
-sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_substr {
+ my ($self,$op,$cx) = @_;
+ if ($op->private & OPpSUBSTR_REPL_FIRST) {
+ return
+ listop($self, $op, 7, "substr", $op->first->sibling->sibling)
+ . " = "
+ . $self->deparse($op->first->sibling, 7);
+ }
+ maybe_local(@_, listop(@_, "substr"))
+}
sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
sub pp_index { maybe_targmy(@_, \&listop, "index") }
sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
sub pp_index { maybe_targmy(@_, \&listop, "index") }
sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
@@
-2327,9
+2448,7
@@
sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
sub pp_reverse { listop(@_, "reverse") }
sub pp_warn { listop(@_, "warn") }
sub pp_die { listop(@_, "die") }
sub pp_reverse { listop(@_, "reverse") }
sub pp_warn { listop(@_, "warn") }
sub pp_die { listop(@_, "die") }
-# Actually, return is exempt from the LLAFR (see examples in this very
-# module!), but for consistency's sake, ignore that fact
-sub pp_return { listop(@_, "return") }
+sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
sub pp_open { listop(@_, "open") }
sub pp_pipe_op { listop(@_, "pipe") }
sub pp_tie { listop(@_, "tie") }
sub pp_open { listop(@_, "open") }
sub pp_pipe_op { listop(@_, "pipe") }
sub pp_tie { listop(@_, "tie") }
@@
-2396,9
+2515,12
@@
sub pp_glob {
my $self = shift;
my($op, $cx) = @_;
my $text = $self->dq($op->first->sibling); # skip pushmark
my $self = shift;
my($op, $cx) = @_;
my $text = $self->dq($op->first->sibling); # skip pushmark
+ my $keyword =
+ $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- return 'glob(' . single_delim('qq', '"', $text) . ')';
+ or $keyword =~ /^CORE::/
+ or $text =~ /[<>]/) {
+ return "$keyword(" . single_delim('qq', '"', $text) . ')';
} else {
return '<' . $text . '>';
}
} else {
return '<' . $text . '>';
}
@@
-2423,10
+2545,11
@@
sub pp_truncate {
$fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
}
my $len = $self->deparse($kid->sibling, 6);
$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) {
if ($parens) {
- return "
truncat
e($fh, $len)";
+ return "
$nam
e($fh, $len)";
} else {
} else {
- return "
truncat
e $fh, $len";
+ return "
$nam
e $fh, $len";
}
}
}
}
@@
-2434,7
+2557,7
@@
sub indirop {
my $self = shift;
my($op, $cx, $name) = @_;
my($expr, @exprs);
my $self = shift;
my($op, $cx, $name) = @_;
my($expr, @exprs);
- my $kid = $op->first->sibling;
+ my $
firstkid = my $
kid = $op->first->sibling;
my $indir = "";
if ($op->flags & OPf_STACKED) {
$indir = $kid;
my $indir = "";
if ($op->flags & OPf_STACKED) {
$indir = $kid;
@@
-2458,19
+2581,20
@@
sub indirop {
$indir = '{$b cmp $a} ';
}
for (; !null($kid); $kid = $kid->sibling) {
$indir = '{$b cmp $a} ';
}
for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
+ $expr = $self->deparse($kid,
!$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 :
6);
push @exprs, $expr;
}
push @exprs, $expr;
}
- my $name2
= $name
;
+ my $name2;
if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
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]";
}
my $args = $indir . join(", ", @exprs);
if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
return "$exprs[0] = $name2 $indir $exprs[0]";
}
my $args = $indir . join(", ", @exprs);
- if ($indir ne ""
and
$name eq "sort") {
+ if ($indir ne ""
&&
$name eq "sort") {
# We don't want to say "sort(f 1, 2, 3)", since perl -w will
# give bareword warnings in that case. Therefore if context
# requires, we'll put parens around the outside "(sort f 1, 2,
# We don't want to say "sort(f 1, 2, 3)", since perl -w will
# give bareword warnings in that case. Therefore if context
# requires, we'll put parens around the outside "(sort f 1, 2,
@@
-2482,6
+2606,13
@@
sub indirop {
} else {
return "$name2 $args";
}
} else {
return "$name2 $args";
}
+ } elsif (
+ !$indir && $name eq "sort"
+ && $op->first->sibling->name eq 'entersub'
+ ) {
+ # We cannot say sort foo(bar), as foo will be interpreted as a
+ # comparison routine. We have to say sort(...) in that case.
+ return "$name2($args)";
} else {
return $self->maybe_parens_func($name2, $args, $cx, 5);
}
} else {
return $self->maybe_parens_func($name2, $args, $cx, 5);
}
@@
-2523,6
+2654,7
@@
sub pp_list {
my($op, $cx) = @_;
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
my($op, $cx) = @_;
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
+ return '' if class($kid) eq 'NULL';
my $lop;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
my $lop;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
@@
-2683,7
+2815,8
@@
sub loop_common {
$ary = $self->deparse($ary, 1);
}
if (null $var) {
$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);
$var = $self->pp_threadsv($enter, 1);
} else { # regular my() variable
$var = $self->pp_padsv($enter, 1);
@@
-2773,10
+2906,9
@@
sub pp_leavetry {
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}
-BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
-BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
-BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
-BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
+BEGIN { for (qw[ const stringify rv2sv list glob ]) {
+ eval "sub OP_\U$_ () { " . opnumber($_) . "}"
+}}
sub pp_null {
my $self = shift;
sub pp_null {
my $self = shift;
@@
-2794,6
+2926,14
@@
sub pp_null {
return $self->pp_scope($op->first, $cx);
} elsif ($op->targ == OP_STRINGIFY) {
return $self->dquote($op, $cx);
return $self->pp_scope($op->first, $cx);
} elsif ($op->targ == OP_STRINGIFY) {
return $self->dquote($op, $cx);
+ } elsif ($op->targ == OP_GLOB) {
+ return $self->pp_glob(
+ $op->first # entersub
+ ->first # ex-list
+ ->first # pushmark
+ ->sibling, # glob
+ $cx
+ );
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "readline" and
$op->first->sibling->flags & OPf_STACKED) {
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "readline" and
$op->first->sibling->flags & OPf_STACKED) {
@@
-2842,15
+2982,7
@@
sub pp_padsv {
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
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) = @_;
sub pp_threadsv {
my $self = shift;
my($op, $cx) = @_;
@@
-2872,7
+3004,7
@@
sub pp_gvsv {
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
return $self->maybe_local($op, $cx, $self->stash_variable("\$",
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
return $self->maybe_local($op, $cx, $self->stash_variable("\$",
- $self->gv_name($gv)));
+ $self->gv_name($gv)
, $cx
));
}
sub pp_gv {
}
sub pp_gv {
@@
-2882,22
+3014,25
@@
sub pp_gv {
return $self->gv_name($gv);
}
return $self->gv_name($gv);
}
+sub pp_aelemfast_lex {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $name = $self->padname($op->targ);
+ $name =~ s/^@/\$/;
+ return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+}
+
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
sub pp_aelemfast {
my $self = shift;
my($op, $cx) = @_;
- my $name;
- if ($op->flags & OPf_SPECIAL) { # optimised PADAV
- $name = $self->padname($op->targ);
- $name =~ s/^@/\$/;
- }
- else {
- my $gv = $self->gv_or_padgv($op);
- $name = $self->gv_name($gv);
- $name = $self->{'curstash'}."::$name"
- if $name !~ /::/ && $self->lex_in_scope('@'.$name);
- $name = '$' . $name;
- }
+ # optimised PADAV, pre 5.15
+ return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
+ my $gv = $self->gv_or_padgv($op);
+ my $name = $self->gv_name($gv);
+ $name = $self->{'curstash'}."::$name"
+ if $name !~ /::/ && $self->lex_in_scope('@'.$name);
+ $name = '$' . $name;
return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
}
return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
}
@@
-2911,7
+3046,7
@@
sub rv2x {
}
my $kid = $op->first;
if ($kid->name eq "gv") {
}
my $kid = $op->first;
if ($kid->name eq "gv") {
- return $self->stash_variable($type, $self->deparse($kid, 0));
+ return $self->stash_variable($type, $self->deparse($kid, 0)
, $cx
);
} elsif (is_scalar $kid) {
my $str = $self->deparse($kid, 0);
if ($str =~ /^\$([^\w\d])\z/) {
} elsif (is_scalar $kid) {
my $str = $self->deparse($kid, 0);
if ($str =~ /^\$([^\w\d])\z/) {
@@
-3172,7
+3307,7
@@
sub _method {
# doesn't get flattened by the append_elem that adds the method,
# making a (object, arg1, arg2, ...) list where the object
# usually is. This can be distinguished from
# doesn't get flattened by the append_elem that adds the method,
# making a (object, arg1, arg2, ...) list where the object
# usually is. This can be distinguished from
- #
`
($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+ #
'
($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
# object) because in the later the list is in scalar context
# as the left side of -> always is, while in the former
# the list is in list context as method arguments always are.
# object) because in the later the list is in scalar context
# as the left side of -> always is, while in the former
# the list is in list context as method arguments always are.
@@
-3187,7
+3322,7
@@
sub _method {
} else {
$obj = $kid;
$kid = $kid->sibling;
} else {
$obj = $kid;
$kid = $kid->sibling;
- for (; !null ($kid->sibling) && $kid->name
ne "method_named"
;
+ for (; !null ($kid->sibling) && $kid->name
!~/^method(?:_named)?\z/
;
$kid = $kid->sibling) {
push @exprs, $kid
}
$kid = $kid->sibling) {
push @exprs, $kid
}
@@
-3206,7
+3341,8
@@
sub _method {
}
return { method => $meth, variable_method => ref($meth),
}
return { method => $meth, variable_method => ref($meth),
- object => $obj, args => \@exprs };
+ object => $obj, args => \@exprs },
+ $cx;
}
# compat function only
}
# compat function only
@@
-3217,12
+3353,22
@@
sub method {
}
sub e_method {
}
sub e_method {
- my ($self, $info) = @_;
+ my ($self, $info
, $cx
) = @_;
my $obj = $self->deparse($info->{object}, 24);
my $meth = $info->{method};
$meth = $self->deparse($meth, 1) if $info->{variable_method};
my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
my $obj = $self->deparse($info->{object}, 24);
my $meth = $info->{method};
$meth = $self->deparse($meth, 1) if $info->{variable_method};
my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
+ # method { $object }
+ # This must be deparsed this way to preserve list context
+ # of $object.
+ my $need_paren = $cx >= 6;
+ return '(' x $need_paren
+ . $meth . substr($obj,2) # chop off the "do"
+ . " $args"
+ . ')' x $need_paren;
+ }
my $kid = $obj . "->" . $meth;
if (length $args) {
return $kid . "(" . $args . ")"; # parens mandatory
my $kid = $obj . "->" . $meth;
if (length $args) {
return $kid . "(" . $args . ")"; # parens mandatory
@@
-3305,7
+3451,7
@@
sub check_proto {
}
}
}
}
}
}
- return "&" if $proto and !$doneok; # too few args and no
`
;'
+ return "&" if $proto and !$doneok; # too few args and no
'
;'
return "&" if @args; # too many args
return ("", join ", ", @reals);
}
return "&" if @args; # too many args
return ("", join ", ", @reals);
}
@@
-3391,15
+3537,7
@@
sub pp_entersub {
return $prefix . $amper. $kid;
}
} else {
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:://;
# so it must have been translated from a keyword call. Translate
# it back.
$kid =~ s/^CORE::GLOBAL:://;
@@
-3735,6
+3873,18
@@
sub const {
}
return "{" . join(", ", @elts) . "}";
} elsif (class($ref) eq "CV") {
}
return "{" . join(", ", @elts) . "}";
} elsif (class($ref) eq "CV") {
+ BEGIN {
+# Commented out until after 5.15.6
+# if ($] > 5.0150051) {
+ require overloading;
+ unimport overloading;
+# }
+ }
+ # Remove the 1|| after 5.15.6
+ if ((1||$] > 5.0150051) && $self->{curcv} &&
+ $self->{curcv}->object_2svref == $ref->object_2svref) {
+ return $self->keyword("__SUB__");
+ }
return "sub " . $self->deparse_sub($ref);
}
if ($ref->FLAGS & SVs_SMG) {
return "sub " . $self->deparse_sub($ref);
}
if ($ref->FLAGS & SVs_SMG) {
@@
-3788,7
+3938,7
@@
sub pp_const {
if ($op->private & OPpCONST_ARYBASE) {
return '$[';
}
if ($op->private & OPpCONST_ARYBASE) {
return '$[';
}
-# if ($op->private & OPpCONST_BARE) { # trouble with
`
=>' autoquoting
+# if ($op->private & OPpCONST_BARE) { # trouble with
'
=>' autoquoting
# return $self->const_sv($op)->PV;
# }
my $sv = $self->const_sv($op);
# return $self->const_sv($op)->PV;
# }
my $sv = $self->const_sv($op);
@@
-3836,7
+3986,10
@@
sub pp_backtick {
# skip pushmark if it exists (readpipe() vs ``)
my $child = $op->first->sibling->isa('B::NULL')
? $op->first : $op->first->sibling;
# 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 {
}
sub dquote {
@@
-3862,7
+4015,7
@@
sub double_delim {
if (($succeed, $to) = balanced_delim($to) and $succeed) {
return "$from$to";
} else {
if (($succeed, $to) = balanced_delim($to) and $succeed) {
return "$from$to";
} else {
- for $delim ('/', '"', '#') { # note no
`''
-- s''' is special
+ for $delim ('/', '"', '#') { # note no
"'"
-- s''' is special
return "$from$delim$to$delim" if index($to, $delim) == -1;
}
$to =~ s[/][\\/]g;
return "$from$delim$to$delim" if index($to, $delim) == -1;
}
$to =~ s[/][\\/]g;
@@
-4085,19
+4238,26
@@
sub pp_trans {
my $self = shift;
my($op, $cx) = @_;
my($from, $to);
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"
} 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 = "";
}
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 "";
$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;
}
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]"
sub re_dq_disambiguate {
my ($first, $last) = @_;
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
@@
-4243,7
+4403,11
@@
sub matchop {
carp("found ".$kid->name." where regcomp expected");
} else {
($re, $quote) = $self->regcomp($kid, 21, $extended);
carp("found ".$kid->name." where regcomp expected");
} else {
($re, $quote) = $self->regcomp($kid, 21, $extended);
- $rhs_bound_to_defsv = 1 if $kid->first->first->flags & OPf_SPECIAL;
+ my $matchop = $kid->first->first;
+ if ($matchop->name =~ /^(?:match|transr?|subst)\z/
+ && $matchop->flags & OPf_SPECIAL) {
+ $rhs_bound_to_defsv = 1;
+ }
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
}
my $flags = "";
$flags .= "c" if $op->pmflags & PMf_CONTINUE;
@@
-4278,6
+4442,8
@@
sub pp_match { matchop(@_, "m", "/") }
sub pp_pushre { matchop(@_, "m", "/") }
sub pp_qr { matchop(@_, "qr", "") }
sub pp_pushre { matchop(@_, "m", "/") }
sub pp_qr { matchop(@_, "qr", "") }
+sub pp_runcv { unop(@_, "__SUB__"); }
+
sub pp_split {
my $self = shift;
my($op, $cx) = @_;
sub pp_split {
my $self = shift;
my($op, $cx) = @_;
@@
-4297,7
+4463,7
@@
sub pp_split {
} elsif (!ref($replroot) and $replroot > 0) {
$gv = $self->padval($replroot);
}
} elsif (!ref($replroot) and $replroot > 0) {
$gv = $self->padval($replroot);
}
- $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
+ $ary = $self->stash_variable('@', $self->gv_name($gv)
, $cx
) if $gv;
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
for (; !null($kid); $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
@@
-4725,6
+4891,7
@@
expect.
=item $[
Takes a number, the value of the array base $[.
=item $[
Takes a number, the value of the array base $[.
+Cannot be non-zero on Perl 5.15.3 or later.
=item bytes
=item bytes
@@
-4836,14
+5003,6
@@
from the Perl core to fix.
=item *
=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:
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:
@@
-4876,7
+5035,7
@@
which is not, consequently, deparsed correctly.
Lexical (my) variables declared in scopes external to a subroutine
appear in code2ref output text as package variables. This is a tricky
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 refer
r
ing to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
=item *
defined within a different scope, although L<PadWalker> is a good start.
=item *