perl/perl-5.27.1-Parse-caret-vars-with-subscripts-the-same-as-normal-.patch

From 4f08ed80a1ad3deb06ce5d8d20cc2d176dcbced0 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Thu, 29 Jun 2017 11:31:14 +0200
Subject: [PATCH] Parse caret vars with subscripts the same as normal vars
 inside of ${..} escaping
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This behavior is discussed in perl #131664, which complains that
"${^CAPTURE}[0]" does not work as expected. Abigail explains the
behavior is by design and Eirik Berg Hanssen expands on that explanation
pointing out that what /should/ work, "${^CAPTURE[0]}" does not,
which Sawyer then ruled was a bug.

So this patch makes "${^CAPTURE[0]}" (and "${^CAPTURE [0]}" [hi
abigial]) work the same as they would if the var was called @foo.

Signed-off-by: Petr Písař <ppisar@redhat.com>
---
 t/base/lex.t | 28 +++++++++++++++++++++++++++-
 toke.c       | 46 +++++++++++++++++++++++++---------------------
 2 files changed, 52 insertions(+), 22 deletions(-)

diff --git a/t/base/lex.t b/t/base/lex.t
index e154aca..89d46df 100644
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..109\n";
+print "1..116\n";
 
 $x = 'x';
 
@@ -154,6 +154,32 @@ my $test = 31;
   print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
   print "ok $test\n"; $test++;
 #  print "($@)\n" if $@;
+#
+  ${^TEST}= "splat";
+  @{^TEST}= ("foo", "bar");
+  %{^TEST}= ("foo" => "FOO", "bar" => "BAR" );
+
+  print "not " if "${^TEST}" ne "splat";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${^TEST}[0]" ne "splat[0]";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${^TEST[0]}" ne "foo";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${ ^TEST [1] }" ne "bar";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${^TEST}{foo}" ne "splat{foo}";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${^TEST{foo}}" ne "FOO";
+  print "ok $test\n"; $test++;
+
+  print "not " if "${ ^TEST {bar} }" ne "BAR";
+  print "ok $test\n"; $test++;
+
 
 # Now let's make sure that caret variables are all forced into the main package.
   package Someother;
diff --git a/toke.c b/toke.c
index 0dcf623..ace92e3 100644
--- a/toke.c
+++ b/toke.c
@@ -9352,19 +9352,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
         bool skip;
         char *s2;
         /* If we were processing {...} notation then...  */
-        if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
-            /* if it starts as a valid identifier, assume that it is one.
-               (the later check for } being at the expected point will trap
-               cases where this doesn't pan out.)  */
-            d += is_utf8 ? UTF8SKIP(d) : 1;
-            parse_ident(&s, &d, e, 1, is_utf8, TRUE);
-	    *d = '\0';
+        if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
+            || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
+                 && isWORDCHAR(*s))
+        ) {
+            /* note we have to check for a normal identifier first,
+             * as it handles utf8 symbols, and only after that has
+             * been ruled out can we look at the caret words */
+            if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
+                /* if it starts as a valid identifier, assume that it is one.
+                   (the later check for } being at the expected point will trap
+                   cases where this doesn't pan out.)  */
+                d += is_utf8 ? UTF8SKIP(d) : 1;
+                parse_ident(&s, &d, e, 1, is_utf8, TRUE);
+                *d = '\0';
+            }
+            else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
+                d++;
+                while (isWORDCHAR(*s) && d < e) {
+                    *d++ = *s++;
+                }
+                if (d >= e)
+                    Perl_croak(aTHX_ "%s", ident_too_long);
+                *d = '\0';
+            }
             tmp_copline = CopLINE(PL_curcop);
             if (s < PL_bufend && isSPACE(*s)) {
                 s = skipspace(s);
             }
 	    if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
-                /* ${foo[0]} and ${foo{bar}} notation.  */
+                /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation.  */
 		if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
 		    const char * const brack =
 			(const char *)
@@ -9383,19 +9400,6 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
 		return s;
 	    }
 	}
-	/* Handle extended ${^Foo} variables
-	 * 1999-02-27 mjd-perl-patch@plover.com */
-	else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
-		 && isWORDCHAR(*s))
-	{
-	    d++;
-	    while (isWORDCHAR(*s) && d < e) {
-		*d++ = *s++;
-	    }
-	    if (d >= e)
-		Perl_croak(aTHX_ "%s", ident_too_long);
-	    *d = '\0';
-	}
 
         if ( !tmp_copline )
             tmp_copline = CopLINE(PL_curcop);
-- 
2.9.4