In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/3188a8216e19cb1020af7615e3178daab8a865d6?hp=a958cfbb8cface09cefb76d5846a867ac7c600dd>
- Log -----------------------------------------------------------------
commit 3188a8216e19cb1020af7615e3178daab8a865d6
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 22:32:23 2014 -0700
Deparse with CORE:: to avoid lex sub conflicts
If a lexical sub with the same name as a keyword is in scope, we need
to deparse the keyword with a CORE:: prefix.
This commit handles most of the cases, but there are a few exceptional
cases remaining.
M lib/B/Deparse-core.t
M lib/B/Deparse.pm
commit c837f29ae94c2404c0fbd82b1dbcc195a35a9183
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 17:30:59 2014 -0700
Deparse-core.t: Fix ineffective tests
In a958cfbb8, I accidentally changed this to test âtest::foo()â,
rather than âfoo()â deparsing as âtest::foo()â, which was what I
had intended.
M lib/B/Deparse-core.t
commit a21eb52b1988ec2828792ad77f68a17dda3e6feb
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 17:25:57 2014 -0700
Correct â"my" variable "&f::b"...â message
"my" variable &foo::bar can't be in a package at - line 2, near "my sub
foo::bar"
It should say âsubroutineâ, not âvariableâ. When I implemented
lexi-
cal subs, I thought I caught all these, must I missed this one.
M perl.h
M pod/perldiag.pod
M t/lib/croak/toke
M toke.c
commit 82a7b38ebca5ead4666341f73512665b295afd51
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 17:15:43 2014 -0700
toke.c: Add comment for greppability
M toke.c
commit 20ed5f007e3724a22784725ed36aeaad036be0ff
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 5 17:10:59 2014 -0700
Reorder t/lib/croak/toke
to put string terminator errors all in one place.
M t/lib/croak/toke
-----------------------------------------------------------------------
Summary of changes:
lib/B/Deparse-core.t | 55 +++++++++++++++++++++++++++++++++++++++++-----------
lib/B/Deparse.pm | 38 +++++++++++++++++++++++-------------
perl.h | 2 +-
pod/perldiag.pod | 10 ++++++++++
t/lib/croak/toke | 41 +++++++++++++++++++++++++--------------
toke.c | 5 ++++-
6 files changed, 109 insertions(+), 42 deletions(-)
diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t
index 2446622..c624218 100644
--- a/lib/B/Deparse-core.t
+++ b/lib/B/Deparse-core.t
@@ -36,7 +36,7 @@ BEGIN {
use strict;
use Test::More;
-plan tests => 2071;
+plan tests => 4018;
use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
# logic to add CORE::
@@ -51,7 +51,7 @@ my %SEEN_STRENGH;
# deparse "() = $expr", and see if it matches $expected_expr
sub testit {
- my ($keyword, $expr, $expected_expr) = @_;
+ my ($keyword, $expr, $expected_expr, $lexsub) = @_;
$expected_expr //= $expr;
$SEEN{$keyword} = 1;
@@ -68,7 +68,8 @@ sub testit {
if ($lex == 2) {
my $repl = 'my $a';
- if ($expr =~ /\bmap\(\$a|CORE::(chomp|chop|lstat|stat)\b/) {
+ if ($expr =~ /CORE::(chomp|chop|lstat|stat)\b/
+ or $expr =~ ($lexsub ? qr/::map\(\$a/ : qr/\bmap\(\$a/)) {
# for some reason only these do:
# 'foo my $a, $b,' => foo my($a), $b, ...
# the rest don't parenthesize the my var.
@@ -78,10 +79,20 @@ sub testit {
}
my $desc = "$keyword: lex=$lex $expr => $expected_expr";
+ $desc .= " (lex sub)" if $lexsub;
my $code_ref;
- {
+ if ($lexsub) {
+ package lexsubtest;
+ no warnings 'experimental::lexical_subs';
+ use feature 'lexical_subs';
+ no strict 'vars';
+ $code_ref =
+ eval "sub { state sub $keyword; ${vars}() = $expr }"
+ || die "$@ in $expr";
+ }
+ else {
package test;
use subs ();
import subs $keyword;
@@ -92,7 +103,7 @@ sub testit {
my $got_text = $deparse->coderef2text($code_ref);
unless ($got_text =~ /^\{
- package test;
+ package (?:lexsub)?test;
BEGIN \{\$\{\^WARNING_BITS} = "[^"]*"}
use strict 'refs', 'subs';
use feature [^\n]+
@@ -131,13 +142,16 @@ sub do_infix_keyword {
# so no need for Deparse to disambiguate with CORE::
testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
testit $keyword, "(\$a $keyword \$b)", $exp;
+ testit $keyword, "(\$a CORE::$keyword \$b)", $exp, 1;
+ testit $keyword, "(\$a $keyword \$b)", $exp, 1;
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);";
+ my $pre = "test::" x ($keyword ne 'x');
+ testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);";
}
+ testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1;
}
# test a keyword that is as tandard op/function, like 'index(...)'.
@@ -153,20 +167,30 @@ sub do_std_keyword {
$SEEN_STRENGH{$keyword} = $strong;
for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
+ for my $lexsub (0,1) { # if true, define lex sub
my @code;
for my $do_exp(0, 1) { # first create expr, then expected-expr
my @args = map "\$$_", (undef,"a".."z")[1..$narg];
- push @args, '$_' if $dollar && $do_exp && ($strong || $core);
+ push @args, '$_'
+ if $dollar && $do_exp && ($strong && !$lexsub or $core);
my $args = join(', ', @args);
- $args = ((!$core && !$strong) || $parens)
+ # XXX $lex_parens is temporary, until lex subs are
+ # deparsed properly.
+ my $lex_parens =
+ !$core && $do_exp && $lexsub && $keyword ne 'map';
+ $args = ((!$core && !$strong) || $parens || $lex_parens)
? "($args)"
: @args ? " $args" : "";
push @code, (($core && !($do_exp && $strong))
- ? "CORE::"
+ ? "CORE::"
+ : $lexsub && $do_exp
+ ? "CORE::" x $core
: $do_exp && !$core && !$strong ? "test::" : "")
. "$keyword$args;";
}
- testit $keyword, @code; # code[0]: to run; code[1]: expected
+ # code[0]: to run; code[1]: expected
+ testit $keyword, @code, $lexsub;
+ }
}
}
@@ -211,6 +235,10 @@ testit dbmopen => 'CORE::dbmopen(%foo, $bar, $baz);';
testit dbmclose => 'CORE::dbmclose %foo;';
testit delete => 'CORE::delete $h{\'foo\'};', 'delete $h{\'foo\'};';
+testit delete => 'CORE::delete $h{\'foo\'};', undef, 1;
+testit delete => 'CORE::delete @h{\'foo\'};', undef, 1;
+testit delete => 'CORE::delete $h[0];', undef, 1;
+testit delete => 'CORE::delete @h[0];', undef, 1;
testit delete => 'delete $h{\'foo\'};', 'delete $h{\'foo\'};';
# do is listed as strong, but only do { block } is strong;
@@ -219,6 +247,8 @@ testit do => 'CORE::do $a;';
testit do => 'do $a;', 'test::do($a);';
testit do => 'CORE::do { 1 }',
"do {\n 1\n };";
+testit do => 'CORE::do { 1 }',
+ "CORE::do {\n 1\n };", 1;
testit do => 'do { 1 };',
"do {\n 1\n };";
@@ -227,6 +257,9 @@ testit each => 'CORE::each %bar;';
testit eof => 'CORE::eof();';
testit exists => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
+testit exists => 'CORE::exists $h{\'foo\'};', undef, 1;
+testit exists => 'CORE::exists &foo;', undef, 1;
+testit exists => 'CORE::exists $h[0];', undef, 1;
testit exists => 'exists $h{\'foo\'};', 'exists $h{\'foo\'};';
testit exec => 'CORE::exec($foo $bar);';
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 424e248..b84217d 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -1222,7 +1222,7 @@ sub maybe_local {
my @our_local;
push @our_local, "local" if $priv & OPpLVAL_INTRO;
push @our_local, "our" if $priv & $our_intro;
- my $our_local = join " ", @our_local;
+ my $our_local = join " ", map $self->keyword($_), @our_local;
if( $our_local[-1] eq 'our' ) {
if ( $text !~ /^\W(\w+::)*\w+\z/
and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
@@ -1276,9 +1276,8 @@ sub maybe_my {
&& $op->name =~ /[ah]v\z/
&& ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
- my $my = $op->private & OPpPAD_STATE
- ? $self->keyword("state")
- : "my";
+ my $my =
+ $self->keyword($op->private & OPpPAD_STATE ? "state" : "my");
if ($padname->FLAGS & SVpad_TYPED) {
$my .= ' ' . $padname->SvSTASH->NAME;
}
@@ -1377,7 +1376,10 @@ sub scopeop {
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
my $body = $self->lineseq($op, 0, @kids);
- return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
+ return is_lexical_subs(@kids)
+ ? $body
+ : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t$body\n\b}";
} else {
my $lineseq = $self->lineseq($op, $cx, @kids);
return (length ($lineseq) ? "$lineseq;" : "");
@@ -1888,6 +1890,9 @@ sub keyword {
if (exists $feature_keywords{$name}) {
return "CORE::$name" if not $self->feature_enabled($name);
}
+ if ($self->lex_in_scope("&$name")) {
+ return "CORE::$name";
+ }
if ($strong_proto_keywords{$name}
|| ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
&& !defined eval{prototype "CORE::$name"})
@@ -2155,17 +2160,18 @@ sub pp_exists {
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("exists");
if ($op->private & OPpEXISTS_SUB) {
# Checking for the existence of a subroutine
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_rv2cv($op->first, 16), $cx, 16);
}
if ($op->flags & OPf_SPECIAL) {
# Array element, not hash element
- return $self->maybe_parens_func("exists",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16), $cx, 16);
}
- return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
$cx, 16);
}
@@ -2173,24 +2179,25 @@ sub pp_delete {
my $self = shift;
my($op, $cx) = @_;
my $arg;
+ my $name = $self->keyword("delete");
if ($op->private & OPpSLICE) {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aslice($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_hslice($op->first, 16),
$cx, 16);
} else {
if ($op->flags & OPf_SPECIAL) {
# Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_aelem($op->first, 16),
$cx, 16);
}
- return $self->maybe_parens_func("delete",
+ return $self->maybe_parens_func($name,
$self->pp_helem($op->first, 16),
$cx, 16);
}
@@ -2993,7 +3000,8 @@ sub mapop {
$expr = $self->deparse($kid, 6);
push @exprs, $expr if defined $expr;
}
- return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+ return $self->maybe_parens_func($self->keyword($name),
+ $code . join(", ", @exprs), $cx, 5);
}
sub pp_mapwhile { mapop(@_, "map") }
@@ -3069,6 +3077,7 @@ sub pp_list {
$type = $newtype;
}
$local = "" if $local eq "either"; # no point if it's all undefs
+ $local &&= $self->keyword($local);
$local .= " $type " if $local && length $type;
return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
for (; !null($kid); $kid = $kid->sibling) {
@@ -3333,7 +3342,8 @@ sub pp_null {
. $self->deparse($op->first->sibling, 20),
$cx, 20);
} elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+ return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
+ . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
} elsif (!null($op->first->sibling) and
$op->first->sibling->name eq "null" and
class($op->first->sibling) eq "UNOP" and
diff --git a/perl.h b/perl.h
index b958d74..e6e1320 100644
--- a/perl.h
+++ b/perl.h
@@ -4600,7 +4600,7 @@ EXTCONST char PL_no_dir_func[]
EXTCONST char PL_no_func[]
INIT("The %s function is unimplemented");
EXTCONST char PL_no_myglob[]
- INIT("\"%s\" variable %s can't be in a package");
+ INIT("\"%s\" %se %s can't be in a package");
EXTCONST char PL_no_localize_ref[]
INIT("Can't localize through a reference");
EXTCONST char PL_memory_wrap[]
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index b4559ce..cfb8a07 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3280,6 +3280,11 @@ See L<perlfunc/pack>.
(F) Lexically scoped subroutines are not yet implemented. Don't try
that yet.
+=item "my" subroutine %s can't be in a package
+
+(F) Lexically scoped subroutines aren't in a package, so it doesn't make
+sense to try to declare one with a package qualifier on the front.
+
=item "my %s" used in sort comparison
(W syntax) The package variables $a and $b are used for sort comparisons.
@@ -5211,6 +5216,11 @@ unless there was a failure. You probably wanted to use
system()
instead, which does return. To suppress this warning, put the exec() in
a block by itself.
+=item "state" subroutine %s can't be in a package
+
+(F) Lexically scoped subroutines aren't in a package, so it doesn't make
+sense to try to declare one with a package qualifier on the front.
+
=item "state %s" used in sort comparison
(W syntax) The package variables $a and $b are used for sort comparisons.
diff --git a/t/lib/croak/toke b/t/lib/croak/toke
index 0572094..9c8dd54 100644
--- a/t/lib/croak/toke
+++ b/t/lib/croak/toke
@@ -9,6 +9,21 @@ eval "s//<<foo/e"; die $@
EXPECT
Can't find string terminator "foo" anywhere before EOF at (eval 1) line 1.
########
+# NAME Unterminated qw//
+qw/
+EXPECT
+Can't find string terminator "/" anywhere before EOF at - line 1.
+########
+# NAME Unterminated q//
+qw/
+EXPECT
+Can't find string terminator "/" anywhere before EOF at - line 1.
+########
+# NAME Unterminated ''
+'
+EXPECT
+Can't find string terminator "'" anywhere before EOF at - line 1.
+########
# NAME /\N{/
/\N{/
EXPECT
@@ -34,6 +49,17 @@ EXPECT
The lexical_subs feature is experimental at - line 2.
Missing name in "state sub" at - line 2.
########
+# NAME my sub pack::foo
+use feature 'lexical_subs', 'state';
+my sub foo::bar;
+state sub foo::bear;
+EXPECT
+The lexical_subs feature is experimental at - line 2.
+The lexical_subs feature is experimental at - line 3.
+"my" subroutine &foo::bar can't be in a package at - line 2, near "my sub
foo::bar"
+"state" subroutine &foo::bear can't be in a package at - line 3, near "state
sub foo::bear"
+Execution of - aborted due to compilation errors.
+########
# NAME Integer constant overloading returning undef
use overload;
BEGIN { overload::constant integer => sub {}; undef *^H }
@@ -134,18 +160,3 @@ Execution of - aborted due to compilation errors.
<<"foo
EXPECT
Unterminated delimiter for here document at - line 1.
-########
-# NAME Unterminated qw//
-qw/
-EXPECT
-Can't find string terminator "/" anywhere before EOF at - line 1.
-########
-# NAME Unterminated q//
-qw/
-EXPECT
-Can't find string terminator "/" anywhere before EOF at - line 1.
-########
-# NAME Unterminated ''
-'
-EXPECT
-Can't find string terminator "'" anywhere before EOF at - line 1.
diff --git a/toke.c b/toke.c
index ff4c789..9efdd80 100644
--- a/toke.c
+++ b/toke.c
@@ -8114,10 +8114,13 @@ S_pending_ident(pTHX)
}
else {
if (has_colon) {
+ /* "my" variable %s can't be in a package */
/* PL_no_myglob is constant */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
- PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
+ PL_in_my == KEY_my ? "my" : "state",
+ *PL_tokenbuf == '&' ? "subroutin" : "variabl",
+ PL_tokenbuf),
UTF ? SVf_UTF8 : 0);
GCC_DIAG_RESTORE;
}
--
Perl5 Master Repository
