[perl #114942] Correct scoping for ‘for my $x(){} $x’

This was broken by commit 60ac52eb5d5.

What that commit did was to merge two different queues that the
lexer had for pending tokens.  Since bison requires that yylex
return exactly one token for each call, when the lexer sometimes has
to set aside tokens in a queue and return them from the next few
calls to yylex.

Formerly, there were two mechanism: the forced token queue (used by
force_next), and PL_pending_ident.  PL_pending_ident was used for
names that had to be looked up in the pads.

$foo was handled like this:

  First call to yylex:
    1. Put '$foo' in PL_tokenbuf.
    2. Set PL_pending_ident.
    3. Return a '$' token.
  Second call:
    PL_pending_ident is set, so call S_pending_ident, which looks up
    the name from PL_tokenbuf, and return the THING token containing
    the appropriate op.

The forced token queue took precedence over PL_pending_ident.  Chang-
ing the order (necessary for parsing ‘our sub foo($)’) caused some
XS::APItest tests to fail.  So I concluded that the two queues needed
to be merged.

As a result, the $foo handling changed to this:

  First call to yylex:
    1. Put '$foo' in PL_tokenbuf.
    2. Call force_ident_maybe_lex (S_pending_ident renamed and modi-
       fied), which looks up the symbol and adds it to the forced
       token queue.
    3. Return a '$' token.
  Second call:
    Return the token from the forced token queue.

That had the unforeseen consequence of changing this:

    for my $x (...) { ... }
    $x;

such that the $x was still visible after the for loop.  It only hap-
pened when the $ was the next token after the closing }:

$ ./miniperl -e 'for my $x(()){} $x = 3; warn $x'
Warning: something's wrong at -e line 1.
$ ./miniperl -e 'for my $x(()){} ;$x = 3; warn $x'
3 at -e line 1.

This broke Class::Declare.

The name lookup in the pad must not happen before the '$' token is
emitted.  At that point, the parser has not yet created the for loop
(which includes exiting its scope), as it does not yet know whether
there is a continue block.  (See the ‘FOR MY...’ branch of the
barestmt rule in perly.y.)  So we must delay the name lookup till the
second call.

So we rename force_ident_maybe_lex back to S_pending_ident, removing
the force_next stuff.  And we add a new force_ident_maybe_lex function
that adds a special ‘pending ident’ token to the forced token queue.

The part of yylex that handles pending tokens (case LEX_KNOWNEXT) is
modified to account for these special ‘pending ident’ tokens and call
S_pending_ident.

diff --git a/embed.fnc b/embed.fnc
index 6c8dfad..0db9300 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2143,13 +2143,14 @@ s       |U8*    |add_utf16_textfilter|NN U8 *const s|bool reversed
 s      |void   |checkcomma     |NN const char *s|NN const char *name \
                                |NN const char *what
 s      |void   |force_ident    |NN const char *s|int kind
-so     |void   |force_ident_maybe_lex|char pit
+s      |void   |force_ident_maybe_lex|char pit
 s      |void   |incline        |NN const char *s
 s      |int    |intuit_method  |NN char *s|NULLOK GV *gv|NULLOK CV *cv
 s      |int    |intuit_more    |NN char *s
 s      |I32    |lop            |I32 f|int x|NN char *s
 rs     |void   |missingterm    |NULLOK char *s
 s      |void   |no_op          |NN const char *const what|NULLOK char *s
+s      |int    |pending_ident
 sR     |I32    |sublex_done
 sR     |I32    |sublex_push
 sR     |I32    |sublex_start

diff --git a/embed.h b/embed.h
index 73deaf2..e0afb12 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1571,6 +1571,7 @@
 #define filter_gets(a,b)       S_filter_gets(aTHX_ a,b)
 #define find_in_my_stash(a,b)  S_find_in_my_stash(aTHX_ a,b)
 #define force_ident(a,b)       S_force_ident(aTHX_ a,b)
+#define force_ident_maybe_lex(a)       S_force_ident_maybe_lex(aTHX_ a)
 #define force_next(a)          S_force_next(aTHX_ a)
 #define force_strict_version(a)        S_force_strict_version(aTHX_ a)
 #define force_version(a,b)     S_force_version(aTHX_ a,b)
@@ -1581,6 +1582,7 @@
 #define lop(a,b,c)             S_lop(aTHX_ a,b,c)
 #define missingterm(a)         S_missingterm(aTHX_ a)
 #define no_op(a,b)             S_no_op(aTHX_ a,b)
+#define pending_ident()                S_pending_ident(aTHX)
 #define readpipe_override()    S_readpipe_override(aTHX)
 #define scan_const(a)          S_scan_const(aTHX_ a)
 #define scan_formline(a)       S_scan_formline(aTHX_ a)

diff --git a/proto.h b/proto.h
index 3737e0b..f662929 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7104,6 +7104,7 @@ STATIC void       S_no_op(pTHX_ const char *const what, char *s)
 #define PERL_ARGS_ASSERT_NO_OP \
        assert(what)
 
+STATIC int     S_pending_ident(pTHX);
 STATIC void    S_readpipe_override(pTHX);
 STATIC char*   S_scan_const(pTHX_ char *start)
                        __attribute__warn_unused_result__

diff --git a/t/comp/parser.t b/t/comp/parser.t
index a0f9a0c..7c0db7f 100644 (file)
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -3,7 +3,7 @@
 # Checks if the parser behaves correctly in edge cases
 # (including weird syntax errors)
 
-print "1..153\n";
+print "1..154\n";
 
 sub failed {
     my ($got, $expected, $name) = @_;
@@ -446,6 +446,9 @@ is prototype "Hello::_he_said", '_', 'initial tick in sub declaration';
 eval 'no if $] >= 5.17.4 warnings => "deprecated"';
 is 1,1, ' no crash for "no ... syntax error"';
 
+for my $pkg(()){}
+$pkg = 3;
+is $pkg, 3, '[perl #114942] for my $foo()){} $foo';
 
 # Add new tests HERE (above this line)
 

diff --git a/toke.c b/toke.c
index e5fc735..b2d8119 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -110,9 +110,6 @@ Individual members of C<PL_parser> have their own documentation.
 #  define PL_nextval           (PL_parser->nextval)
 #endif
 
-#define force_ident_maybe_lex(p) \
-       (PL_bufptr = s, S_force_ident_maybe_lex(aTHX_ p))
-
 static const char ident_too_long[] = "Identifier too long";
 
 #ifdef PERL_MAD
@@ -2153,6 +2150,14 @@ S_force_ident(pTHX_ register const char *s, int kind)
     }
 }
 
+static void
+S_force_ident_maybe_lex(pTHX_ char pit)
+{
+    start_force(PL_curforce);
+    NEXTVAL_NEXTTOKE.ival = pit;
+    force_next('p');
+}
+
 NV
 Perl_str_to_version(pTHX_ SV *sv)
 {
@@ -4504,7 +4509,7 @@ Perl_yylex(pTHX)
            }
            if (S_is_opval_token(next_type) && pl_yylval.opval)
                pl_yylval.opval->op_savefree = 0; /* release */
-           return REPORT(next_type);
+           return REPORT(next_type == 'p' ? pending_ident() : next_type);
        }
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -8631,18 +8636,18 @@ Perl_yylex(pTHX)
 #pragma segment Main
 #endif
 
-static void
-S_force_ident_maybe_lex(pTHX_ char pit)
+static int
+S_pending_ident(pTHX)
 {
     dVAR;
-    OP *o;
-    int force_type;
     PADOFFSET tmp = 0;
+    const char pit = (char)pl_yylval.ival;
     const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
     /* All routes through this function want to know if there is a colon.  */
     const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
 
-    start_force(PL_curforce);
+    DEBUG_T({ PerlIO_printf(Perl_debug_log,
+          "### Pending identifier '%s'\n", PL_tokenbuf); });
 
     /* if we're in a my(), we can't allow dynamics here.
        $foo'bar has already been turned into $foo::bar, so
@@ -8664,11 +8669,10 @@ S_force_ident_maybe_lex(pTHX_ char pit)
                            PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
                             UTF ? SVf_UTF8 : 0);
 
-            o = newOP(OP_PADANY, 0);
-            o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
+            pl_yylval.opval = newOP(OP_PADANY, 0);
+            pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
                                                         UTF ? SVf_UTF8 : 0);
-            force_type = PRIVATEREF;
-            goto doforce;
+           return PRIVATEREF;
         }
     }
 
@@ -8689,8 +8693,8 @@ S_force_ident_maybe_lex(pTHX_ char pit)
                SV *  const sym = newSVhek(stashname);
                 sv_catpvs(sym, "::");
                 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
-                o = (OP*)newSVOP(OP_CONST, 0, sym);
-                o->op_private = OPpCONST_ENTERED;
+                pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+                pl_yylval.opval->op_private = OPpCONST_ENTERED;
                 if (pit != '&')
                   gv_fetchsv(sym,
                     (PL_in_eval
@@ -8700,14 +8704,12 @@ S_force_ident_maybe_lex(pTHX_ char pit)
                     ((PL_tokenbuf[0] == '$') ? SVt_PV
                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
                      : SVt_PVHV));
-                force_type = WORD;
-                goto doforce;
+                return WORD;
             }
 
-            o = newOP(OP_PADANY, 0);
-            o->op_targ = tmp;
-            force_type = PRIVATEREF;
-            goto doforce;
+            pl_yylval.opval = newOP(OP_PADANY, 0);
+            pl_yylval.opval->op_targ = tmp;
+            return PRIVATEREF;
         }
     }
 
@@ -8735,10 +8737,11 @@ S_force_ident_maybe_lex(pTHX_ char pit)
     }
 
     /* build ops for a bareword */
-    o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
+    pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+                                  newSVpvn_flags(PL_tokenbuf + 1,
                                                      tokenbuf_len - 1,
                                                       UTF ? SVf_UTF8 : 0 ));
-    o->op_private = OPpCONST_ENTERED;
+    pl_yylval.opval->op_private = OPpCONST_ENTERED;
     if (pit != '&')
        gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
                     (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
@@ -8746,11 +8749,7 @@ S_force_ident_maybe_lex(pTHX_ char pit)
                     ((PL_tokenbuf[0] == '$') ? SVt_PV
                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
                      : SVt_PVHV));
-    force_type = WORD;
-
-   doforce:
-    NEXTVAL_NEXTTOKE.opval = o;
-    force_next(force_type);
+    return WORD;
 }
 
 STATIC void