In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/a958cfbb8cface09cefb76d5846a867ac7c600dd?hp=88a758b52cfa650539042289a5f43570c7966a74>
- Log -----------------------------------------------------------------
commit a958cfbb8cface09cefb76d5846a867ac7c600dd
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 13:32:20 2014 -0700
Make B::Deparse qualify sub calls named after keywords
While B::Deparse was correctly applying CORE:: as necessary to dis-
ambiguate between keywords and custom subroutines, it was not doing
likewise for subroutines whose names were keywords. main::foo()
should be deparsed as main::foo() if âfooâ is a keyword.
M lib/B/Deparse-core.t
M lib/B/Deparse.pm
M lib/B/Deparse.t
commit 4c627877a44535772b40aca390861295b62b1f6d
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 13:30:36 2014 -0700
[perl #122771] Fix assertion failure with -d and sort
-d was conflicting with sort optimisations added by 932bca295d, which
had assertions that checked for nextstate, but not dbstate ops.
M op.c
M t/run/switchd.t
commit c3d35e457d22b4fe4eb4755e8791ea7451d076b4
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 13:11:01 2014 -0700
Remove __SUB__ from Deparse-core.t exception list
This list is for keywords exempt from the checks that make sure all
keywords have been tested. __SUB__ *is* tested, so it does not
belong here.
M lib/B/Deparse-core.t
commit 9411a3c72766531181298b2ea8b2916c1cfd0b83
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 11:01:57 2014 -0700
Simplify OP_LEAVESUBLV logic in op.c:op_lvalue
If the lvalue type was OP_LEAVESUBLV, then the code for handling
entersub ops would go through extra checking to see whether we
have an lvalue sub available at compile time, before falling
through to the croaking code. But the croaking code does not croak
if the type is OP_LEAVESUBLV, so the extra checks were for nothing.
We can skip those checks here just as we do for OP_GREPSTART,
OP_ENTERSUB and OP_REFGEN lvalue types.
M op.c
commit 66cd0d790e417a08ecfd277029e75cd05756fb20
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 10:57:31 2014 -0700
op.c:op_lvalue: Remove redundent case OP_RETURN
The default case does nothing if the type is OP_LEAVESUBLV. This has
been so since 145b2bbb3.
M op.c
-----------------------------------------------------------------------
Summary of changes:
lib/B/Deparse-core.t | 11 ++++++++---
lib/B/Deparse.pm | 37 ++++++++++++++++++++++++++++---------
lib/B/Deparse.t | 7 +++++++
op.c | 15 ++++++---------
t/run/switchd.t | 12 +++++++++++-
5 files changed, 60 insertions(+), 22 deletions(-)
diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index 44a109b..2446622 100644
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -132,6 +132,10 @@ sub do_infix_keyword {
testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
testit $keyword, "(\$a $keyword \$b)", $exp;
if (!$strong) {
+ # B::Deparse fully qualifies any sub whose name is a keyword,
+ # imported or not, since the importedness may not be reproduced by
+ # the deparsed code. x is special.
+ $keyword =~ s/^(?!x\z)/test::/;
testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);";
}
}
@@ -157,7 +161,9 @@ sub do_std_keyword {
$args = ((!$core && !$strong) || $parens)
? "($args)"
: @args ? " $args" : "";
- push @code, (($core && !($do_exp && $strong)) ? "CORE::" : "")
+ push @code, (($core && !($do_exp && $strong))
+ ? "CORE::"
+ : $do_exp && !$core && !$strong ? "test::" : "")
. "$keyword$args;";
}
testit $keyword, @code; # code[0]: to run; code[1]: expected
@@ -210,7 +216,7 @@ testit delete => 'delete $h{\'foo\'};', 'delete
$h{\'foo\'};';
# do is listed as strong, but only do { block } is strong;
# do $file is weak, so test it separately here
testit do => 'CORE::do $a;';
-testit do => 'do $a;', 'do($a);';
+testit do => 'do $a;', 'test::do($a);';
testit do => 'CORE::do { 1 }',
"do {\n 1\n };";
testit do => 'do { 1 };',
@@ -289,7 +295,6 @@ my %not_tested = map { $_ => 1} qw(
__FILE__
__LINE__
__PACKAGE__
- __SUB__
AUTOLOAD
BEGIN
CHECK
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 8d99acc..424e248 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -1870,20 +1870,23 @@ my %strong_proto_keywords = map { $_ => 1 } qw(
undef
);
-sub keyword {
- my $self = shift;
- my $name = shift;
- return $name if $name =~ /^CORE::/; # just in case
- if (exists $feature_keywords{$name}) {
+sub feature_enabled {
+ my($self,$name) = @_;
my $hh;
my $hints = $self->{hints} & $feature::hint_mask;
if ($hints && $hints != $feature::hint_mask) {
$hh = _features_from_bundle($hints);
}
elsif ($hints) { $hh = $self->{'hinthash'} }
- return "CORE::$name"
- if !$hh
- || !$hh->{"feature_$feature_keywords{$name}"}
+ return $hh && $hh->{"feature_$feature_keywords{$name}"}
+}
+
+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 not $self->feature_enabled($name);
}
if ($strong_proto_keywords{$name}
|| ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
@@ -3882,8 +3885,24 @@ sub pp_entersub {
if (!$amper) {
if ($kid eq 'main::') {
$kid = '::';
- } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
+ }
+ else {
+ if ($kid !~ /::/ && $kid ne 'x') {
+ # Fully qualify any sub name that is also a keyword. While
+ # we could check the import flag, we cannot guarantee that
+ # the code deparsed so far would set that flag, so we qual-
+ # ify the names regardless of importation.
+ my $fq;
+ if (exists $feature_keywords{$kid}) {
+ $fq++ if $self->feature_enabled($kid);
+ } elsif (eval { () = prototype "CORE::$kid"; 1 }) {
+ $fq++
+ }
+ $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
+ }
+ if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
$kid = single_delim("q", "'", $kid) . '->';
+ }
}
}
} elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index ffc2a16..75a5fc2 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -1506,3 +1506,10 @@ my(@array, %hash, @a, @b, %c, %d);
() = \(@Foo::array);
() = \(%Foo::hash);
() = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d);
+####
+# subs synonymous with keywords
+main::our();
+main::pop();
+state();
+use feature 'state';
+main::state();
diff --git a/op.c b/op.c
index c864a26..d54651b 100644
--- a/op.c
+++ b/op.c
@@ -2375,10 +2375,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
break;
}
else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO
- |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
+ o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type ==
OP_REFGEN) {
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV) {
/* Potential lvalue context: */
o->op_private |= OPpENTERSUB_INARGS;
break;
@@ -2617,11 +2617,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
op_lvalue(kid, type);
break;
- case OP_RETURN:
- if (type != OP_LEAVESUBLV)
- goto nomod;
- break; /* op_lvalue()ing was handled by ck_return() */
-
case OP_COREARGS:
return o;
@@ -12063,7 +12058,9 @@ Perl_rpeep(pTHX_ OP *o)
* altering the basic op_first/op_sibling layout. */
kid = kLISTOP->op_first;
assert(
- (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+ (kid->op_type == OP_NULL
+ && ( kid->op_targ == OP_NEXTSTATE
+ || kid->op_targ == OP_DBSTATE ))
|| kid->op_type == OP_STUB
|| kid->op_type == OP_ENTER);
nullop->op_next = kLISTOP->op_next;
diff --git a/t/run/switchd.t b/t/run/switchd.t
index b5d4d42..d24d98b 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -9,7 +9,7 @@ BEGIN { require "./test.pl"; }
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 18);
+plan(tests => 19);
my $r;
@@ -275,3 +275,13 @@ is(
"42\n",
'UTF8 length caches on $DB::sub are flushed'
);
+
+# [perl #122771] -d conflicting with sort optimisations
+is(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ prog => 'BEGIN { $^P &= ~0x4 } sort { $$b <=> $$a } (); print qq-42\n-',
+ ),
+ "42\n",
+ '-d does not conflict with sort optimisations'
+);
--
Perl5 Master Repository
