doco improvement for attributes.pm

[perl5.git] / utf8.c

diff --git a/utf8.c b/utf8.c
index 69ab6b9..2b1e99b 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -257,9 +257,9 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
 
 /*
 
 
 /*
 

-Tests if some arbitrary number of bytes begins in a valid UTF-8
+Tests if the first C<len> bytes of string C<s> form a valid UTF-8

 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
 character.  Note that an INVARIANT (i.e. ASCII) character is a valid

-UTF-8 character.  The actual number of bytes in the UTF-8 character
+UTF-8 character.  The number of bytes in the UTF-8 character

 will be returned if it is valid, otherwise 0.
 
 This is the "slow" version as opposed to the "fast" version which is
 will be returned if it is valid, otherwise 0.
 
 This is the "slow" version as opposed to the "fast" version which is


@@ -283,7 +283,7 @@ S_is_utf8_char_slow(const U8 *s, const STRLEN len)
     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
 
     if (UTF8_IS_INVARIANT(u))
     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
 
     if (UTF8_IS_INVARIANT(u))

-       return 1;
+       return len == 1;

 
     if (!UTF8_IS_START(u))
        return 0;
 
     if (!UTF8_IS_START(u))
        return 0;


@@ -316,25 +316,65 @@ S_is_utf8_char_slow(const U8 *s, const STRLEN len)
 }
 
 /*
 }
 
 /*

+=for apidoc is_utf8_char_buf
+
+Returns the number of bytes that comprise the first UTF-8 encoded character in
+buffer C<buf>.  C<buf_end> should point to one position beyond the end of the
+buffer.  0 is returned if C<buf> does not point to a complete, valid UTF-8
+encoded character.
+
+Note that an INVARIANT character (i.e. ASCII on non-EBCDIC
+machines) is a valid UTF-8 character.
+
+=cut */
+
+STRLEN
+Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end)
+{
+
+    STRLEN len;
+
+    PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF;
+
+    if (buf_end <= buf) {
+       return 0;
+    }
+
+    len = buf_end - buf;
+    if (len > UTF8SKIP(buf)) {
+       len = UTF8SKIP(buf);
+    }
+
+#ifdef IS_UTF8_CHAR
+    if (IS_UTF8_CHAR_FAST(len))
+        return IS_UTF8_CHAR(buf, len) ? len : 0;
+#endif /* #ifdef IS_UTF8_CHAR */
+    return is_utf8_char_slow(buf, len);
+}
+
+/*

 =for apidoc is_utf8_char
 
 =for apidoc is_utf8_char
 

+DEPRECATED!
+

 Tests if some arbitrary number of bytes begins in a valid UTF-8
 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
 character will be returned if it is valid, otherwise 0.
 
 Tests if some arbitrary number of bytes begins in a valid UTF-8
 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
 character will be returned if it is valid, otherwise 0.
 

+This function is deprecated due to the possibility that malformed input could
+cause reading beyond the end of the input buffer.  Use C<is_utf8_char_buf>
+instead.
+

 =cut */
 =cut */

+

 STRLEN
 Perl_is_utf8_char(const U8 *s)
 {
 STRLEN
 Perl_is_utf8_char(const U8 *s)
 {

-    const STRLEN len = UTF8SKIP(s);
-

     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
     PERL_ARGS_ASSERT_IS_UTF8_CHAR;

-#ifdef IS_UTF8_CHAR
-    if (IS_UTF8_CHAR_FAST(len))
-        return IS_UTF8_CHAR(s, len) ? len : 0;
-#endif /* #ifdef IS_UTF8_CHAR */
-    return is_utf8_char_slow(s, len);
+
+    /* Assumes we have enough space, which is why this is deprecated */
+    return is_utf8_char_buf(s, s + UTF8SKIP(s));

 }
 
 
 }
 
 


@@ -343,9 +383,9 @@ Perl_is_utf8_char(const U8 *s)
 
 Returns true if first C<len> bytes of the given string form a valid
 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated
 
 Returns true if first C<len> bytes of the given string form a valid
 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated

-using C<strlen(s)>.  Note that 'a valid UTF-8 string' does not mean 'a
-string that contains code points above 0x7F encoded in UTF-8' because a
-valid ASCII string is a valid UTF-8 string.
+using C<strlen(s)> (which means if you use this option, that C<s> has to have a
+terminating NUL byte).  Note that all characters being ASCII constitute 'a
+valid UTF-8 string'.

 
 See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
 
 
 See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
 


@@ -361,35 +401,32 @@ Perl_is_utf8_string(const U8 *s, STRLEN len)
     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 
     while (x < send) {
     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 
     while (x < send) {

-       STRLEN c;

         /* Inline the easy bits of is_utf8_char() here for speed... */
         /* Inline the easy bits of is_utf8_char() here for speed... */

-        if (UTF8_IS_INVARIANT(*x))
-             c = 1;
+        if (UTF8_IS_INVARIANT(*x)) {
+           x++;
+        }

         else if (!UTF8_IS_START(*x))
         else if (!UTF8_IS_START(*x))

-            goto out;
+            return FALSE;

         else {
              /* ... and call is_utf8_char() only if really needed. */
         else {
              /* ... and call is_utf8_char() only if really needed. */

-#ifdef IS_UTF8_CHAR
-            c = UTF8SKIP(x);
+            const STRLEN c = UTF8SKIP(x);
+            const U8* const next_char_ptr = x + c;
+
+            if (next_char_ptr > send) {
+                return FALSE;
+            }
+

             if (IS_UTF8_CHAR_FAST(c)) {
                 if (!IS_UTF8_CHAR(x, c))
             if (IS_UTF8_CHAR_FAST(c)) {
                 if (!IS_UTF8_CHAR(x, c))

-                    c = 0;
+                    return FALSE;

             }
             }

-            else
-               c = is_utf8_char_slow(x, c);
-#else
-            c = is_utf8_char(x);
-#endif /* #ifdef IS_UTF8_CHAR */
-             if (!c)
-                 goto out;
+            else if (! is_utf8_char_slow(x, c)) {
+                return FALSE;
+            }
+            x = next_char_ptr;

         }
         }

-        x += c;

     }
 
     }
 

- out:
-    if (x != send)
-       return FALSE;
-

     return TRUE;
 }
 
     return TRUE;
 }
 


@@ -427,27 +464,29 @@ Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 
     while (x < send) {
     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 
     while (x < send) {

+        const U8* next_char_ptr;
+

         /* Inline the easy bits of is_utf8_char() here for speed... */
         if (UTF8_IS_INVARIANT(*x))
         /* Inline the easy bits of is_utf8_char() here for speed... */
         if (UTF8_IS_INVARIANT(*x))

-            c = 1;
+            next_char_ptr = x + 1;

         else if (!UTF8_IS_START(*x))
             goto out;
         else {
             /* ... and call is_utf8_char() only if really needed. */
         else if (!UTF8_IS_START(*x))
             goto out;
         else {
             /* ... and call is_utf8_char() only if really needed. */

-#ifdef IS_UTF8_CHAR

             c = UTF8SKIP(x);
             c = UTF8SKIP(x);

+            next_char_ptr = c + x;
+            if (next_char_ptr > send) {
+                goto out;
+            }

             if (IS_UTF8_CHAR_FAST(c)) {
                 if (!IS_UTF8_CHAR(x, c))
                     c = 0;
             } else
                 c = is_utf8_char_slow(x, c);
             if (IS_UTF8_CHAR_FAST(c)) {
                 if (!IS_UTF8_CHAR(x, c))
                     c = 0;
             } else
                 c = is_utf8_char_slow(x, c);

-#else
-            c = is_utf8_char(x);
-#endif /* #ifdef IS_UTF8_CHAR */

             if (!c)
                 goto out;
         }
             if (!c)
                 goto out;
         }

-         x += c;
+         x = next_char_ptr;

         outlen++;
     }
 
         outlen++;
     }
 


@@ -493,7 +532,7 @@ C<retlen> to C<-1> and return zero.
 Certain code points are considered problematic.  These are Unicode surrogates,
 Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
 By default these are considered regular code points, but certain situations
 Certain code points are considered problematic.  These are Unicode surrogates,
 Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
 By default these are considered regular code points, but certain situations

-warrant special handling for them.  if C<flags> contains
+warrant special handling for them.  If C<flags> contains

 UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
 malformations and handled as such.  The flags UTF8_DISALLOW_SURROGATE,
 UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
 UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
 malformations and handled as such.  The flags UTF8_DISALLOW_SURROGATE,
 UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode


@@ -511,7 +550,7 @@ Very large code points (above 0x7FFF_FFFF) are considered more problematic than
 the others that are above the Unicode legal maximum.  There are several
 reasons, one of which is that the original UTF-8 specification never went above
 this number (the current 0x10FFF limit was imposed later).  The UTF-8 encoding
 the others that are above the Unicode legal maximum.  There are several
 reasons, one of which is that the original UTF-8 specification never went above
 this number (the current 0x10FFF limit was imposed later).  The UTF-8 encoding

-on ASCII platforms for these large code point begins with a byte containing
+on ASCII platforms for these large code points begins with a byte containing

 0xFE or 0xFF.  The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
 malformations, while allowing smaller above-Unicode code points.  (Of course
 UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,
 0xFE or 0xFF.  The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
 malformations, while allowing smaller above-Unicode code points.  (Of course
 UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,


@@ -1210,7 +1249,9 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
     return utf16_to_utf8(p, d, bytelen, newlen);
 }
 
     return utf16_to_utf8(p, d, bytelen, newlen);
 }
 

-/* for now these are all defined (inefficiently) in terms of the utf8 versions */
+/* for now these are all defined (inefficiently) in terms of the utf8 versions.
+ * Note that the macros in handy.h that call these short-circuit calling them
+ * for Latin-1 range inputs */

 
 bool
 Perl_is_uni_alnum(pTHX_ UV c)
 
 bool
 Perl_is_uni_alnum(pTHX_ UV c)


@@ -1313,42 +1354,206 @@ Perl_is_uni_xdigit(pTHX_ UV c)
 }
 
 UV
 }
 
 UV

+Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
+{
+    /* We have the latin1-range values compiled into the core, so just use
+     * those, converting the result to utf8.  The only difference between upper
+     * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
+     * either "SS" or "Ss".  Which one to use is passed into the routine in
+     * 'S_or_s' to avoid a test */
+
+    UV converted = toUPPER_LATIN1_MOD(c);
+
+    PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
+
+    assert(S_or_s == 'S' || S_or_s == 's');
+
+    if (UNI_IS_INVARIANT(converted)) { /* No difference between the two for
+                                         characters in this range */
+       *p = (U8) converted;
+       *lenp = 1;
+       return converted;
+    }
+
+    /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
+     * which it maps to one of them, so as to only have to have one check for
+     * it in the main case */
+    if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+       switch (c) {
+           case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
+               converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
+               break;
+           case MICRO_SIGN:
+               converted = GREEK_CAPITAL_LETTER_MU;
+               break;
+           case LATIN_SMALL_LETTER_SHARP_S:
+               *(p)++ = 'S';
+               *p = S_or_s;
+               *lenp = 2;
+               return 'S';
+           default:
+               Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
+               /* NOTREACHED */
+       }
+    }
+
+    *(p)++ = UTF8_TWO_BYTE_HI(converted);
+    *p = UTF8_TWO_BYTE_LO(converted);
+    *lenp = 2;
+
+    return converted;
+}
+
+/* Call the function to convert a UTF-8 encoded character to the specified case.
+ * Note that there may be more than one character in the result.
+ * INP is a pointer to the first byte of the input character
+ * OUTP will be set to the first byte of the string of changed characters.  It
+ *     needs to have space for UTF8_MAXBYTES_CASE+1 bytes
+ * LENP will be set to the length in bytes of the string of changed characters
+ *
+ * The functions return the ordinal of the first character in the string of OUTP */
+#define CALL_UPPER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_toupper, "ToUc", "utf8::ToSpecUc")
+#define CALL_TITLE_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_totitle, "ToTc", "utf8::ToSpecTc")
+#define CALL_LOWER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tolower, "ToLc", "utf8::ToSpecLc")
+
+/* This additionally has the input parameter SPECIALS, which if non-zero will
+ * cause this to use the SPECIALS hash for folding (meaning get full case
+ * folding); otherwise, when zero, this implies a simple case fold */
+#define CALL_FOLD_CASE(INP, OUTP, LENP, SPECIALS) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tofold, "ToCf", (SPECIALS) ? "utf8::ToSpecCf" : NULL)
+
+UV

 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
 {
 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
 {

+    dVAR;
+
+    /* Convert the Unicode character whose ordinal is c to its uppercase
+     * version and store that in UTF-8 in p and its length in bytes in lenp.
+     * Note that the p needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
+     * the changed version may be longer than the original character.
+     *
+     * The ordinal of the first character of the changed version is returned
+     * (but note, as explained above, that there may be more.) */
+

     PERL_ARGS_ASSERT_TO_UNI_UPPER;
 
     PERL_ARGS_ASSERT_TO_UNI_UPPER;
 

+    if (c < 256) {
+       return _to_upper_title_latin1((U8) c, p, lenp, 'S');
+    }
+

     uvchr_to_utf8(p, c);
     uvchr_to_utf8(p, c);

-    return to_utf8_upper(p, p, lenp);
+    return CALL_UPPER_CASE(p, p, lenp);

 }
 
 UV
 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
 {
 }
 
 UV
 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
 {

+    dVAR;
+

     PERL_ARGS_ASSERT_TO_UNI_TITLE;
 
     PERL_ARGS_ASSERT_TO_UNI_TITLE;
 

+    if (c < 256) {
+       return _to_upper_title_latin1((U8) c, p, lenp, 's');
+    }
+

     uvchr_to_utf8(p, c);
     uvchr_to_utf8(p, c);

-    return to_utf8_title(p, p, lenp);
+    return CALL_TITLE_CASE(p, p, lenp);
+}
+
+STATIC U8
+S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
+{
+    /* We have the latin1-range values compiled into the core, so just use
+     * those, converting the result to utf8.  Since the result is always just
+     * one character, we allow p to be NULL */
+
+    U8 converted = toLOWER_LATIN1(c);
+
+    if (p != NULL) {
+       if (UNI_IS_INVARIANT(converted)) {
+           *p = converted;
+           *lenp = 1;
+       }
+       else {
+           *p = UTF8_TWO_BYTE_HI(converted);
+           *(p+1) = UTF8_TWO_BYTE_LO(converted);
+           *lenp = 2;
+       }
+    }
+    return converted;

 }
 
 UV
 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
 {
 }
 
 UV
 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
 {

+    dVAR;
+

     PERL_ARGS_ASSERT_TO_UNI_LOWER;
 
     PERL_ARGS_ASSERT_TO_UNI_LOWER;
 

+    if (c < 256) {
+       return to_lower_latin1((U8) c, p, lenp);
+    }
+

     uvchr_to_utf8(p, c);
     uvchr_to_utf8(p, c);

-    return to_utf8_lower(p, p, lenp);
+    return CALL_LOWER_CASE(p, p, lenp);

 }
 
 UV
 }
 
 UV

-Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
+Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const bool flags)

 {
 {

+    /* Corresponds to to_lower_latin1(), flags is TRUE if to use full case
+     * folding */
+
+    UV converted;
+
+    PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
+
+    if (c == MICRO_SIGN) {
+       converted = GREEK_SMALL_LETTER_MU;
+    }
+    else if (flags && c == LATIN_SMALL_LETTER_SHARP_S) {
+       *(p)++ = 's';
+       *p = 's';
+       *lenp = 2;
+       return 's';
+    }
+    else { /* In this range the fold of all other characters is their lower
+              case */
+       converted = toLOWER_LATIN1(c);
+    }
+
+    if (UNI_IS_INVARIANT(converted)) {
+       *p = (U8) converted;
+       *lenp = 1;
+    }
+    else {
+       *(p)++ = UTF8_TWO_BYTE_HI(converted);
+       *p = UTF8_TWO_BYTE_LO(converted);
+       *lenp = 2;
+    }
+
+    return converted;
+}
+
+UV
+Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const bool flags)
+{
+
+    /* Not currently externally documented, and subject to change, <flags> is
+     * TRUE iff full folding is to be used */
+

     PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
 
     PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
 

+    if (c < 256) {
+       return _to_fold_latin1((U8) c, p, lenp, flags);
+    }
+

     uvchr_to_utf8(p, c);
     uvchr_to_utf8(p, c);

-    return _to_utf8_fold_flags(p, p, lenp, flags);
+    return CALL_FOLD_CASE(p, p, lenp, flags);

 }
 
 }
 

-/* for now these all assume no locale info available for Unicode > 255 */
+/* for now these all assume no locale info available for Unicode > 255; and
+ * the corresponding macros in handy.h (like isALNUM_LC_uvchr) should have been
+ * called instead, so that these don't get called for < 255 */

 
 bool
 Perl_is_uni_alnum_lc(pTHX_ UV c)
 
 bool
 Perl_is_uni_alnum_lc(pTHX_ UV c)


@@ -1462,11 +1667,27 @@ static bool
 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
                 const char *const swashname)
 {
 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
                 const char *const swashname)
 {

+    /* returns a boolean giving whether or not the UTF8-encoded character that
+     * starts at <p> is in the swash indicated by <swashname>.  <swash>
+     * contains a pointer to where the swash indicated by <swashname>
+     * is to be stored; which this routine will do, so that future calls will
+     * look at <*swash> and only generate a swash if it is not null
+     *
+     * Note that it is assumed that the buffer length of <p> is enough to
+     * contain all the bytes that comprise the character.  Thus, <*p> should
+     * have been checked before this call for mal-formedness enough to assure
+     * that. */
+

     dVAR;
 
     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
 
     dVAR;
 
     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
 

-    if (!is_utf8_char(p))
+    /* The API should have included a length for the UTF-8 character in <p>,
+     * but it doesn't.  We therefor assume that p has been validated at least
+     * as far as there being enough bytes available in it to accommodate the
+     * character without reading beyond the end, and pass that number on to the
+     * validating routine */
+    if (!is_utf8_char_buf(p, p + UTF8SKIP(p)))

        return FALSE;
     if (!*swash)
        *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
        return FALSE;
     if (!*swash)
        *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);


@@ -1808,6 +2029,18 @@ Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
 }
 
     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
 }
 

+bool
+Perl__is_utf8_quotemeta(pTHX_ const U8 *p)
+{
+    /* For exclusive use of pp_quotemeta() */
+
+    dVAR;
+
+    PERL_ARGS_ASSERT__IS_UTF8_QUOTEMETA;
+
+    return is_utf8_common(p, &PL_utf8_quotemeta, "_Perl_Quotemeta");
+}
+

 /*
 =for apidoc to_utf8_case
 
 /*
 =for apidoc to_utf8_case
 


@@ -1945,6 +2178,53 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
     return len ? utf8_to_uvchr(ustrp, 0) : 0;
 }
 
     return len ? utf8_to_uvchr(ustrp, 0) : 0;
 }
 

+STATIC UV
+S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+{
+    /* This is called when changing the case of a utf8-encoded character above
+     * the Latin1 range, and the operation is in locale.  If the result
+     * contains a character that crosses the 255/256 boundary, disallow the
+     * change, and return the original code point.  See L<perlfunc/lc> for why;
+     *
+     * p       points to the original string whose case was changed
+     * result  the code point of the first character in the changed-case string
+     * ustrp   points to the changed-case string (<result> represents its first char)
+     * lenp    points to the length of <ustrp> */
+
+    UV original;    /* To store the first code point of <p> */
+
+    PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
+
+    assert(! UTF8_IS_INVARIANT(*p) && ! UTF8_IS_DOWNGRADEABLE_START(*p));
+
+    /* We know immediately if the first character in the string crosses the
+     * boundary, so can skip */
+    if (result > 255) {
+
+       /* Look at every character in the result; if any cross the
+       * boundary, the whole thing is disallowed */
+       U8* s = ustrp + UTF8SKIP(ustrp);
+       U8* e = ustrp + *lenp;
+       while (s < e) {
+           if (UTF8_IS_INVARIANT(*s) || UTF8_IS_DOWNGRADEABLE_START(*s))
+           {
+               goto bad_crossing;
+           }
+           s += UTF8SKIP(s);
+       }
+
+       /* Here, no characters crossed, result is ok as-is */
+       return result;
+    }
+
+bad_crossing:
+
+    /* Failed, have to return the original */
+    original = utf8_to_uvchr(p, lenp);
+    Copy(p, ustrp, *lenp, char);
+    return original;
+}
+

 /*
 =for apidoc to_utf8_upper
 
 /*
 =for apidoc to_utf8_upper
 


@@ -1958,15 +2238,61 @@ The first character of the uppercased version is returned
 
 =cut */
 
 
 =cut */
 

+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ *              were used in the calculation; otherwise unchanged. */
+

 UV
 UV

-Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)

 {
     dVAR;
 
 {
     dVAR;
 

-    PERL_ARGS_ASSERT_TO_UTF8_UPPER;
+    UV result;
+
+    PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
+
+    if (UTF8_IS_INVARIANT(*p)) {
+       if (flags) {
+           result = toUPPER_LC(*p);
+       }
+       else {
+           return _to_upper_title_latin1(*p, ustrp, lenp, 'S');
+       }
+    }
+    else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+       if (flags) {
+           result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+       }
+       else {
+           return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+                                         ustrp, lenp, 'S');
+       }
+    }
+    else {  /* utf8, ord above 255 */
+       result = CALL_UPPER_CASE(p, ustrp, lenp);
+
+       if (flags) {
+           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+       }
+       return result;
+    }

 
 

-    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
-                             &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
+    /* Here, used locale rules.  Convert back to utf8 */
+    if (UTF8_IS_INVARIANT(result)) {
+       *ustrp = (U8) result;
+       *lenp = 1;
+    }
+    else {
+       *ustrp = UTF8_EIGHT_BIT_HI(result);
+       *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+       *lenp = 2;
+    }
+
+    if (tainted_ptr) {
+       *tainted_ptr = TRUE;
+    }
+    return result;

 }
 
 /*
 }
 
 /*


@@ -1982,15 +2308,63 @@ The first character of the titlecased version is returned
 
 =cut */
 
 
 =cut */
 

+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ *        Since titlecase is not defined in POSIX, uppercase is used instead
+ *        for these/
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ *              were used in the calculation; otherwise unchanged. */
+

 UV
 UV

-Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)

 {
     dVAR;
 
 {
     dVAR;
 

-    PERL_ARGS_ASSERT_TO_UTF8_TITLE;
+    UV result;
+
+    PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
+
+    if (UTF8_IS_INVARIANT(*p)) {
+       if (flags) {
+           result = toUPPER_LC(*p);
+       }
+       else {
+           return _to_upper_title_latin1(*p, ustrp, lenp, 's');
+       }
+    }
+    else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+       if (flags) {
+           result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+       }
+       else {
+           return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+                                         ustrp, lenp, 's');
+       }
+    }
+    else {  /* utf8, ord above 255 */
+       result = CALL_TITLE_CASE(p, ustrp, lenp);
+
+       if (flags) {
+           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+       }
+       return result;
+    }

 
 

-    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
-                             &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
+    /* Here, used locale rules.  Convert back to utf8 */
+    if (UTF8_IS_INVARIANT(result)) {
+       *ustrp = (U8) result;
+       *lenp = 1;
+    }
+    else {
+       *ustrp = UTF8_EIGHT_BIT_HI(result);
+       *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+       *lenp = 2;
+    }
+
+    if (tainted_ptr) {
+       *tainted_ptr = TRUE;
+    }
+    return result;

 }
 
 /*
 }
 
 /*


@@ -2006,15 +2380,62 @@ The first character of the lowercased version is returned
 
 =cut */
 
 
 =cut */
 

+/* Not currently externally documented, and subject to change:
+ * <flags> is set iff locale semantics are to be used for code points < 256
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ *              were used in the calculation; otherwise unchanged. */
+

 UV
 UV

-Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
+Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)

 {
 {

+    UV result;
+

     dVAR;
 
     dVAR;
 

-    PERL_ARGS_ASSERT_TO_UTF8_LOWER;
+    PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
+
+    if (UTF8_IS_INVARIANT(*p)) {
+       if (flags) {
+           result = toLOWER_LC(*p);
+       }
+       else {
+           return to_lower_latin1(*p, ustrp, lenp);
+       }
+    }
+    else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+       if (flags) {
+           result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+       }
+       else {
+           return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+                                  ustrp, lenp);
+       }
+    }
+    else {  /* utf8, ord above 255 */
+       result = CALL_LOWER_CASE(p, ustrp, lenp);
+
+       if (flags) {
+           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+       }

 
 

-    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
-                             &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
+       return result;
+    }
+
+    /* Here, used locale rules.  Convert back to utf8 */
+    if (UTF8_IS_INVARIANT(result)) {
+       *ustrp = (U8) result;
+       *lenp = 1;
+    }
+    else {
+       *ustrp = UTF8_EIGHT_BIT_HI(result);
+       *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+       *lenp = 2;
+    }
+
+    if (tainted_ptr) {
+       *tainted_ptr = TRUE;
+    }
+    return result;

 }
 
 /*
 }
 
 /*


@@ -2031,97 +2452,265 @@ The first character of the foldcased version is returned
 
 =cut */
 
 
 =cut */
 

-/* Not currently externally documented is 'flags', which currently is non-zero
- * if full case folds are to be used; otherwise simple folds */
+/* Not currently externally documented, and subject to change,
+ * in <flags>
+ *     bit FOLD_FLAGS_LOCALE is set iff locale semantics are to be used for code
+ *                           points < 256.  Since foldcase is not defined in
+ *                           POSIX, lowercase is used instead
+ *      bit FOLD_FLAGS_FULL   is set iff full case folds are to be used;
+ *                           otherwise simple folds
+ * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
+ *              were used in the calculation; otherwise unchanged. */

 
 UV
 
 UV

-Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
+Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr)

 {
 {

-    const char *specials = (flags) ? "utf8::ToSpecFold" : NULL;
-

     dVAR;
 
     dVAR;
 

+    UV result;
+

     PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
 
     PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
 

-    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
-                             &PL_utf8_tofold, "ToFold", specials);
+    if (UTF8_IS_INVARIANT(*p)) {
+       if (flags & FOLD_FLAGS_LOCALE) {
+           result = toLOWER_LC(*p);
+       }
+       else {
+           return _to_fold_latin1(*p, ustrp, lenp,
+                                  cBOOL(flags & FOLD_FLAGS_FULL));
+       }
+    }
+    else if UTF8_IS_DOWNGRADEABLE_START(*p) {
+       if (flags & FOLD_FLAGS_LOCALE) {
+           result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+       }
+       else {
+           return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+                                  ustrp, lenp, cBOOL(flags & FOLD_FLAGS_FULL));
+       }
+    }
+    else {  /* utf8, ord above 255 */
+       result = CALL_FOLD_CASE(p, ustrp, lenp, flags);
+
+       if ((flags & FOLD_FLAGS_LOCALE)) {
+           result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+       }
+
+       return result;
+    }
+
+    /* Here, used locale rules.  Convert back to utf8 */
+    if (UTF8_IS_INVARIANT(result)) {
+       *ustrp = (U8) result;
+       *lenp = 1;
+    }
+    else {
+       *ustrp = UTF8_EIGHT_BIT_HI(result);
+       *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
+       *lenp = 2;
+    }
+
+    if (tainted_ptr) {
+       *tainted_ptr = TRUE;
+    }
+    return result;

 }
 
 /* Note:
 }
 
 /* Note:

- * A "swash" is a swatch hash.
- * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
+ * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().

  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
  */
  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
  */

+

 SV*
 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
 {
 SV*
 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
 {

+    PERL_ARGS_ASSERT_SWASH_INIT;
+
+    /* Returns a copy of a swash initiated by the called function.  This is the
+     * public interface, and returning a copy prevents others from doing
+     * mischief on the original */
+
+    return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, FALSE, NULL, FALSE));
+}
+
+SV*
+Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, bool return_if_undef, SV* invlist, bool passed_in_invlist_has_user_defined_property)
+{
+    /* Initialize and return a swash, creating it if necessary.  It does this
+     * by calling utf8_heavy.pl in the general case.
+     *
+     * This interface should only be used by functions that won't destroy or
+     * adversely change the swash, as doing so affects all other uses of the
+     * swash in the program; the general public should use 'Perl_swash_init'
+     * instead.
+     *
+     * pkg  is the name of the package that <name> should be in.
+     * name is the name of the swash to find.  Typically it is a Unicode
+     *     property name, including user-defined ones
+     * listsv is a string to initialize the swash with.  It must be of the form
+     *     documented as the subroutine return value in
+     *     L<perlunicode/User-Defined Character Properties>
+     * minbits is the number of bits required to represent each data element.
+     *     It is '1' for binary properties.
+     * none I (khw) do not understand this one, but it is used only in tr///.
+     * return_if_undef is TRUE if the routine shouldn't croak if it can't find
+     *     the requested property
+     * invlist is an inversion list to initialize the swash with (or NULL)
+     * has_user_defined_property is TRUE if <invlist> has some component that
+     *      came from a user-defined property
+     *
+     * Thus there are three possible inputs to find the swash: <name>,
+     * <listsv>, and <invlist>.  At least one must be specified.  The result
+     * will be the union of the specified ones, although <listsv>'s various
+     * actions can intersect, etc. what <name> gives.
+     *
+     * <invlist> is only valid for binary properties */
+

     dVAR;
     dVAR;

-    SV* retval;
-    dSP;
-    const size_t pkg_len = strlen(pkg);
-    const size_t name_len = strlen(name);
-    HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
-    SV* errsv_save;
-    GV *method;
+    SV* retval = &PL_sv_undef;

 
 

-    PERL_ARGS_ASSERT_SWASH_INIT;
+    assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
+    assert(! invlist || minbits == 1);
+
+    /* If data was passed in to go out to utf8_heavy to find the swash of, do
+     * so */
+    if (listsv != &PL_sv_undef || strNE(name, "")) {
+       dSP;
+       const size_t pkg_len = strlen(pkg);
+       const size_t name_len = strlen(name);
+       HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
+       SV* errsv_save;
+       GV *method;

 
 

-    PUSHSTACKi(PERLSI_MAGIC);
-    ENTER;
-    SAVEHINTS();
-    save_re_context();
-    if (PL_parser && PL_parser->error_count)
-       SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
-    method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
-    if (!method) {     /* demand load utf8 */
+       PERL_ARGS_ASSERT__CORE_SWASH_INIT;
+
+       PUSHSTACKi(PERLSI_MAGIC);

        ENTER;
        ENTER;

+       SAVEHINTS();
+       save_re_context();
+       if (PL_parser && PL_parser->error_count)
+           SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
+       method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
+       if (!method) {  /* demand load utf8 */
+           ENTER;
+           errsv_save = newSVsv(ERRSV);
+           /* It is assumed that callers of this routine are not passing in
+            * any user derived data.  */
+           /* Need to do this after save_re_context() as it will set
+            * PL_tainted to 1 while saving $1 etc (see the code after getrx:
+            * in Perl_magic_get).  Even line to create errsv_save can turn on
+            * PL_tainted.  */
+           SAVEBOOL(PL_tainted);
+           PL_tainted = 0;
+           Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
+                            NULL);
+           if (!SvTRUE(ERRSV))
+               sv_setsv(ERRSV, errsv_save);
+           SvREFCNT_dec(errsv_save);
+           LEAVE;
+       }
+       SPAGAIN;
+       PUSHMARK(SP);
+       EXTEND(SP,5);
+       mPUSHp(pkg, pkg_len);
+       mPUSHp(name, name_len);
+       PUSHs(listsv);
+       mPUSHi(minbits);
+       mPUSHi(none);
+       PUTBACK;

        errsv_save = newSVsv(ERRSV);
        errsv_save = newSVsv(ERRSV);

-       /* It is assumed that callers of this routine are not passing in any
-          user derived data.  */
-       /* Need to do this after save_re_context() as it will set PL_tainted to
-          1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
-          Even line to create errsv_save can turn on PL_tainted.  */
-       SAVEBOOL(PL_tainted);
-       PL_tainted = 0;
-       Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
-                        NULL);
+       /* If we already have a pointer to the method, no need to use
+        * call_method() to repeat the lookup.  */
+       if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
+           : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
+       {
+           retval = *PL_stack_sp--;
+           SvREFCNT_inc(retval);
+       }

        if (!SvTRUE(ERRSV))
            sv_setsv(ERRSV, errsv_save);
        SvREFCNT_dec(errsv_save);
        LEAVE;
        if (!SvTRUE(ERRSV))
            sv_setsv(ERRSV, errsv_save);
        SvREFCNT_dec(errsv_save);
        LEAVE;

+       POPSTACK;
+       if (IN_PERL_COMPILETIME) {
+           CopHINTS_set(PL_curcop, PL_hints);
+       }
+       if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
+           if (SvPOK(retval))
+
+               /* If caller wants to handle missing properties, let them */
+               if (return_if_undef) {
+                   return NULL;
+               }
+               Perl_croak(aTHX_
+                          "Can't find Unicode property definition \"%"SVf"\"",
+                          SVfARG(retval));
+           Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+       }
+    } /* End of calling the module to find the swash */
+
+    /* Make sure there is an inversion list for binary properties */
+    if (minbits == 1) {
+       SV** swash_invlistsvp = NULL;
+       SV* swash_invlist = NULL;
+       bool invlist_in_swash_is_valid = FALSE;
+       HV* swash_hv = NULL;
+
+        /* If this operation fetched a swash, get its already existing
+         * inversion list or create one for it */
+       if (retval != &PL_sv_undef) {
+           swash_hv = MUTABLE_HV(SvRV(retval));
+
+           swash_invlistsvp = hv_fetchs(swash_hv, "INVLIST", FALSE);
+           if (swash_invlistsvp) {
+               swash_invlist = *swash_invlistsvp;
+               invlist_in_swash_is_valid = TRUE;
+           }
+           else {
+               swash_invlist = _swash_to_invlist(retval);
+           }
+       }
+
+       /* If an inversion list was passed in, have to include it */
+       if (invlist) {
+
+            /* Any fetched swash will by now have an inversion list in it;
+             * otherwise <swash_invlist>  will be NULL, indicating that we
+             * didn't fetch a swash */
+           if (swash_invlist) {
+
+               /* Add the passed-in inversion list, which invalidates the one
+                * already stored in the swash */
+               invlist_in_swash_is_valid = FALSE;
+               _invlist_union(invlist, swash_invlist, &swash_invlist);
+           }
+           else {
+
+               /* Here, there is no swash already.  Set up a minimal one */
+               swash_hv = newHV();
+               retval = newRV_inc(MUTABLE_SV(swash_hv));
+               swash_invlist = invlist;
+           }
+
+            if (passed_in_invlist_has_user_defined_property) {
+                if (! hv_stores(swash_hv, "USER_DEFINED", newSVuv(1))) {
+                    Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+                }
+            }
+       }
+
+        /* Here, we have computed the union of all the passed-in data.  It may
+         * be that there was an inversion list in the swash which didn't get
+         * touched; otherwise save the one computed one */
+       if (! invlist_in_swash_is_valid) {
+           if (! hv_stores(MUTABLE_HV(SvRV(retval)), "INVLIST", swash_invlist))
+            {
+               Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+           }
+       }

     }
     }

-    SPAGAIN;
-    PUSHMARK(SP);
-    EXTEND(SP,5);
-    mPUSHp(pkg, pkg_len);
-    mPUSHp(name, name_len);
-    PUSHs(listsv);
-    mPUSHi(minbits);
-    mPUSHi(none);
-    PUTBACK;
-    errsv_save = newSVsv(ERRSV);
-    /* If we already have a pointer to the method, no need to use call_method()
-       to repeat the lookup.  */
-    if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
-       : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
-       retval = newSVsv(*PL_stack_sp--);
-    else
-       retval = &PL_sv_undef;
-    if (!SvTRUE(ERRSV))
-       sv_setsv(ERRSV, errsv_save);
-    SvREFCNT_dec(errsv_save);
-    LEAVE;
-    POPSTACK;
-    if (IN_PERL_COMPILETIME) {
-       CopHINTS_set(PL_curcop, PL_hints);
-    }
-    if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
-        if (SvPOK(retval))
-           Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
-                      SVfARG(retval));
-       Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
-    }
+

     return retval;
 }
 
     return retval;
 }
 


@@ -2132,13 +2721,41 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits
  * the lower-level routine, and it is similarly broken for returning
  * multiple values.  --jhi
  * For those, you should use to_utf8_case() instead */
  * the lower-level routine, and it is similarly broken for returning
  * multiple values.  --jhi
  * For those, you should use to_utf8_case() instead */

-/* Now SWASHGET is recasted into S_swash_get in this file. */
+/* Now SWASHGET is recasted into S_swatch_get in this file. */

 
 /* Note:
  * Returns the value of property/mapping C<swash> for the first character
  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
 
 /* Note:
  * Returns the value of property/mapping C<swash> for the first character
  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.

+ *
+ * A "swash" is a hash which contains initially the keys/values set up by
+ * SWASHNEW.  The purpose is to be able to completely represent a Unicode
+ * property for all possible code points.  Things are stored in a compact form
+ * (see utf8_heavy.pl) so that calculation is required to find the actual
+ * property value for a given code point.  As code points are looked up, new
+ * key/value pairs are added to the hash, so that the calculation doesn't have
+ * to ever be re-done.  Further, each calculation is done, not just for the
+ * desired one, but for a whole block of code points adjacent to that one.
+ * For binary properties on ASCII machines, the block is usually for 64 code
+ * points, starting with a code point evenly divisible by 64.  Thus if the
+ * property value for code point 257 is requested, the code goes out and
+ * calculates the property values for all 64 code points between 256 and 319,
+ * and stores these as a single 64-bit long bit vector, called a "swatch",
+ * under the key for code point 256.  The key is the UTF-8 encoding for code
+ * point 256, minus the final byte.  Thus, if the length of the UTF-8 encoding
+ * for a code point is 13 bytes, the key will be 12 bytes long.  If the value
+ * for code point 258 is then requested, this code realizes that it would be
+ * stored under the key for 256, and would find that value and extract the
+ * relevant bit, offset from 256.
+ *
+ * Non-binary properties are stored in as many bits as necessary to represent
+ * their values (32 currently, though the code is more general than that), not
+ * as single bits, but the principal is the same: the value for each key is a
+ * vector that encompasses the property values for all code points whose UTF-8
+ * representations are represented by the key.  That is, for all code points
+ * whose UTF-8 representations are length N bytes, and the key is the first N-1
+ * bytes of that.

  */
 UV
 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
  */
 UV
 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)


@@ -2157,6 +2774,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
 
     PERL_ARGS_ASSERT_SWASH_FETCH;
 
 
     PERL_ARGS_ASSERT_SWASH_FETCH;
 

+    /* Convert to utf8 if not already */

     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
        tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
        tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
        tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
        tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);


@@ -2181,19 +2799,6 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
       /* If char is encoded then swatch is for the prefix */
        needents = (1 << UTF_ACCUMULATION_SHIFT);
        off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
       /* If char is encoded then swatch is for the prefix */
        needents = (1 << UTF_ACCUMULATION_SHIFT);
        off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;

-       if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
-           const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
-
-           /* This outputs warnings for binary properties only, assuming that
-            * to_utf8_case() will output any for non-binary.  Also, surrogates
-            * aren't checked for, as that would warn on things like
-            * /\p{Gc=Cs}/ */
-           SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
-           if (SvUV(*bitssvp) == 1) {
-               Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
-                   "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", code_point);
-           }
-       }

     }
 
     /*
     }
 
     /*


@@ -2216,7 +2821,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
        /* Try our second-level swatch cache, kept in a hash. */
        SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
 
        /* Try our second-level swatch cache, kept in a hash. */
        SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
 

-       /* If not cached, generate it via swash_get */
+       /* If not cached, generate it via swatch_get */

        if (!svp || !SvPOK(*svp)
                 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
            /* We use utf8n_to_uvuni() as we want an index into
        if (!svp || !SvPOK(*svp)
                 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
            /* We use utf8n_to_uvuni() as we want an index into


@@ -2225,9 +2830,9 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
            const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
                                           ckWARN(WARN_UTF8) ?
                                           0 : UTF8_ALLOW_ANY);
            const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
                                           ckWARN(WARN_UTF8) ?
                                           0 : UTF8_ALLOW_ANY);

-           swatch = swash_get(swash,
+           swatch = swatch_get(swash,

                    /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
                    /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */

-                               (klen) ? (code_point & ~(needents - 1)) : 0,
+                               (klen) ? (code_point & ~((UV)needents - 1)) : 0,

                                needents);
 
            if (IN_PERL_COMPILETIME)
                                needents);
 
            if (IN_PERL_COMPILETIME)


@@ -2237,7 +2842,9 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
 
            if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
                     || (slen << 3) < needents)
 
            if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
                     || (slen << 3) < needents)

-               Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
+               Perl_croak(aTHX_ "panic: swash_fetch got improper swatch, "
+                          "svp=%p, tmps=%p, slen=%"UVuf", needents=%"UVuf,
+                          svp, tmps, (UV)slen, (UV)needents);

        }
 
        PL_last_swash_hv = hv;
        }
 
        PL_last_swash_hv = hv;


@@ -2250,6 +2857,24 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
            Copy(ptr, PL_last_swash_key, klen, U8);
     }
 
            Copy(ptr, PL_last_swash_key, klen, U8);
     }
 

+    if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
+       SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+
+       /* This outputs warnings for binary properties only, assuming that
+        * to_utf8_case() will output any for non-binary.  Also, surrogates
+        * aren't checked for, as that would warn on things like /\p{Gc=Cs}/ */
+
+       if (! bitssvp || SvUV(*bitssvp) == 1) {
+           /* User-defined properties can silently match above-Unicode */
+           SV** const user_defined_svp = hv_fetchs(hv, "USER_DEFINED", FALSE);
+           if (! user_defined_svp || ! SvUV(*user_defined_svp)) {
+               const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
+               Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
+                   "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", code_point);
+           }
+       }
+    }
+

     switch ((int)((slen << 3) / needents)) {
     case 1:
        bit = 1 << (off & 7);
     switch ((int)((slen << 3) / needents)) {
     case 1:
        bit = 1 << (off & 7);


@@ -2264,7 +2889,8 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
        off <<= 2;
        return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
     }
        off <<= 2;
        return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
     }

-    Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
+    Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
+              "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);

     NORETURN_FUNCTION_END;
 }
 
     NORETURN_FUNCTION_END;
 }
 


@@ -2329,19 +2955,31 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
        if (wants_value) {
            if (isBLANK(*l)) {
                ++l;
        if (wants_value) {
            if (isBLANK(*l)) {
                ++l;

-               flags = PERL_SCAN_SILENT_ILLDIGIT
-                     | PERL_SCAN_DISALLOW_PREFIX
-                     | PERL_SCAN_SILENT_NON_PORTABLE;
-               numlen = lend - l;
-               *val = grok_hex((char *)l, &numlen, &flags, NULL);
-               if (numlen)
-                   l += numlen;
-               else
-                   *val = 0;
+
+               /* The ToLc, etc table mappings are not in hex, and must be
+                * corrected by adding the code point to them */
+               if (typeto) {
+                   char *after_strtol = (char *) lend;
+                   *val = Strtol((char *)l, &after_strtol, 10);
+                   l = (U8 *) after_strtol;
+               }
+               else { /* Other tables are in hex, and are the correct result
+                         without tweaking */
+                   flags = PERL_SCAN_SILENT_ILLDIGIT
+                       | PERL_SCAN_DISALLOW_PREFIX
+                       | PERL_SCAN_SILENT_NON_PORTABLE;
+                   numlen = lend - l;
+                   *val = grok_hex((char *)l, &numlen, &flags, NULL);
+                   if (numlen)
+                       l += numlen;
+                   else
+                       *val = 0;
+               }

            }
            else {
                *val = 0;
                if (typeto) {
            }
            else {
                *val = 0;
                if (typeto) {

+                   /* diag_listed_as: To%s: illegal mapping '%s' */

                    Perl_croak(aTHX_ "%s: illegal mapping '%s'",
                                     typestr, l);
                }
                    Perl_croak(aTHX_ "%s: illegal mapping '%s'",
                                     typestr, l);
                }


@@ -2356,6 +2994,7 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
        if (wants_value) {
            *val = 0;
            if (typeto) {
        if (wants_value) {
            *val = 0;
            if (typeto) {

+               /* diag_listed_as: To%s: illegal mapping '%s' */

                Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
            }
        }
                Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
            }
        }


@@ -2379,34 +3018,54 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
  */
 STATIC SV*
  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
  */
 STATIC SV*

-S_swash_get(pTHX_ SV* swash, UV start, UV span)
+S_swatch_get(pTHX_ SV* swash, UV start, UV span)

 {
     SV *swatch;
     U8 *l, *lend, *x, *xend, *s, *send;
     STRLEN lcur, xcur, scur;
     HV *const hv = MUTABLE_HV(SvRV(swash));
 {
     SV *swatch;
     U8 *l, *lend, *x, *xend, *s, *send;
     STRLEN lcur, xcur, scur;
     HV *const hv = MUTABLE_HV(SvRV(swash));

+    SV** const invlistsvp = hv_fetchs(hv, "INVLIST", FALSE);
+
+    SV** listsvp = NULL; /* The string containing the main body of the table */
+    SV** extssvp = NULL;
+    SV** invert_it_svp = NULL;
+    U8* typestr = NULL;
+    STRLEN bits;
+    STRLEN octets; /* if bits == 1, then octets == 0 */
+    UV  none;
+    UV  end = start + span;
+
+    if (invlistsvp == NULL) {
+        SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+        SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
+        SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
+        extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+        listsvp = hv_fetchs(hv, "LIST", FALSE);
+        invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
+
+       bits  = SvUV(*bitssvp);
+       none  = SvUV(*nonesvp);
+       typestr = (U8*)SvPV_nolen(*typesvp);
+    }
+    else {
+       bits = 1;
+       none = 0;
+    }
+    octets = bits >> 3; /* if bits == 1, then octets == 0 */

 
 

-    /* The string containing the main body of the table */
-    SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
-
-    SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
-    SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
-    SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
-    SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
-    SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
-    const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
-    const STRLEN bits  = SvUV(*bitssvp);
-    const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
-    const UV     none  = SvUV(*nonesvp);
-    const UV     end   = start + span;
-
-    PERL_ARGS_ASSERT_SWASH_GET;
+    PERL_ARGS_ASSERT_SWATCH_GET;

 
     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
 
     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {

-       Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
+       Perl_croak(aTHX_ "panic: swatch_get doesn't expect bits %"UVuf,

                                                 (UV)bits);
     }
 
                                                 (UV)bits);
     }
 

+    /* If overflowed, use the max possible */
+    if (end < start) {
+       end = UV_MAX;
+       span = end - start;
+    }
+

     /* create and initialize $swatch */
     scur   = octets ? (span * octets) : (span + 7) / 8;
     swatch = newSV(scur);
     /* create and initialize $swatch */
     scur   = octets ? (span * octets) : (span + 7) / 8;
     swatch = newSV(scur);


@@ -2436,11 +3095,16 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
     SvCUR_set(swatch, scur);
     s = (U8*)SvPVX(swatch);
 
     SvCUR_set(swatch, scur);
     s = (U8*)SvPVX(swatch);
 

+    if (invlistsvp) {  /* If has an inversion list set up use that */
+       _invlist_populate_swatch(*invlistsvp, start, end, s);
+        return swatch;
+    }
+

     /* read $swash->{LIST} */
     l = (U8*)SvPV(*listsvp, lcur);
     lend = l + lcur;
     while (l < lend) {
     /* read $swash->{LIST} */
     l = (U8*)SvPV(*listsvp, lcur);
     lend = l + lcur;
     while (l < lend) {

-       UV min, max, val;
+       UV min, max, val, upper;

        l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
                                         cBOOL(octets), typestr);
        if (l > lend) {
        l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
                                         cBOOL(octets), typestr);
        if (l > lend) {


@@ -2451,6 +3115,15 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
        if (max < start)
            continue;
 
        if (max < start)
            continue;
 

+       /* <end> is generally 1 beyond where we want to set things, but at the
+        * platform's infinity, where we can't go any higher, we want to
+        * include the code point at <end> */
+        upper = (max < end)
+                ? max
+                : (max != UV_MAX || end != UV_MAX)
+                  ? end - 1
+                  : end;
+

        if (octets) {
            UV key;
            if (min < start) {
        if (octets) {
            UV key;
            if (min < start) {


@@ -2459,10 +3132,8 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
                }
                min = start;
            }
                }
                min = start;
            }

-           for (key = min; key <= max; key++) {
+           for (key = min; key <= upper; key++) {

                STRLEN offset;
                STRLEN offset;

-               if (key >= end)
-                   goto go_out_list;

                /* offset must be non-negative (start <= min <= key < end) */
                offset = octets * (key - start);
                if (bits == 8)
                /* offset must be non-negative (start <= min <= key < end) */
                offset = octets * (key - start);
                if (bits == 8)


@@ -2486,15 +3157,13 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
            UV key;
            if (min < start)
                min = start;
            UV key;
            if (min < start)
                min = start;

-           for (key = min; key <= max; key++) {
+
+           for (key = min; key <= upper; key++) {

                const STRLEN offset = (STRLEN)(key - start);
                const STRLEN offset = (STRLEN)(key - start);

-               if (key >= end)
-                   goto go_out_list;

                s[offset >> 3] |= 1 << (offset & 7);
            }
        }
     } /* while */
                s[offset >> 3] |= 1 << (offset & 7);
            }
        }
     } /* while */

-  go_out_list:

 
     /* Invert if the data says it should be.  Assumes that bits == 1 */
     if (invert_it_svp && SvUV(*invert_it_svp)) {
 
     /* Invert if the data says it should be.  Assumes that bits == 1 */
     if (invert_it_svp && SvUV(*invert_it_svp)) {


@@ -2565,19 +3234,22 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
        otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
        otherbits = (STRLEN)SvUV(*otherbitssvp);
        if (bits < otherbits)
        otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
        otherbits = (STRLEN)SvUV(*otherbitssvp);
        if (bits < otherbits)

-           Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
+           Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch, "
+                      "bits=%"UVuf", otherbits=%"UVuf, (UV)bits, (UV)otherbits);

 
        /* The "other" swatch must be destroyed after. */
 
        /* The "other" swatch must be destroyed after. */

-       other = swash_get(*othersvp, start, span);
+       other = swatch_get(*othersvp, start, span);

        o = (U8*)SvPV(other, olen);
 
        if (!olen)
        o = (U8*)SvPV(other, olen);
 
        if (!olen)

-           Perl_croak(aTHX_ "panic: swash_get got improper swatch");
+           Perl_croak(aTHX_ "panic: swatch_get got improper swatch");

 
        s = (U8*)SvPV(swatch, slen);
        if (bits == 1 && otherbits == 1) {
            if (slen != olen)
 
        s = (U8*)SvPV(swatch, slen);
        if (bits == 1 && otherbits == 1) {
            if (slen != olen)

-               Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
+               Perl_croak(aTHX_ "panic: swatch_get found swatch length "
+                          "mismatch, slen=%"UVuf", olen=%"UVuf,
+                          (UV)slen, (UV)olen);

 
            switch (opc) {
            case '+':
 
            switch (opc) {
            case '+':


@@ -2742,7 +3414,9 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
        while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
            SV** listp;
            if (! SvPOK(sv_to)) {
        while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
            SV** listp;
            if (! SvPOK(sv_to)) {

-               Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() unexpectedly is not a string");
+               Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() "
+                          "unexpectedly is not a string, flags=%lu",
+                          (unsigned long)SvFLAGS(sv_to));

            }
            /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", utf8_to_uvchr((U8*) char_from, 0), utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
 
            }
            /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", utf8_to_uvchr((U8*) char_from, 0), utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
 


@@ -2904,13 +3578,13 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
                /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", inverse, val));*/
            }
 
                /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", inverse, val));*/
            }
 

-           /* swash_get() increments the value of val for each element in the
+           /* swatch_get() increments the value of val for each element in the

             * range.  That makes more compact tables possible.  You can
             * express the capitalization, for example, of all consecutive
             * letters with a single line: 0061\t007A\t0041 This maps 0061 to
             * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
             * and it's not documented; it appears to be used only in
             * range.  That makes more compact tables possible.  You can
             * express the capitalization, for example, of all consecutive
             * letters with a single line: 0061\t007A\t0041 This maps 0061 to
             * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
             * and it's not documented; it appears to be used only in

-            * implementing tr//; I copied the semantics from swash_get(), just
+            * implementing tr//; I copied the semantics from swatch_get(), just

             * in case */
            if (!none || val < none) {
                ++val;
             * in case */
            if (!none || val < none) {
                ++val;


@@ -2976,7 +3650,9 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
 
     /* If the ending is somehow corrupt and isn't a new line, add another
      * element for the final range that isn't in the inversion list */
 
     /* If the ending is somehow corrupt and isn't a new line, add another
      * element for the final range that isn't in the inversion list */

-    if (! (*lend == '\n' || (*lend == '\0' && *(lend - 1) == '\n'))) {
+    if (! (*lend == '\n'
+       || (*lend == '\0' && (lcur == 0 || *(lend - 1) == '\n'))))
+    {

        elements++;
     }
 
        elements++;
     }
 


@@ -3002,7 +3678,7 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
        _invlist_invert_prop(invlist);
     }
 
        _invlist_invert_prop(invlist);
     }
 

-    /* This code is copied from swash_get()
+    /* This code is copied from swatch_get()

      * read $swash->{EXTRAS} */
     x = (U8*)SvPV(*extssvp, xcur);
     xend = x + xcur;
      * read $swash->{EXTRAS} */
     x = (U8*)SvPV(*extssvp, xcur);
     xend = x + xcur;


@@ -3048,13 +3724,15 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
        otherbits = (STRLEN)SvUV(*otherbitssvp);
 
        if (bits != otherbits || bits != 1) {
        otherbits = (STRLEN)SvUV(*otherbitssvp);
 
        if (bits != otherbits || bits != 1) {

-           Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean properties");
+           Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean "
+                      "properties, bits=%"UVuf", otherbits=%"UVuf,
+                      (UV)bits, (UV)otherbits);

        }
 
        /* The "other" swatch must be destroyed after. */
        other = _swash_to_invlist((SV *)*othersvp);
 
        }
 
        /* The "other" swatch must be destroyed after. */
        other = _swash_to_invlist((SV *)*othersvp);
 

-       /* End of code copied from swash_get() */
+       /* End of code copied from swatch_get() */

        switch (opc) {
        case '+':
            _invlist_union(invlist, other, &invlist);
        switch (opc) {
        case '+':
            _invlist_union(invlist, other, &invlist);


@@ -3082,7 +3760,7 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
 =for apidoc uvchr_to_utf8
 
 Adds the UTF-8 representation of the Native code point C<uv> to the end
 =for apidoc uvchr_to_utf8
 
 Adds the UTF-8 representation of the Native code point C<uv> to the end

-of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
+of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free

 bytes available. The return value is the pointer to the byte after the
 end of the new character. In other words,
 
 bytes available. The return value is the pointer to the byte after the
 end of the new character. In other words,
 


@@ -3144,9 +3822,9 @@ bool
 Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
 {
     /* May change: warns if surrogates, non-character code points, or
 Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
 {
     /* May change: warns if surrogates, non-character code points, or

-     * non-Unicode code points are in s which has length len.  Returns TRUE if
-     * none found; FALSE otherwise.  The only other validity check is to make
-     * sure that this won't exceed the string's length */
+     * non-Unicode code points are in s which has length len bytes.  Returns
+     * TRUE if none found; FALSE otherwise.  The only other validity check is
+     * to make sure that this won't exceed the string's length */

 
     const U8* const e = s + len;
     bool ok = TRUE;
 
     const U8* const e = s + len;
     bool ok = TRUE;


@@ -3159,7 +3837,7 @@ Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
                           "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
            return FALSE;
        }
                           "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
            return FALSE;
        }

-       if (*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE) {
+       if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) {

            STRLEN char_len;
            if (UTF8_IS_SUPER(s)) {
                if (ckWARN_d(WARN_NON_UNICODE)) {
            STRLEN char_len;
            if (UTF8_IS_SUPER(s)) {
                if (ckWARN_d(WARN_NON_UNICODE)) {


@@ -3343,6 +4021,9 @@ http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
  *                         points below 256; unicode rules for above 255; and
  *                         folds that cross those boundaries are disallowed,
  *                         like the NOMIX_ASCII option
  *                         points below 256; unicode rules for above 255; and
  *                         folds that cross those boundaries are disallowed,
  *                         like the NOMIX_ASCII option

+ *  FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this
+ *                           routine.  This allows that step to be skipped.
+ *  FOLDEQ_S2_ALREADY_FOLDED   Similarly.

  */
 I32
 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)
  */
 I32
 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)


@@ -3359,11 +4040,14 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1
     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];

-    U8 natbuf[2];               /* Holds native 8-bit char converted to utf8;
-                                   these always fit in 2 bytes */

 
     PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
 
 
     PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
 

+    /* The algorithm requires that input with the flags on the first line of
+     * the assert not be pre-folded. */
+    assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_UTF8_LOCALE))
+       && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
+

     if (pe1) {
         e1 = *(U8**)pe1;
     }
     if (pe1) {
         e1 = *(U8**)pe1;
     }


@@ -3405,6 +4089,10 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1
        assert(e2);
     }
 
        assert(e2);
     }
 

+    /* If both operands are already folded, we could just do a memEQ on the
+     * whole strings at once, but it would be better if the caller realized
+     * this and didn't even call us */
+

     /* Look through both strings, a character at a time */
     while (p1 < e1 && p2 < e2) {
 
     /* Look through both strings, a character at a time */
     while (p1 < e1 && p2 < e2) {
 


@@ -3412,96 +4100,108 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1
         * and the length of the fold.  (exception: locale rules just get the
         * character to a single byte) */
         if (n1 == 0) {
         * and the length of the fold.  (exception: locale rules just get the
         * character to a single byte) */
         if (n1 == 0) {

+           if (flags & FOLDEQ_S1_ALREADY_FOLDED) {
+               f1 = (U8 *) p1;
+               n1 = UTF8SKIP(f1);
+           }

 
 

-           /* If in locale matching, we use two sets of rules, depending on if
-            * the code point is above or below 255.  Here, we test for and
-            * handle locale rules */
-           if ((flags & FOLDEQ_UTF8_LOCALE)
-               && (! u1 || UTF8_IS_INVARIANT(*p1) || UTF8_IS_DOWNGRADEABLE_START(*p1)))
-           {
-               /* There is no mixing of code points above and below 255. */
-               if (u2 && (! UTF8_IS_INVARIANT(*p2)
-                   && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
+           else {
+               /* If in locale matching, we use two sets of rules, depending
+                * on if the code point is above or below 255.  Here, we test
+                * for and handle locale rules */
+               if ((flags & FOLDEQ_UTF8_LOCALE)
+                   && (! u1 || UTF8_IS_INVARIANT(*p1)
+                       || UTF8_IS_DOWNGRADEABLE_START(*p1)))

                {
                {

-                   return 0;
+                   /* There is no mixing of code points above and below 255. */
+                   if (u2 && (! UTF8_IS_INVARIANT(*p2)
+                       && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
+                   {
+                       return 0;
+                   }
+
+                   /* We handle locale rules by converting, if necessary, the
+                    * code point to a single byte. */
+                   if (! u1 || UTF8_IS_INVARIANT(*p1)) {
+                       *foldbuf1 = *p1;
+                   }
+                   else {
+                       *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+                   }
+                   n1 = 1;

                }
                }

+               else if (isASCII(*p1)) {    /* Note, that here won't be both
+                                              ASCII and using locale rules */

 
 

-               /* We handle locale rules by converting, if necessary, the code
-                * point to a single byte. */
-               if (! u1 || UTF8_IS_INVARIANT(*p1)) {
-                   *foldbuf1 = *p1;
+                   /* If trying to mix non- with ASCII, and not supposed to,
+                    * fail */
+                   if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
+                       return 0;
+                   }
+                   n1 = 1;
+                   *foldbuf1 = toLOWER(*p1);   /* Folds in the ASCII range are
+                                                  just lowercased */

                }
                }

-               else {
-                   *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+               else if (u1) {
+                   to_utf8_fold(p1, foldbuf1, &n1);

                }
                }

-               n1 = 1;
-           }
-           else if (isASCII(*p1)) {    /* Note, that here won't be both ASCII
-                                          and using locale rules */
-
-               /* If trying to mix non- with ASCII, and not supposed to, fail */
-               if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
-                   return 0;
+               else {  /* Not utf8, get utf8 fold */
+                   to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1);

                }
                }

-               n1 = 1;
-               *foldbuf1 = toLOWER(*p1);   /* Folds in the ASCII range are
-                                              just lowercased */
+               f1 = foldbuf1;

            }
            }

-           else if (u1) {
-                to_utf8_fold(p1, foldbuf1, &n1);
-            }
-            else {  /* Not utf8, convert to it first and then get fold */
-                uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
-                to_utf8_fold(natbuf, foldbuf1, &n1);
-            }
-            f1 = foldbuf1;

         }
 
         if (n2 == 0) {    /* Same for s2 */
         }
 
         if (n2 == 0) {    /* Same for s2 */

-           if ((flags & FOLDEQ_UTF8_LOCALE)
-               && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
-           {
-               /* Here, the next char in s2 is < 256.  We've already worked on
-                * s1, and if it isn't also < 256, can't match */
-               if (u1 && (! UTF8_IS_INVARIANT(*p1)
-                   && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
+           if (flags & FOLDEQ_S2_ALREADY_FOLDED) {
+               f2 = (U8 *) p2;
+               n2 = UTF8SKIP(f2);
+           }
+           else {
+               if ((flags & FOLDEQ_UTF8_LOCALE)
+                   && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))

                {
                {

-                   return 0;
-               }
-               if (! u2 || UTF8_IS_INVARIANT(*p2)) {
-                   *foldbuf2 = *p2;
+                   /* Here, the next char in s2 is < 256.  We've already
+                    * worked on s1, and if it isn't also < 256, can't match */
+                   if (u1 && (! UTF8_IS_INVARIANT(*p1)
+                       && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
+                   {
+                       return 0;
+                   }
+                   if (! u2 || UTF8_IS_INVARIANT(*p2)) {
+                       *foldbuf2 = *p2;
+                   }
+                   else {
+                       *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+                   }
+
+                   /* Use another function to handle locale rules.  We've made
+                    * sure that both characters to compare are single bytes */
+                   if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
+                       return 0;
+                   }
+                   n1 = n2 = 0;

                }
                }

-               else {
-                   *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+               else if (isASCII(*p2)) {
+                   if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
+                       return 0;
+                   }
+                   n2 = 1;
+                   *foldbuf2 = toLOWER(*p2);

                }
                }

-
-               /* Use another function to handle locale rules.  We've made
-                * sure that both characters to compare are single bytes */
-               if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
-                   return 0;
+               else if (u2) {
+                   to_utf8_fold(p2, foldbuf2, &n2);

                }
                }

-               n1 = n2 = 0;
-           }
-           else if (isASCII(*p2)) {
-               if (flags && ! isASCII(*p1)) {
-                   return 0;
+               else {
+                   to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2);

                }
                }

-               n2 = 1;
-               *foldbuf2 = toLOWER(*p2);
+               f2 = foldbuf2;

            }
            }

-           else if (u2) {
-                to_utf8_fold(p2, foldbuf2, &n2);
-            }
-            else {
-                uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
-                to_utf8_fold(natbuf, foldbuf2, &n2);
-            }
-            f2 = foldbuf2;

         }
 
        /* Here f1 and f2 point to the beginning of the strings to compare.
         }
 
        /* Here f1 and f2 point to the beginning of the strings to compare.

-        * These strings are the folds of the input characters, stored in utf8.
-        */
+        * These strings are the folds of the next character from each input
+        * string, stored in utf8. */

 
         /* While there is more to look for in both folds, see if they
         * continue to match */
 
         /* While there is more to look for in both folds, see if they
         * continue to match */


@@ -3510,7 +4210,7 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1
             if (fold_length != UTF8SKIP(f2)
                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
                                                        function call for single
             if (fold_length != UTF8SKIP(f2)
                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
                                                        function call for single

-                                                       character */
+                                                       byte */

                 || memNE((char*)f1, (char*)f2, fold_length))
             {
                 return 0; /* mismatch */
                 || memNE((char*)f1, (char*)f2, fold_length))
             {
                 return 0; /* mismatch */