Don't allow literal control chars in var names in EBCDIC

Currently, a variable name of length-1 may have as its name some of the
possible control characters, though this usage is deprecated.  It is a
pain to fix this to work properly on EBCDIC, and since the use of these
is deprecated, the pumpking agreed with me to not to bother with doing
so.

diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index 04fdd11..cf0d020 100644 (file)
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -150,6 +150,12 @@ EXPECT
 Use of bare << to mean <<"" is deprecated at - line 2.
 ########
 # toke.c
+BEGIN {
+    if (ord('A') == 193) {
+        print "SKIPPED\n# Literal control characters in variable names forbidden on EBCDIC";
+        exit 0;
+    }
+}
 eval "\$\cT";
 eval "\${\7LOBAL_PHASE}";
 eval "\${\cT}";
@@ -1491,6 +1497,12 @@ I
 ########
 # toke.c
 #[perl #119123] disallow literal control character variables
+BEGIN {
+    if (ord('A') == 193) {
+        print "SKIPPED\n# Literal control characters in variable names forbidden on EBCDIC";
+        exit 0;
+    }
+}
 eval "\$\cQ = 25";
 eval "\${ \cX } = 24";
 *{

diff --git a/t/uni/variables.t b/t/uni/variables.t
index cea9352..e8259e5 100644 (file)
--- a/t/uni/variables.t
+++ b/t/uni/variables.t
@@ -102,7 +102,8 @@ for ( 0x0 .. 0xff ) {
         }
         else {
             $name = sprintf "\\x%02x, an ASCII control", $ord;
-            $deprecated = 1;
+            $syntax_error = $::IS_EBCDIC;
+            $deprecated = ! $syntax_error;
         }
     }
     elsif ($chr =~ /\pC/) {
@@ -112,14 +113,16 @@ for ( 0x0 .. 0xff ) {
         else {
             $name = sprintf "\\x%02x, a C1 control", $ord;
         }
-        $deprecated = 1;
+        $syntax_error = $::IS_EBCDIC;
+        $deprecated = ! $syntax_error;
     }
     elsif ($chr =~ /\p{XIDStart}/) {
         $name = sprintf "\\x%02x, a non-ASCII XIDS character", $ord;
     }
     elsif ($chr =~ /\p{XPosixSpace}/) {
         $name = sprintf "\\x%02x, a non-ASCII space character", $ord;
-        $deprecated = 1;
+        $syntax_error = $::IS_EBCDIC;
+        $deprecated = ! $syntax_error;
     }
     else {
         $name = sprintf "\\x%02x, a non-ASCII, non-XIDS graphic character", $ord;
@@ -130,7 +133,8 @@ for ( 0x0 .. 0xff ) {
     if ($chr !~ /\p{XIDS}/u) {
         if ($syntax_error) {
             evalbytes "\$$chr";
-            like($@, qr/syntax error/, "$name as a length-1 variable generates a syntax error");
+            like($@, qr/ syntax\ error | Unrecognized\ character /x,
+                     "$name as a length-1 variable generates a syntax error");
             $tests++;
         }
         elsif ($ord < 32 || chr =~ /[[:punct:][:digit:]]/a) {
@@ -350,12 +354,16 @@ EOP
         no warnings 'deprecated';
 
         for my $var ( '$', "\7LOBAL_PHASE", "^GLOBAL_PHASE", "^V" ) {
+          SKIP: {
+            skip("Literal control characters in variable names forbidden on EBCDIC", 3)
+                             if ($::IS_EBCDIC && ord substr($var, 0, 1) < 32);
             eval "\${ $var}";
             is($@, '', "\${ $var} works" );
             eval "\${$var }";
             is($@, '', "\${$var } works" );
             eval "\${ $var }";
             is($@, '', "\${ $var } works" );
+          }
         }
     }
 }
@@ -368,19 +376,30 @@ EOP
     );
     
     
-    is(
-        "".eval "*{^JOIN}",
-        "*main::\nOIN",
-        "...but \$^J is still legal"
-    );
+    SKIP: {
+        skip('Is $^U on EBCDIC 1047, BC; nothing works on 0037', 1)
+                                                                if $::IS_EBCDIC;
+        is(
+            "".eval "*{^JOIN}",
+            "*main::\nOIN",
+            "  ... but \$^J is still legal"
+        );
+    }
     
+  SKIP: {
+    skip("Literal control characters in variable names forbidden on EBCDIC", 2)
+                                                                if $::IS_EBCDIC;
     no warnings 'deprecated';
     my $ret = eval "\${\cT\n}";
     is($@, "", 'No errors from using ${\n\cT\n}');
     is($ret, $^T, "  ... and we got the right value");
+  }
 }
 
-{
+SKIP: {
+    skip("Literal control characters in variable names forbidden on EBCDIC", 5)
+                                                                if $::IS_EBCDIC;
+
     # Originally from t/base/lex.t, moved here since we can't
     # turn deprecation warnings off in that file.
     no strict;

diff --git a/toke.c b/toke.c
index 51075e5..b653687 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -8562,11 +8562,19 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
  *      Because all ASCII characters have the same representation whether
  *      encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
  *      '{' without knowing if is UTF-8 or not */
+#ifdef EBCDIC
+#   define VALID_LEN_ONE_IDENT(s, is_utf8)                                    \
+    (isGRAPH_A(*(s)) || ((is_utf8)                                            \
+                         ? isIDFIRST_utf8((U8*) (s))                          \
+                         : (isGRAPH_L1(*s)                                    \
+                            && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
+#else
 #   define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s))                 \
                                             && LIKELY(*(s) != '\0')           \
                                             && (! is_utf8                     \
                                                 || isASCII_utf8((U8*) (s))    \
                                                 || isIDFIRST_utf8((U8*) (s))))
+#endif
     if ((s <= PL_bufend - (is_utf8)
                           ? UTF8SKIP(s)
                           : 1)