Validate above-Latin1 characters in \N{} aliases
authorKarl Williamson <public@khwilliamson.com>
Fri, 9 Nov 2012 17:18:17 +0000 (10:18 -0700)
committerKarl Williamson <public@khwilliamson.com>
Sun, 11 Nov 2012 17:11:34 +0000 (10:11 -0700)
This completes the process of allowing users to define their own aliases
for \N{} in any language they choose.  Names have some validation
applied so that they can't, for example, begin with something that is a
digit in some Unicode script.  Tests and documentation are included in
this patch.  The loop in toke.c that does the validation for
user-supplied translators is revamped, and the messages that are output
when there is an error are fixed to work with UTF-8.

embedvar.h
intrpvar.h
lib/_charnames.pm
lib/charnames.pm
pod/perldelta.pod
pod/perldiag.pod
sv.c
t/lib/charnames/alias
t/re/pat_advanced.t
toke.c

index 65c2ff1..6efd53a 100644 (file)
 #define PL_utf8_alnum          (vTHX->Iutf8_alnum)
 #define PL_utf8_alpha          (vTHX->Iutf8_alpha)
 #define PL_utf8_blank          (vTHX->Iutf8_blank)
+#define PL_utf8_charname_begin (vTHX->Iutf8_charname_begin)
+#define PL_utf8_charname_continue      (vTHX->Iutf8_charname_continue)
 #define PL_utf8_digit          (vTHX->Iutf8_digit)
 #define PL_utf8_foldable       (vTHX->Iutf8_foldable)
 #define PL_utf8_foldclosures   (vTHX->Iutf8_foldclosures)
index 9cff6e4..b6d69ed 100644 (file)
@@ -631,6 +631,8 @@ PERLVAR(I, utf8_toupper, SV *)
 PERLVAR(I, utf8_totitle, SV *)
 PERLVAR(I, utf8_tolower, SV *)
 PERLVAR(I, utf8_tofold,        SV *)
+PERLVAR(I, utf8_charname_begin, SV *)
+PERLVAR(I, utf8_charname_continue, SV *)
 PERLVAR(I, last_swash_hv, HV *)
 PERLVAR(I, last_swash_tmps, U8 *)
 PERLVAR(I, last_swash_slen, STRLEN)
index ad7684d..bbb7378 100644 (file)
@@ -167,6 +167,8 @@ sub alias (@) # Set up a single alias
         $^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name;
     }
     else {
+        # This regex needs to be sync'd with the code in toke.c that checks
+        # for the same thing
         if ($name !~ / ^
                        \p{_Perl_Charname_Begin}
                        \p{_Perl_Charname_Continue}*
index 0786690..559dc4f 100644 (file)
@@ -88,6 +88,8 @@ sub string_vianame {
 1;
 __END__
 
+=encoding utf8
+
 =head1 NAME
 
 charnames - access to Unicode character names and named character sequences; also define character names
@@ -110,12 +112,16 @@ charnames - access to Unicode character names and named character sequences; als
  use charnames qw(cyrillic greek);
  print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
 
+ use utf8;
  use charnames ":full", ":alias" => {
    e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
    mychar => 0xE8000,  # Private use area
+   "自転車に乗る人" => "BICYCLIST"
  };
  print "\N{e_ACUTE} is a small letter e with an acute.\n";
  print "\N{mychar} allows me to name private use characters.\n";
+ print "And I can create synonyms in other languages,",
+       " such as \N{自転車に乗る人} for "BICYCLIST (U+1F6B4)\n";
 
  use charnames ();
  print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
@@ -270,9 +276,19 @@ conventions.  The aliases override any standard definitions, so, if
 you're twisted enough, you can change C<"\N{LATIN CAPITAL LETTER A}"> to
 mean C<"B">, etc.
 
-Aliases may not begin with anything other than an alphabetic character nor
-contain anything other than alphanumerics, spaces, dashes, parentheses, and
-underscores.  Currently they must be Latin1.
+Aliases must begin with a character that is alphabetic.  After that, each may
+contain any combination of word (C<\w>) characters, SPACE, (U+0020),
+HYPHEN-MINUS (U+002D), LEFT PARENTHESIS (U+0028), RIGHT PARENTHESIS (U+0029),
+and NO-BREAK SPACE (U+00A0).  These last three should never have been allowed
+in names, and are retained for backwards compatibility only; they may be
+deprecated and removed in future releases of Perl, so don't use them for new
+names.  (More precisely, the first character of a name you specify must be
+something that matches all of C<\p{ID_Start}>, C<\p{Alphabetic}>, and
+C<\p{Gc=Letter}>.  This makes sure it is what any reasonable person would view
+as an alphabetic character.  And, the other characters that match C<\w> must
+also match C<\p{ID_Continue}>.)  Starting with Perl v5.18, any Unicode
+characters meeting the above criteria may be used; prior to that only
+Latin1-range characters were acceptable.
 
 An alias can map to either an official Unicode character name (not a loose
 matched name) or to a
@@ -471,10 +487,6 @@ the form C<U+...>, it returns a chr instead.  In this case, if C<use bytes> is
 in effect and the character won't fit into a byte, it returns C<undef> and
 raises a warning.
 
-Names must be ASCII characters only, which means that you are out of luck if
-you want to create aliases in a language where some or all the characters of
-the desired aliases are non-ASCII.
-
 Since evaluation of the translation function (see L</CUSTOM
 TRANSLATORS>) happens in the middle of compilation (of a string
 literal), the translation function should not do any C<eval>s or
index 26d808f..abcd2ed 100644 (file)
@@ -27,6 +27,16 @@ here, but most should go in the L</Performance Enhancements> section.
 
 [ List each enhancement as a =head2 entry ]
 
+=head2 Character name aliases may now include non-Latin1-range characters
+
+It is possible to define your own names for characters for use in
+C<\N{...}>, C<charnames::vianame()>, etc.  These names can now be
+comprised of characters from the whole Unicode range.  This allows for
+names to be in your native language, and not just English.  Certain
+restrictions apply to the characters that may be used (you can't define
+a name that has punctuation in it, for example).  See L<charnames/CUSTOM
+ALIASES>.
+
 =head1 Security
 
 XXX Any security-related notices go here.  In particular, any security
index ba30c17..52fa476 100644 (file)
@@ -2710,7 +2710,7 @@ just before the first bad one.  If C<utf8> warnings are enabled, a
 warning is generated that gives more details about the type of
 malformation.
 
-=item Malformed UTF-8 returned by \N
+=item Malformed UTF-8 returned by \N{%s} immediately after '%s'
 
 (F) The charnames handler returned malformed UTF-8.
 
diff --git a/sv.c b/sv.c
index 726c5cc..067a9e0 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -13458,6 +13458,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_utf8_idcont     = sv_dup_inc(proto_perl->Iutf8_idcont, param);
     PL_utf8_xidcont    = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
     PL_utf8_foldable   = sv_dup_inc(proto_perl->Iutf8_foldable, param);
+    PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+    PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
     PL_ASCII           = sv_dup_inc(proto_perl->IASCII, param);
     PL_AboveLatin1     = sv_dup_inc(proto_perl->IAboveLatin1, param);
     PL_Latin1          = sv_dup_inc(proto_perl->ILatin1, param);
index fc13342..a71c657 100644 (file)
@@ -362,10 +362,35 @@ Invalid character in charnames alias definition; marked by <-- HERE in '4<-- HER
 Invalid character in charnames alias definition; marked by <-- HERE in 'e_A,<-- HERE CUTE'
 Invalid character in charnames alias definition; marked by <-- HERE in 'e_ACUT(?:\x{d7}|\x{C3}\x{97})<-- HERE E'
 ########
-# RT#73022, \N{...} interprets ... as octets rather than UTF-8
+# RT#73022
+# NAME \N{...} interprets ... as octets rather than UTF-8
 use utf8;
 use open qw( :utf8 :std );
-use charnames ":full", ":alias" => { ニ => "KATAKANA LETTER NI" };
-print "ok\n" if "\N{ニ}" eq "\x{30cb}";
+use charnames ":full", ":alias" => { "自転車に乗る人" => "BICYCLIST" };
+print "ok\n" if "\N{自転車に乗る人}" eq "\x{1F6B4}";
 EXPECT
 ok
+########
+# NAME Misspelled \N{} UTF-8 names are errors
+use utf8;
+use open qw( :utf8 :std );
+use charnames ":full", ":alias" => { "自転車に乗る人" => "BICYCLIST" };
+print "ok\n" if "\N{転車に乗る人}" eq "\x{1F6B4}";
+EXPECT
+OPTIONS regex
+Unknown charname '転車に乗る人' at - line \d+, within string
+########
+# NAME various wrong UTF-8 characters in :alias are errors
+# First has a punctuation, KATAKANA MIDDLE DOT, in it; second begins with a
+# digit: ARABIC-INDIC DIGIT FOUR
+use utf8;
+use open qw( :utf8 :std );
+use charnames ":full", ":alias" => { "自転車・に乗る人" => "BICYCLIST",
+                                     "٤転車に乗る人" => "BICYCLIST",
+                                    };
+print "ok\n" if "\N{自転車・に乗る人}" eq "\x{1F6B4}";
+print "ok\n" if "\N{٤転車に乗る人}" eq "\x{1F6B4}";
+EXPECT
+OPTIONS regex
+Invalid character in charnames alias definition; marked by <-- HERE in '٤<-- HERE 転車に乗る人'
+Invalid character in charnames alias definition; marked by <-- HERE in '自転車・<-- HERE に乗る人' at - line \d+
index 538c3ef..7b43fd1 100644 (file)
@@ -1024,6 +1024,25 @@ sub run_tests {
         my $name = "A\x{D7}O";
         eval "q(W) =~ /\\N{$name}/";
         ok $@ && $@ =~ /Invalid character/, 'Verify that latin1 symbol in name gives error';
+        my $utf8_name = "7 CITIES OF GOLD";
+        utf8::upgrade($utf8_name);
+        eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+        ok $@ && $@ =~ /Invalid character/, 'Verify that leading digit in utf8 name gives error';
+        $utf8_name = "SHARP #";
+        utf8::upgrade($utf8_name);
+        eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+        ok $@ && $@ =~ /Invalid character/, 'Verify that ASCII symbol in utf8 name gives error';
+        $utf8_name = "A HOUSE \xF7 AGAINST ITSELF";
+        utf8::upgrade($utf8_name);
+        eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+        ok $@ && $@ =~ /Invalid character/, 'Verify that latin1 symbol in utf8 name gives error';
+        $utf8_name = "\x{664} HORSEMEN}";
+        eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+        ok $@ && $@ =~ /Invalid character/, 'Verify that leading above Latin1 digit in utf8 name gives error';
+        $utf8_name = "A \x{1F4A9} WOULD SMELL AS SWEET}";
+        eval "use utf8; q(W) =~ /\\N{$utf8_name}/";
+        ok $@ && $@ =~ /Invalid character/, 'Verify that above Latin1 symbol in utf8 name gives error';
+
         undef $w;
         $name = "A\x{D1}O";
         eval "q(W) =~ /\\N{$name}/";
diff --git a/toke.c b/toke.c
index c71cdb7..ea6318e 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2639,9 +2639,6 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
      * interior, hence to the "}".  Finds what the name resolves to, returning
      * an SV* containing it; NULL if no valid one found */
 
-    STRLEN len;
-    const char *str;
-    const char* i = s;
     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
 
     HV * table;
@@ -2695,76 +2692,134 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
        }
     }
 
-    /* A custom translator can leave res not in UTF-8, so make sure.  XXX This
-     * can be revisited to not use utf8 for characters that don't need it when
-     * regexes don't have to be in utf8 for Unicode semantics.  If doing so,
-     * remember EBCDIC */
-    sv_utf8_upgrade(res);
-
-    /* Don't accept malformed input */
-    str = SvPV_const(res, len);
-    if (! is_utf8_string((U8 *) str, len)) {
-        yyerror("Malformed UTF-8 returned by \\N");
-        return NULL;
-    }
+    /* Here, it isn't Perl's charname handler.  We can't rely on a
+     * user-supplied handler to validate the input name.  For non-ut8 input,
+     * look to see that the first character is legal.  Then loop through the
+     * rest checking that each is a continuation */
 
     /* This code needs to be sync'ed with a regex in _charnames.pm which does
      * the same thing */
 
-    /* For non-ut8 input, look to see that the first character is an alpha,
-     * then loop through the rest checking that each is a continuation */
     if (! UTF) {
-        if (! isALPHAU(*i)) {
+        if (! isALPHAU(*s)) {
             goto bad_charname;
         }
-        else for (i = s + 1; i < e; i++) {
-            if (! isCHARNAME_CONT(*i)) {
+        s++;
+        while (s < e) {
+            if (! isCHARNAME_CONT(*s)) {
                 goto bad_charname;
             }
+            s++;
         }
     }
     else {
-        /* Similarly for utf8.  For invariants can check directly.  We accept
-         * anything above the latin1 range because it is immaterial to Perl if
-         * it is correct or not, and is expensive to check.  But it is fairly
-         * easy in the latin1 range to convert the variants into a single
-         * character and check those */
-        if (UTF8_IS_INVARIANT(*i)) {
-            if (! isALPHAU(*i)) {
+        /* Similarly for utf8.  For invariants can check directly; for other
+         * Latin1, can calculate their code point and check; otherwise  use a
+         * swash */
+        if (UTF8_IS_INVARIANT(*s)) {
+            if (! isALPHAU(*s)) {
                 goto bad_charname;
             }
-        } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
-            if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
-                                                        *(i+1)))))
-            {
+            s++;
+        } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+            if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
                 goto bad_charname;
             }
+            s += 2;
         }
-        for (i = s + UTF8SKIP(s); i < e; i+= UTF8SKIP(i)) {
-            if (UTF8_IS_INVARIANT(*i)) {
-                if (isCHARNAME_CONT(*i)) continue;
-            } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
-                continue;
-            } else if (isCHARNAME_CONT(
-                        UNI_TO_NATIVE(
-                        TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
-            {
-                continue;
+        else {
+            if (! PL_utf8_charname_begin) {
+                U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+                PL_utf8_charname_begin = _core_swash_init("utf8",
+                                                        "_Perl_Charname_Begin",
+                                                        &PL_sv_undef,
+                                                        1, 0, NULL, &flags);
+            }
+            if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
+                goto bad_charname;
+            }
+            s += UTF8SKIP(s);
+        }
+
+        while (s < e) {
+            if (UTF8_IS_INVARIANT(*s)) {
+                if (! isCHARNAME_CONT(*s)) {
+                    goto bad_charname;
+                }
+                s++;
+            }
+            else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+                if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
+                                                                    *(s+1)))))
+                {
+                    goto bad_charname;
+                }
+                s += 2;
+            }
+            else {
+                if (! PL_utf8_charname_continue) {
+                    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+                    PL_utf8_charname_continue = _core_swash_init("utf8",
+                                                "_Perl_Charname_Continue",
+                                                &PL_sv_undef,
+                                                1, 0, NULL, &flags);
+                }
+                if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
+                    goto bad_charname;
+                }
+                s += UTF8SKIP(s);
             }
-            goto bad_charname;
         }
     }
 
-    return res;
+    /* A custom translator can leave res not in UTF-8, so make sure.  XXX This
+     * can be revisited to not use utf8 for characters that don't need it when
+     * regexes don't have to be in utf8 for Unicode semantics.  If doing so,
+     * remember EBCDIC */
+    if (! SvUTF8(res)) {
+        sv_utf8_upgrade(res);
+    }
+    else { /* Don't accept malformed input */
+        const U8* first_bad_char_loc;
+        STRLEN len;
+        const char* const str = SvPV_const(res, len);
+        if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
+            /* If warnings are on, this will print a more detailed analysis of
+             * what is wrong than the error message below */
+            utf8n_to_uvuni(first_bad_char_loc,
+                           (char *) first_bad_char_loc - str,
+                           NULL, 0);
+
+            /* We deliberately don't try to print the malformed character,
+             * which might not print very well; it also may be just the first
+             * of many malformations, so don't print what comes after it */
+            yyerror_pv(
+              Perl_form(aTHX_
+                "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
+                 (int) (e - backslash_ptr + 1), backslash_ptr,
+                 (int) ((char *) first_bad_char_loc - str), str
+              ),
+              SVf_UTF8);
+            return NULL;
+        }
+    }
 
-  bad_charname:
+    return res;
 
-    /* The e-i passed to the final %.*s makes sure that should the trailing NUL
-     * be missing that this print won't run off the end of the string */
-    yyerror(Perl_form(aTHX_
-        "Invalid character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
-        (int)(i - s + 1), s, (int)(e - i), i + 1));
-    return NULL;
+  bad_charname: {
+        int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
+
+        /* The final %.*s makes sure that should the trailing NUL be missing
+         * that this print won't run off the end of the string */
+        yyerror_pv(
+          Perl_form(aTHX_
+            "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
+            (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
+            (int)(e - s + bad_char_size), s + bad_char_size
+          ),
+          UTF ? SVf_UTF8 : 0);
+        return NULL;
+    }
 }
 
 /*
@@ -9010,9 +9065,12 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
             why3 = "} is not defined";
         report:
             if (strEQ(key,"charnames")) {
-                msg = Perl_newSVpvf(aTHX_
-                        /* The +3 is for '\N{'; -4 for that, plus '}' */
-                        "Unknown charname '%.*s'", (int)typelen - 4, type + 3);
+                yyerror_pv(Perl_form(aTHX_
+                            /* The +3 is for '\N{'; -4 for that, plus '}' */
+                            "Unknown charname '%.*s'", (int)typelen - 4, type + 3
+                           ),
+                           UTF ? SVf_UTF8 : 0);
+                return sv;
             }
             else {
                 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",