This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix EBCDIC-only bug with /[...]/
[perl5.git] / utf8.c
diff --git a/utf8.c b/utf8.c
index aa13a59..a7baed4 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -39,8 +39,7 @@ static const char unees[] =
 
 /*
 =head1 Unicode Support
-
-This file contains various utility functions for manipulating UTF8-encoded
+These are various utility functions for manipulating UTF8-encoded
 strings.  For the uninitiated, this is a method of representing arbitrary
 Unicode characters as a variable number of bytes, in such a way that
 characters in the ASCII range are unmodified, and a zero byte never appears
@@ -308,47 +307,9 @@ Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
 }
 
 /*
-
-Tests if the first C<len> bytes of string C<s> form a valid UTF-8
-character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a
-valid 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
-the "unrolled" IS_UTF8_CHAR().  E.g. for t/uni/class.t the speed
-difference is a factor of 2 to 3.  For lengths (UTF8SKIP(s)) of four
-or less you should use the IS_UTF8_CHAR(), for lengths of five or more
-you should use the _slow().  In practice this means that the _slow()
-will be used very rarely, since the maximum Unicode code point (as of
-Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes.  Only
-the "Perl extended UTF-8" (e.g, the infamous 'v-strings') will encode into
-five bytes or more.
-
-=cut */
-PERL_STATIC_INLINE STRLEN
-S_is_utf8_char_slow(const U8 *s, const STRLEN len)
-{
-    dTHX;   /* The function called below requires thread context */
-
-    STRLEN actual_len;
-
-    PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
-
-    utf8n_to_uvchr(s, len, &actual_len, UTF8_CHECK_ONLY);
-
-    return (actual_len == (STRLEN) -1) ? 0 : actual_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.
+This is identical to the macro L</isUTF8_CHAR>.
 
 =cut */
 
@@ -356,48 +317,11 @@ 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);
-    }
-
-    if (IS_UTF8_CHAR_FAST(len))
-        return IS_UTF8_CHAR(buf, len) ? len : 0;
-    return is_utf8_char_slow(buf, len);
-}
-
-/*
-=for apidoc is_utf8_char
-
-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 L</is_utf8_char_buf>
-instead.
-
-=cut */
-
-STRLEN
-Perl_is_utf8_char(const U8 *s)
-{
-    PERL_ARGS_ASSERT_IS_UTF8_CHAR;
-
-    /* Assumes we have enough space, which is why this is deprecated */
-    return is_utf8_char_buf(s, s + UTF8SKIP(s));
+    return isUTF8_CHAR(buf, buf_end);
 }
 
-
 /*
 =for apidoc is_utf8_string
 
@@ -421,28 +345,11 @@ Perl_is_utf8_string(const U8 *s, STRLEN len)
     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 
     while (x < send) {
-        /* Inline the easy bits of is_utf8_char() here for speed... */
-        if (UTF8_IS_INVARIANT(*x)) {
-           x++;
-        }
-        else {
-             /* ... and call is_utf8_char() only if really needed. */
-            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))
-                    return FALSE;
-            }
-            else if (! is_utf8_char_slow(x, c)) {
-                return FALSE;
-            }
-            x = next_char_ptr;
-        }
+        STRLEN len = isUTF8_CHAR(x, send);
+        if (UNLIKELY(! len)) {
+            return FALSE;
+        }
+        x += len;
     }
 
     return TRUE;
@@ -476,34 +383,17 @@ Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 {
     const U8* const send = s + (len ? len : strlen((const char *)s));
     const U8* x = s;
-    STRLEN c;
     STRLEN outlen = 0;
 
     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))
-            next_char_ptr = x + 1;
-        else {
-            /* ... and call is_utf8_char() only if really needed. */
-            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 (!c)
-                goto out;
-        }
-         x = next_char_ptr;
-        outlen++;
+        STRLEN len = isUTF8_CHAR(x, send);
+        if (UNLIKELY(! len)) {
+            goto out;
+        }
+        x += len;
+        outlen++;
     }
 
  out:
@@ -599,7 +489,6 @@ warn.
 UV
 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 {
-    dVAR;
     const U8 * const s0 = s;
     U8 overflow_byte = '\0';   /* Save byte in case of overflow */
     U8 * send;
@@ -979,6 +868,7 @@ Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
     UV uv = *s;
 
     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
+    PERL_UNUSED_CONTEXT;
 
     if (retlen) {
         *retlen = expectlen;
@@ -1009,36 +899,6 @@ Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
 }
 
 /*
-=for apidoc utf8_to_uvchr
-
-Returns the native code point of the first character in the string C<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-Some, but not all, UTF-8 malformations are detected, and in fact, some
-malformed input could cause reading beyond the end of the input buffer, which
-is why this function is deprecated.  Use L</utf8_to_uvchr_buf> instead.
-
-If C<s> points to one of the detected malformations, and UTF8 warnings are
-enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
-NULL) to -1.  If those warnings are off, the computed value if well-defined (or
-the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
-is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
-next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
-
-=cut
-*/
-
-UV
-Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
-{
-    PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
-
-    return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
-}
-
-/*
 =for apidoc utf8_to_uvuni_buf
 
 Only in very rare circumstances should code need to be dealing in Unicode
@@ -1073,51 +933,6 @@ Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
                               ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY));
 }
 
-/* DEPRECATED!
- * Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
- * there are no malformations in the input UTF-8 string C<s>.  Surrogates,
- * non-character code points, and non-Unicode code points are allowed */
-
-UV
-Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
-{
-    PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
-
-    return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
-}
-
-/*
-=for apidoc utf8_to_uvuni
-
-Returns the Unicode code point of the first character in the string C<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-Some, but not all, UTF-8 malformations are detected, and in fact, some
-malformed input could cause reading beyond the end of the input buffer, which
-is one reason why this function is deprecated.  The other is that only in
-extremely limited circumstances should the Unicode versus native code point be
-of any interest to you.  See L</utf8_to_uvuni_buf> for alternatives.
-
-If C<s> points to one of the detected malformations, and UTF8 warnings are
-enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
-NULL) to -1.  If those warnings are off, the computed value if well-defined (or
-the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
-is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
-next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
-
-=cut
-*/
-
-UV
-Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
-{
-    PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
-
-    return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
-}
-
 /*
 =for apidoc utf8_length
 
@@ -1131,7 +946,6 @@ up past C<e>, croaks.
 STRLEN
 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
 {
-    dVAR;
     STRLEN len = 0;
 
     PERL_ARGS_ASSERT_UTF8_LENGTH;
@@ -1194,11 +1008,10 @@ on the first byte of character or just after the last byte of a character.
 */
 
 U8 *
-Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
+Perl_utf8_hop(const U8 *s, I32 off)
 {
     PERL_ARGS_ASSERT_UTF8_HOP;
 
-    PERL_UNUSED_CONTEXT;
     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
      * the bitops (especially ~) can create illegal UTF-8.
      * In other words: in Perl UTF-8 is not just for Unicode. */
@@ -1242,8 +1055,6 @@ Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
 
     PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
 
-    PERL_UNUSED_CONTEXT;
-
     while (b < bend && u < uend) {
         U8 c = *u++;
        if (!UTF8_IS_INVARIANT(c)) {
@@ -1308,6 +1119,7 @@ Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
     U8 *d;
 
     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
+    PERL_UNUSED_CONTEXT;
 
     /* ensure valid UTF-8 and chars < 256 before updating string */
     while (s < send) {
@@ -1359,7 +1171,6 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
     I32 count = 0;
 
     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
-
     PERL_UNUSED_CONTEXT;
     if (!*is_utf8)
         return (U8 *)start;
@@ -1541,26 +1352,17 @@ Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
 /* Internal function so we can deprecate the external one, and call
    this one from other deprecated functions in this file */
 
-PERL_STATIC_INLINE bool
-S_is_utf8_idfirst(pTHX_ const U8 *p)
+bool
+Perl__is_utf8_idstart(pTHX_ const U8 *p)
 {
-    dVAR;
+    PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
 
     if (*p == '_')
        return TRUE;
-    /* is_utf8_idstart would be more logical. */
     return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
 }
 
 bool
-Perl_is_uni_idfirst(pTHX_ UV c)
-{
-    U8 tmpbuf[UTF8_MAXBYTES+1];
-    uvchr_to_utf8(tmpbuf, c);
-    return S_is_utf8_idfirst(aTHX_ tmpbuf);
-}
-
-bool
 Perl__is_uni_perl_idcont(pTHX_ UV c)
 {
     U8 tmpbuf[UTF8_MAXBYTES+1];
@@ -1647,8 +1449,6 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_
 UV
 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
@@ -1670,8 +1470,6 @@ Perl_to_uni_upper(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;
 
     if (c < 256) {
@@ -1683,7 +1481,7 @@ Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
 }
 
 STATIC U8
-S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
+S_to_lower_latin1(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
@@ -1697,8 +1495,10 @@ S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
            *lenp = 1;
        }
        else {
-           *p = UTF8_TWO_BYTE_HI(converted);
-           *(p+1) = UTF8_TWO_BYTE_LO(converted);
+            /* Result is known to always be < 256, so can use the EIGHT_BIT
+             * macros */
+           *p = UTF8_EIGHT_BIT_HI(converted);
+           *(p+1) = UTF8_EIGHT_BIT_LO(converted);
            *lenp = 2;
        }
     }
@@ -1708,8 +1508,6 @@ S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
 UV
 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
 {
-    dVAR;
-
     PERL_ARGS_ASSERT_TO_UNI_LOWER;
 
     if (c < 256) {
@@ -1733,6 +1531,7 @@ Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int f
     UV converted;
 
     PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
+    PERL_UNUSED_CONTEXT;
 
     assert (! (flags & FOLD_FLAGS_LOCALE));
 
@@ -1834,8 +1633,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
      * have been checked before this call for mal-formedness enough to assure
      * that. */
 
-    dVAR;
-
     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
 
     /* The API should have included a length for the UTF-8 character in <p>,
@@ -1843,7 +1640,7 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
      * 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))) {
+    if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
         if (ckWARN_d(WARN_UTF8)) {
             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED,WARN_UTF8),
                    "Passing malformed UTF-8 to \"%s\" is deprecated", swashname);
@@ -1871,8 +1668,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
 bool
 Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
 {
-    dVAR;
-
     PERL_ARGS_ASSERT__IS_UTF8_FOO;
 
     assert(classnum < _FIRST_NON_SWASH_CC);
@@ -1884,46 +1679,31 @@ Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
 }
 
 bool
-Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
+Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
 {
-    dVAR;
+    SV* invlist = NULL;
 
-    PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
+    PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
 
-    return S_is_utf8_idfirst(aTHX_ p);
+    if (! PL_utf8_perl_idstart) {
+        invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
+    }
+    return is_utf8_common(p, &PL_utf8_perl_idstart, "", invlist);
 }
 
 bool
-Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
+Perl__is_utf8_xidstart(pTHX_ const U8 *p)
 {
-    dVAR;
-
-    PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
+    PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
 
     if (*p == '_')
        return TRUE;
-    /* is_utf8_idstart would be more logical. */
     return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
 }
 
 bool
-Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
-{
-    dVAR;
-    SV* invlist = NULL;
-
-    PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
-
-    if (! PL_utf8_perl_idstart) {
-        invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
-    }
-    return is_utf8_common(p, &PL_utf8_perl_idstart, "", invlist);
-}
-
-bool
 Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
 {
-    dVAR;
     SV* invlist = NULL;
 
     PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
@@ -1934,23 +1714,18 @@ Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
     return is_utf8_common(p, &PL_utf8_perl_idcont, "", invlist);
 }
 
-
 bool
-Perl_is_utf8_idcont(pTHX_ const U8 *p)
+Perl__is_utf8_idcont(pTHX_ const U8 *p)
 {
-    dVAR;
-
-    PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
+    PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
 
     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
 }
 
 bool
-Perl_is_utf8_xidcont(pTHX_ const U8 *p)
+Perl__is_utf8_xidcont(pTHX_ const U8 *p)
 {
-    dVAR;
-
-    PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
+    PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
 
     return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
 }
@@ -1958,8 +1733,6 @@ Perl_is_utf8_xidcont(pTHX_ const U8 *p)
 bool
 Perl__is_utf8_mark(pTHX_ const U8 *p)
 {
-    dVAR;
-
     PERL_ARGS_ASSERT__IS_UTF8_MARK;
 
     return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
@@ -1996,7 +1769,6 @@ UV
 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
                        SV **swashp, const char *normal, const char *special)
 {
-    dVAR;
     STRLEN len = 0;
     const UV uv1 = valid_utf8_to_uvchr(p, NULL);
 
@@ -2153,8 +1925,6 @@ Instead use L</toUPPER_utf8>.
 UV
 Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
 {
-    dVAR;
-
     UV result;
 
     PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
@@ -2220,8 +1990,6 @@ Instead use L</toTITLE_utf8>.
 UV
 Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
 {
-    dVAR;
-
     UV result;
 
     PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
@@ -2288,8 +2056,6 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags
 {
     UV result;
 
-    dVAR;
-
     PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
 
     if (flags && IN_UTF8_CTYPE_LOCALE) {
@@ -2358,8 +2124,6 @@ Instead use L</toFOLD_utf8>.
 UV
 Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
 {
-    dVAR;
-
     UV result;
 
     PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
@@ -2509,6 +2273,14 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits
 SV*
 Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
 {
+
+    /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
+     * use the following define */
+
+#define CORE_SWASH_INIT_RETURN(x)   \
+    PL_curpm= old_PL_curpm;         \
+    return x
+
     /* Initialize and return a swash, creating it if necessary.  It does this
      * by calling utf8_heavy.pl in the general case.  The returned value may be
      * the swash's inversion list instead if the input parameters allow it.
@@ -2553,7 +2325,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
      *
      * <invlist> is only valid for binary properties */
 
-    dVAR;
+    PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
+
     SV* retval = &PL_sv_undef;
     HV* swash_hv = NULL;
     const int invlist_swash_boundary =
@@ -2565,6 +2338,10 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
     assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
     assert(! invlist || minbits == 1);
 
+    PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
+                       that triggered the swash init and the swash init perl logic itself.
+                       See perl #122747 */
+
     /* 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, "")) {
@@ -2580,7 +2357,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
        PUSHSTACKi(PERLSI_MAGIC);
        ENTER;
        SAVEHINTS();
-       save_re_context();
        /* We might get here via a subroutine signature which uses a utf8
         * parameter name, at which point PL_subname will have been set
         * but not yet used. */
@@ -2592,13 +2368,9 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
            ENTER;
            if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
            GvSV(PL_errgv) = NULL;
+#ifndef NO_TAINT_SUPPORT
            /* 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.  */
-#ifndef NO_TAINT_SUPPORT
            SAVEBOOL(TAINT_get);
            TAINT_NOT;
 #endif
@@ -2653,12 +2425,12 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
 
                /* If caller wants to handle missing properties, let them */
                if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
-                   return NULL;
+                    CORE_SWASH_INIT_RETURN(NULL);
                }
                Perl_croak(aTHX_
                           "Can't find Unicode property definition \"%"SVf"\"",
                           SVfARG(retval));
-           Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+                NOT_REACHED; /* NOTREACHED */
        }
     } /* End of calling the module to find the swash */
 
@@ -2755,7 +2527,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
         }
     }
 
-    return retval;
+    CORE_SWASH_INIT_RETURN(retval);
+#undef CORE_SWASH_INIT_RETURN
 }
 
 
@@ -2804,7 +2577,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
 UV
 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
 {
-    dVAR;
     HV *const hv = MUTABLE_HV(SvRV(swash));
     U32 klen;
     U32 off;
@@ -3610,15 +3382,17 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
            for (i = 0; i <= av_tindex(list); i++) {
                SV** entryp = av_fetch(list, i, FALSE);
                SV* entry;
+               UV uv;
                if (entryp == NULL) {
                    Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
                }
                entry = *entryp;
-               /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, SvUV(entry)));*/
-               if (SvUV(entry) == val) {
+               uv = SvUV(entry);
+               /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, uv));*/
+               if (uv == val) {
                    found_key = TRUE;
                }
-               if (SvUV(entry) == inverse) {
+               if (uv == inverse) {
                    found_inverse = TRUE;
                }
 
@@ -3719,22 +3493,24 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
     lend = l + lcur;
 
     if (*l == 'V') {    /*  Inversion list format */
-        char *after_strtol = (char *) lend;
+        const char *after_atou = (char *) lend;
         UV element0;
         UV* other_elements_ptr;
 
         /* The first number is a count of the rest */
         l++;
-        elements = Strtoul((char *)l, &after_strtol, 10);
+        elements = grok_atou((const char *)l, &after_atou);
         if (elements == 0) {
             invlist = _new_invlist(0);
         }
         else {
-            l = (U8 *) after_strtol;
+            while (isSPACE(*l)) l++;
+            l = (U8 *) after_atou;
 
             /* Get the 0th element, which is needed to setup the inversion list */
-            element0 = (UV) Strtoul((char *)l, &after_strtol, 10);
-            l = (U8 *) after_strtol;
+            while (isSPACE(*l)) l++;
+            element0 = (UV) grok_atou((const char *)l, &after_atou);
+            l = (U8 *) after_atou;
             invlist = _setup_canned_invlist(elements, element0, &other_elements_ptr);
             elements--;
 
@@ -3743,8 +3519,9 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
                 if (l > lend) {
                     Perl_croak(aTHX_ "panic: Expecting %"UVuf" more elements than available", elements);
                 }
-                *other_elements_ptr++ = (UV) Strtoul((char *)l, &after_strtol, 10);
-                l = (U8 *) after_strtol;
+                while (isSPACE(*l)) l++;
+                *other_elements_ptr++ = (UV) grok_atou((const char *)l, &after_atou);
+                l = (U8 *) after_atou;
             }
         }
     }
@@ -4108,7 +3885,6 @@ L<http://www.unicode.org/unicode/reports/tr21/> (Case Mappings).
 I32
 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags)
 {
-    dVAR;
     const U8 *p1  = (const U8*)s1; /* Point to current char */
     const U8 *p2  = (const U8*)s2;
     const U8 *g1 = NULL;       /* goal for s1 */
@@ -4335,7 +4111,7 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const c
     return 1;
 }
 
-/* XXX The next four functions should likely be moved to mathoms.c once all
+/* XXX The next two functions should likely be moved to mathoms.c once all
  * occurrences of them are removed from the core; some cpan-upstream modules
  * still use them */