X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/537124e4032962cd7c5f3bd4f0ee7995cd79e8ec..c6871b765d934773fb82823602c1e03e073c38ac:/utf8.c diff --git a/utf8.c b/utf8.c index ba1304e..2c2ef48 100644 --- a/utf8.c +++ b/utf8.c @@ -31,24 +31,19 @@ #include "EXTERN.h" #define PERL_IN_UTF8_C #include "perl.h" -#include "inline_invlist.c" - -#ifndef EBCDIC -/* Separate prototypes needed because in ASCII systems these are - * usually macros but they still are compiled as code, too. */ -PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags); -PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen); -PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv); -#endif +#include "invlist_inline.h" static const char unees[] = "Malformed UTF-8 character (unexpected end of string)"; +static const char cp_above_legal_max[] = + "Use of code point 0x%"UVXf" is deprecated; the permissible max is 0x%"UVXf""; + +#define MAX_NON_DEPRECATED_CP ((UV) (IV_MAX)) /* =head1 Unicode Support - -This file contains various utility functions for manipulating UTF8-encoded -strings. For the uninitiated, this is a method of representing arbitrary +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 within non-zero characters. @@ -57,14 +52,19 @@ within non-zero characters. */ /* -=for apidoc is_ascii_string +=for apidoc is_invariant_string -Returns true if the first C bytes of the string C are the same whether -or not the string is encoded in UTF-8 (or UTF-EBCDIC on EBCDIC machines). That -is, if they are invariant. On ASCII-ish machines, only ASCII characters -fit this definition, hence the function's name. +Returns true iff the first C bytes of the string C are the same +regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on +EBCDIC machines). That is, if they are UTF-8 invariant. On ASCII-ish +machines, all the ASCII characters and only the ASCII characters fit this +definition. On EBCDIC machines, the ASCII-range characters are invariant, but +so also are the C1 controls and C<\c?> (which isn't in the ASCII range on +EBCDIC). -If C is 0, it will be calculated using C. +If C is 0, it will be calculated using C, (which means if you +use this option, that C can't have embedded C characters and has to +have a terminating C byte). See also L(), L(), and L(). @@ -72,12 +72,12 @@ See also L(), L(), and L to the end -of the string C; C should have at least C free -bytes available. The return value is the pointer to the byte after the -end of the new character. In other words, - - d = uvuni_to_utf8_flags(d, uv, flags); +=for apidoc uvoffuni_to_utf8_flags -or, in most cases, - - d = uvuni_to_utf8(d, uv); +THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES. +Instead, B or +L>. -(which is equivalent to) +This function is like them, but the input is a strict Unicode +(as opposed to native) code point. Only in very rare circumstances should code +not be using the native code point. - d = uvuni_to_utf8_flags(d, uv, 0); +For details, see the description for L. -This is the recommended Unicode-aware way of saying +=cut +*/ - *(d++) = uv; +#define HANDLE_UNICODE_SURROGATE(uv, flags) \ + STMT_START { \ + if (flags & UNICODE_WARN_SURROGATE) { \ + Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE), \ + "UTF-16 surrogate U+%04"UVXf, uv); \ + } \ + if (flags & UNICODE_DISALLOW_SURROGATE) { \ + return NULL; \ + } \ + } STMT_END; + +#define HANDLE_UNICODE_NONCHAR(uv, flags) \ + STMT_START { \ + if (flags & UNICODE_WARN_NONCHAR) { \ + Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR), \ + "Unicode non-character U+%04"UVXf" is not " \ + "recommended for open interchange", uv); \ + } \ + if (flags & UNICODE_DISALLOW_NONCHAR) { \ + return NULL; \ + } \ + } STMT_END; + +/* Use shorter names internally in this file */ +#define SHIFT UTF_ACCUMULATION_SHIFT +#undef MARK +#define MARK UTF_CONTINUATION_MARK +#define MASK UTF_CONTINUATION_MASK -where uv is a code point expressed in Latin-1 or above, not the platform's -native character set. B -or L>. +U8 * +Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) +{ + PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS; -This function will convert to UTF-8 (and not warn) even code points that aren't -legal Unicode or are problematic, unless C contains one or more of the -following flags: + if (OFFUNI_IS_INVARIANT(uv)) { + *d++ = LATIN1_TO_NATIVE(uv); + return d; + } -If C is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set, -the function will raise a warning, provided UTF8 warnings are enabled. If instead -UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL. -If both flags are set, the function will both warn and return NULL. + if (uv <= MAX_UTF8_TWO_BYTE) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> SHIFT) | UTF_START_MARK(2)); + *d++ = I8_TO_NATIVE_UTF8(( uv & MASK) | MARK); + return d; + } + + /* Not 2-byte; test for and handle 3-byte result. In the test immediately + * below, the 16 is for start bytes E0-EF (which are all the possible ones + * for 3 byte characters). The 2 is for 2 continuation bytes; these each + * contribute SHIFT bits. This yields 0x4000 on EBCDIC platforms, 0x1_0000 + * on ASCII; so 3 bytes covers the range 0x400-0x3FFF on EBCDIC; + * 0x800-0xFFFF on ASCII */ + if (uv < (16 * (1U << (2 * SHIFT)))) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * SHIFT)) | UTF_START_MARK(3)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); + +#ifndef EBCDIC /* These problematic code points are 4 bytes on EBCDIC, so + aren't tested here */ + /* The most likely code points in this range are below the surrogates. + * Do an extra test to quickly exclude those. */ + if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST)) { + if (UNLIKELY( UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv) + || UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) + { + HANDLE_UNICODE_NONCHAR(uv, flags); + } + else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) { + HANDLE_UNICODE_SURROGATE(uv, flags); + } + } +#endif + return d; + } -The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags correspondingly -affect how the function handles a Unicode non-character. And likewise, the -UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, affect the handling of -code points that are -above the Unicode maximum of 0x10FFFF. Code points above 0x7FFF_FFFF (which are -even less portable) can be warned and/or disallowed even if other above-Unicode -code points are accepted by the UNICODE_WARN_FE_FF and UNICODE_DISALLOW_FE_FF -flags. + /* Not 3-byte; that means the code point is at least 0x1_0000 on ASCII + * platforms, and 0x4000 on EBCDIC. There are problematic cases that can + * happen starting with 4-byte characters on ASCII platforms. We unify the + * code for these with EBCDIC, even though some of them require 5-bytes on + * those, because khw believes the code saving is worth the very slight + * performance hit on these high EBCDIC code points. */ -And finally, the flag UNICODE_WARN_ILLEGAL_INTERCHANGE selects all four of the -above WARN flags; and UNICODE_DISALLOW_ILLEGAL_INTERCHANGE selects all four -DISALLOW flags. + if (UNLIKELY(UNICODE_IS_SUPER(uv))) { + if ( UNLIKELY(uv > MAX_NON_DEPRECATED_CP) + && ckWARN_d(WARN_DEPRECATED)) + { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + cp_above_legal_max, uv, MAX_NON_DEPRECATED_CP); + } + if ( (flags & UNICODE_WARN_SUPER) + || ( UNICODE_IS_ABOVE_31_BIT(uv) + && (flags & UNICODE_WARN_ABOVE_31_BIT))) + { + Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE), + /* Choose the more dire applicable warning */ + (UNICODE_IS_ABOVE_31_BIT(uv)) + ? "Code point 0x%"UVXf" is not Unicode, and not portable" + : "Code point 0x%"UVXf" is not Unicode, may not be portable", + uv); + } + if (flags & UNICODE_DISALLOW_SUPER + || ( UNICODE_IS_ABOVE_31_BIT(uv) + && (flags & UNICODE_DISALLOW_ABOVE_31_BIT))) + { + return NULL; + } + } + else if (UNLIKELY(UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) { + HANDLE_UNICODE_NONCHAR(uv, flags); + } + + /* Test for and handle 4-byte result. In the test immediately below, the + * 8 is for start bytes F0-F7 (which are all the possible ones for 4 byte + * characters). The 3 is for 3 continuation bytes; these each contribute + * SHIFT bits. This yields 0x4_0000 on EBCDIC platforms, 0x20_0000 on + * ASCII, so 4 bytes covers the range 0x4000-0x3_FFFF on EBCDIC; + * 0x1_0000-0x1F_FFFF on ASCII */ + if (uv < (8 * (1U << (3 * SHIFT)))) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * SHIFT)) | UTF_START_MARK(4)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); + +#ifdef EBCDIC /* These were handled on ASCII platforms in the code for 3-byte + characters. The end-plane non-characters for EBCDIC were + handled just above */ + if (UNLIKELY(UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv))) { + HANDLE_UNICODE_NONCHAR(uv, flags); + } + else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) { + HANDLE_UNICODE_SURROGATE(uv, flags); + } +#endif -=cut -*/ + return d; + } -U8 * -Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) -{ - PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS; + /* Not 4-byte; that means the code point is at least 0x20_0000 on ASCII + * platforms, and 0x4000 on EBCDIC. At this point we switch to a loop + * format. The unrolled version above turns out to not save all that much + * time, and at these high code points (well above the legal Unicode range + * on ASCII platforms, and well above anything in common use in EBCDIC), + * khw believes that less code outweighs slight performance gains. */ - /* The first problematic code point is the first surrogate */ - if (uv >= UNICODE_SURROGATE_FIRST - && ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { - if (UNICODE_IS_SURROGATE(uv)) { - if (flags & UNICODE_WARN_SURROGATE) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE), - "UTF-16 surrogate U+%04"UVXf, uv); - } - if (flags & UNICODE_DISALLOW_SURROGATE) { - return NULL; - } - } - else if (UNICODE_IS_SUPER(uv)) { - if (flags & UNICODE_WARN_SUPER - || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_WARN_FE_FF))) - { - Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE), - "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv); - } - if (flags & UNICODE_DISALLOW_SUPER - || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF))) - { - return NULL; - } - } - else if (UNICODE_IS_NONCHAR(uv)) { - if (flags & UNICODE_WARN_NONCHAR) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR), - "Unicode non-character U+%04"UVXf" is illegal for open interchange", - uv); - } - if (flags & UNICODE_DISALLOW_NONCHAR) { - return NULL; - } - } - } - if (UNI_IS_INVARIANT(uv)) { - *d++ = (U8)UTF_TO_NATIVE(uv); - return d; - } -#if defined(EBCDIC) - else { - STRLEN len = UNISKIP(uv); + STRLEN len = OFFUNISKIP(uv); U8 *p = d+len-1; while (p > d) { - *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK); + *p-- = I8_TO_NATIVE_UTF8((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK); uv >>= UTF_ACCUMULATION_SHIFT; } - *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); + *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); return d+len; } -#else /* Non loop style */ - if (uv < 0x800) { - *d++ = (U8)(( uv >> 6) | 0xc0); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } - if (uv < 0x10000) { - *d++ = (U8)(( uv >> 12) | 0xe0); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } - if (uv < 0x200000) { - *d++ = (U8)(( uv >> 18) | 0xf0); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } - if (uv < 0x4000000) { - *d++ = (U8)(( uv >> 24) | 0xf8); - *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } - if (uv < 0x80000000) { - *d++ = (U8)(( uv >> 30) | 0xfc); - *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } -#ifdef HAS_QUAD - if (uv < UTF8_QUAD_MAX) -#endif - { - *d++ = 0xfe; /* Can't match U+FEFF! */ - *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } -#ifdef HAS_QUAD - { - *d++ = 0xff; /* Can't match U+FFFE! */ - *d++ = 0x80; /* 6 Reserved bits */ - *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */ - *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - return d; - } -#endif -#endif /* Non loop style */ } /* +=for apidoc uvchr_to_utf8 -Tests if the first C bytes of string C form a valid UTF-8 -character. Note that an INVARIANT (i.e. ASCII) 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; +Adds the UTF-8 representation of the native code point C to the end +of the string C; C should have at least C (up to +C) free bytes available. The return value is the pointer to +the byte after the end of the new character. In other words, - PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW; + d = uvchr_to_utf8(d, uv); - utf8n_to_uvuni(s, len, &actual_len, UTF8_CHECK_ONLY); +is the recommended wide native character-aware way of saying - return (actual_len == (STRLEN) -1) ? 0 : actual_len; -} + *(d++) = uv; -/* -=for apidoc is_utf8_char_buf +This function accepts any UV as input, but very high code points (above +C on the platform) will raise a deprecation warning. This is +typically 0x7FFF_FFFF in a 32-bit word. -Returns the number of bytes that comprise the first UTF-8 encoded character in -buffer C. C should point to one position beyond the end of the -buffer. 0 is returned if C does not point to a complete, valid UTF-8 -encoded character. +It is possible to forbid or warn on non-Unicode code points, or those that may +be problematic by using L. -Note that an INVARIANT character (i.e. ASCII on non-EBCDIC -machines) is a valid UTF-8 character. +=cut +*/ -=cut */ +/* This is also a macro */ +PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv); -STRLEN -Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end) +U8 * +Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) { + return uvchr_to_utf8(d, uv); +} - STRLEN len; +/* +=for apidoc uvchr_to_utf8_flags - PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF; +Adds the UTF-8 representation of the native code point C to the end +of the string C; C should have at least C (up to +C) free bytes available. The return value is the pointer to +the byte after the end of the new character. In other words, - if (buf_end <= buf) { - return 0; - } + d = uvchr_to_utf8_flags(d, uv, flags); - len = buf_end - buf; - if (len > UTF8SKIP(buf)) { - len = UTF8SKIP(buf); - } +or, in most cases, -#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); -} + d = uvchr_to_utf8_flags(d, uv, 0); -/* -=for apidoc is_utf8_char +This is the Unicode-aware way of saying -DEPRECATED! + *(d++) = uv; -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. +If C is 0, this function accepts any UV as input, but very high code +points (above C for the platform) will raise a deprecation warning. +This is typically 0x7FFF_FFFF in a 32-bit word. + +Specifying C can further restrict what is allowed and not warned on, as +follows: + +If C is a Unicode surrogate code point and C is set, +the function will raise a warning, provided UTF8 warnings are enabled. If +instead C is set, the function will fail and return +NULL. If both flags are set, the function will both warn and return NULL. + +Similarly, the C and C flags +affect how the function handles a Unicode non-character. + +And likewise, the C and C flags +affect the handling of code points that are above the Unicode maximum of +0x10FFFF. Languages other than Perl may not be able to accept files that +contain these. + +The flag C selects all three of +the above WARN flags; and C selects all +three DISALLOW flags. + +Code points above 0x7FFF_FFFF (2**31 - 1) were never specified in any standard, +so using them is more problematic than other above-Unicode code points. Perl +invented an extension to UTF-8 to represent the ones above 2**36-1, so it is +likely that non-Perl languages will not be able to read files that contain +these that written by the perl interpreter; nor would Perl understand files +written by something that uses a different extension. For these reasons, there +is a separate set of flags that can warn and/or disallow these extremely high +code points, even if other above-Unicode ones are accepted. These are the +C and C flags. These +are entirely independent from the deprecation warning for code points above +C. On 32-bit machines, it will eventually be forbidden to have any +code point that needs more than 31 bits to represent. When that happens, +effectively the C flag will always be set on +32-bit machines. (Of course C will treat all +above-Unicode code points, including these, as malformations; and +C warns on these.) + +On EBCDIC platforms starting in Perl v5.24, the Perl extension for representing +extremely high code points kicks in at 0x3FFF_FFFF (2**30 -1), which is lower +than on ASCII. Prior to that, code points 2**31 and higher were simply +unrepresentable, and a different, incompatible method was used to represent +code points between 2**30 and 2**31 - 1. The flags C +and C have the same function as on ASCII +platforms, warning and disallowing 2**31 and higher. -This function is deprecated due to the possibility that malformed input could -cause reading beyond the end of the input buffer. Use L -instead. +=cut +*/ -=cut */ +/* This is also a macro */ +PERL_CALLCONV U8* Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags); -STRLEN -Perl_is_utf8_char(const U8 *s) +U8 * +Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) { - 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 uvchr_to_utf8_flags(d, uv, flags); } - /* =for apidoc is_utf8_string Returns true if the first C bytes of string C form a valid UTF-8 string, false otherwise. If C is 0, it will be calculated -using C (which means if you use this option, that C has to have a -terminating NUL byte). Note that all characters being ASCII constitute 'a -valid UTF-8 string'. +using C (which means if you use this option, that C can't have +embedded C characters and has to have a terminating C byte). Note +that all characters being ASCII constitute 'a valid UTF-8 string'. -See also L(), L(), and L(). +See also L(), L(), and L(). =cut */ @@ -384,28 +394,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; @@ -439,34 +432,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: @@ -480,10 +456,13 @@ Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) /* -=for apidoc utf8n_to_uvuni +=for apidoc utf8n_to_uvchr + +THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES. +Most code should use L() rather than call this directly. Bottom level UTF-8 decode routine. -Returns the code point value of the first character in the string C, +Returns the native code point value of the first character in the string C, which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than C bytes; C<*retlen> (if C isn't NULL) will be set to the length, in bytes, of that character. @@ -505,62 +484,74 @@ overlong sequences, the computed code point is returned; for all other allowed malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no determinable reasonable value. -The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other +The C flag overrides the behavior when a non-allowed (by other flags) malformation is found. If this flag is set, the routine assumes that the caller will raise a warning, and this function will silently just set C to C<-1> (cast to C) and return zero. -Note that this API requires disambiguation between successful decoding a NUL -character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as +Note that this API requires disambiguation between successful decoding a C +character, and an error return (unless the C flag is set), as in both cases, 0 is returned. To disambiguate, upon a zero return, see if the -first byte of C is 0 as well. If so, the input was a NUL; if not, the input -had an error. +first byte of C is 0 as well. If so, the input was a C; if not, the +input had an error. Certain code points are considered problematic. These are Unicode surrogates, Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF. By default these are considered regular code points, but certain situations warrant special handling for them. If C 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 -maximum) can be set to disallow these categories individually. - -The flags UTF8_WARN_ILLEGAL_INTERCHANGE, UTF8_WARN_SURROGATE, -UTF8_WARN_NONCHAR, and UTF8_WARN_SUPER will cause warning messages to be raised -for their respective categories, but otherwise the code points are considered -valid (not malformations). To get a category to both be treated as a -malformation and raise a warning, specify both the WARN and DISALLOW flags. +C, all three classes are treated as +malformations and handled as such. The flags C, +C, and C (meaning above the legal +Unicode maximum) can be set to disallow these categories individually. + +The flags C, C, +C, and C will cause warning messages to be +raised for their respective categories, but otherwise the code points are +considered valid (not malformations). To get a category to both be treated as +a malformation and raise a warning, specify both the WARN and DISALLOW flags. (But note that warnings are not raised if lexically disabled nor if -UTF8_CHECK_ONLY is also specified.) - -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: they requre at least 32 bits to represent them on ASCII platforms, are -not representable at all on EBCDIC platforms, and the original UTF-8 -specification never went above this number (the current 0x10FFFF limit was -imposed later). (The smaller ones, those that fit into 32 bits, are -representable by a UV on ASCII platforms, but not by an IV, which means that -the number of operations that can be performed on them is quite restricted.) -The UTF-8 encoding 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, as malformations.) Similarly, UTF8_WARN_FE_FF acts just like -the other WARN flags, but applies just to these code points. +C is also specified.) + +It is now deprecated to have very high code points (above C on the +platforms) and this function will raise a deprecation warning for these (unless +such warnings are turned off). This value, is typically 0x7FFF_FFFF (2**31 -1) +in a 32-bit word. + +Code points above 0x7FFF_FFFF (2**31 - 1) were never specified in any standard, +so using them is more problematic than other above-Unicode code points. Perl +invented an extension to UTF-8 to represent the ones above 2**36-1, so it is +likely that non-Perl languages will not be able to read files that contain +these that written by the perl interpreter; nor would Perl understand files +written by something that uses a different extension. For these reasons, there +is a separate set of flags that can warn and/or disallow these extremely high +code points, even if other above-Unicode ones are accepted. These are the +C and C flags. These +are entirely independent from the deprecation warning for code points above +C. On 32-bit machines, it will eventually be forbidden to have any +code point that needs more than 31 bits to represent. When that happens, +effectively the C flag will always be set on +32-bit machines. (Of course C will treat all +above-Unicode code points, including these, as malformations; and +C warns on these.) + +On EBCDIC platforms starting in Perl v5.24, the Perl extension for representing +extremely high code points kicks in at 0x3FFF_FFFF (2**30 -1), which is lower +than on ASCII. Prior to that, code points 2**31 and higher were simply +unrepresentable, and a different, incompatible method was used to represent +code points between 2**30 and 2**31 - 1. The flags C +and C have the same function as on ASCII +platforms, warning and disallowing 2**31 and higher. All other code points corresponding to Unicode characters, including private use and those yet to be assigned, are never considered malformed and never warn. -Most code should use L() rather than call this directly. - =cut */ UV -Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) +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; @@ -576,7 +567,7 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) const char* const malformed_text = "Malformed UTF-8 character"; - PERL_ARGS_ASSERT_UTF8N_TO_UVUNI; + PERL_ARGS_ASSERT_UTF8N_TO_UVCHR; /* The order of malformation tests here is important. We should consume as * few bytes as possible in order to not skip any valid character. This is @@ -593,7 +584,7 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) * We also should not consume too few bytes, otherwise someone could inject * things. For example, an input could be deliberately designed to * overflow, and if this code bailed out immediately upon discovering that, - * returning to the caller *retlen pointing to the very next byte (one + * returning to the caller C<*retlen> pointing to the very next byte (one * which is actually part of of the overflowing sequence), that could look * legitimate to the caller, which could discard the initial partial * sequence and process the rest, inappropriately */ @@ -625,7 +616,7 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) /* An invariant is trivially well-formed */ if (UTF8_IS_INVARIANT(uv)) { - return (UV) (NATIVE_TO_UTF(*s)); + return uv; } /* A continuation character can't start a valid sequence */ @@ -644,13 +635,13 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) goto malformed; } -#ifdef EBCDIC - uv = NATIVE_TO_UTF(uv); -#endif - /* Here is not a continuation byte, nor an invariant. The only thing left * is a start byte (possibly for an overlong) */ +#ifdef EBCDIC + uv = NATIVE_UTF8_TO_I8(uv); +#endif + /* Remove the leading bits that indicate the number of bytes in the * character's whole UTF-8 sequence, leaving just the bits that are part of * the value */ @@ -663,7 +654,6 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) for (s = s0 + 1; s < send; s++) { if (LIKELY(UTF8_IS_CONTINUATION(*s))) { -#ifndef EBCDIC /* Can't overflow in EBCDIC */ if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) { /* The original implementors viewed this malformation as more @@ -675,7 +665,6 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) overflowed = TRUE; overflow_byte = *s; /* Save for warning message's use */ } -#endif uv = UTF8_ACCUMULATE(uv, *s); } else { @@ -742,39 +731,13 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) } } -#ifndef EBCDIC /* EBCDIC allows FE, FF, can't overflow */ - if ((*s0 & 0xFE) == 0xFE /* matches both FE, FF */ - && (flags & (UTF8_WARN_FE_FF|UTF8_DISALLOW_FE_FF))) - { - /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary - * generation of the sv, since no warnings are raised under CHECK */ - if ((flags & (UTF8_WARN_FE_FF|UTF8_CHECK_ONLY)) == UTF8_WARN_FE_FF - && ckWARN_d(WARN_UTF8)) - { - /* This message is deliberately not of the same syntax as the other - * messages for malformations, for backwards compatibility in the - * unlikely event that code is relying on its precise earlier text - */ - sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s Code point beginning with byte 0x%02X is not Unicode, and not portable", malformed_text, *s0)); - pack_warn = packWARN(WARN_UTF8); - } - if (flags & UTF8_DISALLOW_FE_FF) { - goto malformed; - } - } if (UNLIKELY(overflowed)) { - - /* If the first byte is FF, it will overflow a 32-bit word. If the - * first byte is FE, it will overflow a signed 32-bit word. The - * above preserves backward compatibility, since its message was used - * in earlier versions of this code in preference to overflow */ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0)); goto malformed; } -#endif if (do_overlong_test - && expectlen > (STRLEN)UNISKIP(uv) + && expectlen > (STRLEN) OFFUNISKIP(uv) && ! (flags & UTF8_ALLOW_LONG)) { /* The overlong malformation has lower precedence than the others. @@ -782,23 +745,34 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) * value, instead of the replacement character. This is because this * value is actually well-defined. */ if (! (flags & UTF8_CHECK_ONLY)) { - sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), *s0)); + sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", OFFUNISKIP(uv), *s0)); } goto malformed; } - /* Here, the input is considered to be well-formed , but could be a + /* Here, the input is considered to be well-formed, but it still could be a * problematic code point that is not allowed by the input parameters. */ if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */ - && (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE - |UTF8_WARN_ILLEGAL_INTERCHANGE))) + && ((flags & ( UTF8_DISALLOW_NONCHAR + |UTF8_DISALLOW_SURROGATE + |UTF8_DISALLOW_SUPER + |UTF8_DISALLOW_ABOVE_31_BIT + |UTF8_WARN_NONCHAR + |UTF8_WARN_SURROGATE + |UTF8_WARN_SUPER + |UTF8_WARN_ABOVE_31_BIT)) + || ( UNLIKELY(uv > MAX_NON_DEPRECATED_CP) + && ckWARN_d(WARN_DEPRECATED)))) { if (UNICODE_IS_SURROGATE(uv)) { + + /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary + * generation of the sv, since no warnings are raised under CHECK */ if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE - && ckWARN2_d(WARN_UTF8, WARN_SURROGATE)) + && ckWARN_d(WARN_SURROGATE)) { sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE); + pack_warn = packWARN(WARN_SURROGATE); } if (flags & UTF8_DISALLOW_SURROGATE) { goto disallowed; @@ -806,21 +780,79 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) } else if ((uv > PERL_UNICODE_MAX)) { if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER - && ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE)) + && ckWARN_d(WARN_NON_UNICODE)) { - sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_NON_UNICODE); + sv = sv_2mortal(Perl_newSVpvf(aTHX_ + "Code point 0x%04"UVXf" is not Unicode, may not be portable", + uv)); + pack_warn = packWARN(WARN_NON_UNICODE); } + + /* The maximum code point ever specified by a standard was + * 2**31 - 1. Anything larger than that is a Perl extension that + * very well may not be understood by other applications (including + * earlier perl versions on EBCDIC platforms). On ASCII platforms, + * these code points are indicated by the first UTF-8 byte being + * 0xFE or 0xFF. We test for these after the regular SUPER ones, + * and before possibly bailing out, so that the slightly more dire + * warning will override the regular one. */ + if ( +#ifndef EBCDIC + (*s0 & 0xFE) == 0xFE /* matches both FE, FF */ +#else + /* The I8 for 2**31 (U+80000000) is + * \xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA2\xA0\xA0\xA0\xA0\xA0\xA0 + * and it turns out that on all EBCDIC pages recognized that + * the UTF-EBCDIC for that code point is + * \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41 + * For the next lower code point, the 1047 UTF-EBCDIC is + * \xFE\x41\x41\x41\x41\x41\x41\x42\x73\x73\x73\x73\x73\x73 + * The other code pages differ only in the bytes following + * \x42. Thus the following works (the minimum continuation + * byte is \x41). */ + *s0 == 0xFE && send - s0 > 7 && ( s0[1] > 0x41 + || s0[2] > 0x41 + || s0[3] > 0x41 + || s0[4] > 0x41 + || s0[5] > 0x41 + || s0[6] > 0x41 + || s0[7] > 0x42) +#endif + && (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_WARN_SUPER + |UTF8_DISALLOW_ABOVE_31_BIT))) + { + if ( ! (flags & UTF8_CHECK_ONLY) + && (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_WARN_SUPER)) + && ckWARN_d(WARN_UTF8)) + { + sv = sv_2mortal(Perl_newSVpvf(aTHX_ + "Code point 0x%"UVXf" is not Unicode, and not portable", + uv)); + pack_warn = packWARN(WARN_UTF8); + } + if (flags & UTF8_DISALLOW_ABOVE_31_BIT) { + goto disallowed; + } + } + if (flags & UTF8_DISALLOW_SUPER) { goto disallowed; } + + /* The deprecated warning overrides any non-deprecated one */ + if (UNLIKELY(uv > MAX_NON_DEPRECATED_CP) && ckWARN_d(WARN_DEPRECATED)) + { + sv = sv_2mortal(Perl_newSVpvf(aTHX_ cp_above_legal_max, + uv, MAX_NON_DEPRECATED_CP)); + pack_warn = packWARN(WARN_DEPRECATED); + } } else if (UNICODE_IS_NONCHAR(uv)) { if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR - && ckWARN2_d(WARN_UTF8, WARN_NONCHAR)) + && ckWARN_d(WARN_NONCHAR)) { - sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_NONCHAR); + sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv)); + pack_warn = packWARN(WARN_NONCHAR); } if (flags & UTF8_DISALLOW_NONCHAR) { goto disallowed; @@ -828,7 +860,9 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) } if (sv) { - outlier_ret = uv; + outlier_ret = uv; /* Note we don't bother to convert to native, + as all the outlier code points are the same + in both ASCII and EBCDIC */ goto do_warn; } @@ -836,7 +870,7 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) * to return it */ } - return uv; + return UNI_TO_NATIVE(uv); /* There are three cases which get to beyond this point. In all 3 cases: * if not null points to a string to print as a warning. @@ -864,13 +898,13 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) * is the label . */ -malformed: + malformed: if (sv && ckWARN_d(WARN_UTF8)) { pack_warn = packWARN(WARN_UTF8); } -disallowed: + disallowed: if (flags & UTF8_CHECK_ONLY) { if (retlen) @@ -878,7 +912,7 @@ disallowed: return 0; } -do_warn: + do_warn: if (pack_warn) { /* was initialized to 0, and changed only if warnings are to be raised. */ @@ -906,13 +940,16 @@ C<*retlen> will be set to the length, in bytes, of that character. If C does not point to a well-formed UTF-8 character and UTF8 warnings are enabled, zero is returned and C<*retlen> is set (if C isn't -NULL) to -1. If those warnings are off, the computed value, if well-defined +C) 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 isn't NULL) so that (S + C<*retlen>>) is +C<*retlen> is set (if C isn't C) so that (S + C<*retlen>>) is the next possible position in C that could begin a non-malformed character. -See L for details on when the REPLACEMENT CHARACTER is +See L for details on when the REPLACEMENT CHARACTER is returned. +Code points above the platform's C will raise a deprecation warning, +unless those are turned off. + =cut */ @@ -920,8 +957,6 @@ returned. UV Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) { - PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF; - assert(s < send); return utf8n_to_uvchr(s, send - s, retlen, @@ -930,99 +965,20 @@ Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) /* Like L(), but should only be called when it is known that * there are no malformations in the input UTF-8 string C. surrogates, - * non-character code points, and non-Unicode code points are allowed. A macro - * in utf8.h is used to normally avoid this function wrapper */ + * non-character code points, and non-Unicode code points are allowed. */ UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) { - const UV uv = valid_utf8_to_uvuni(s, retlen); - - PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR; - - return UNI_TO_NATIVE(uv); -} - -/* -=for apidoc utf8_to_uvchr - -DEPRECATED! - -Returns the native code point of the first character in the string C -which is assumed to be in UTF-8 encoding; C 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 instead. - -If C points to one of the detected malformations, and UTF8 warnings are -enabled, zero is returned and C<*retlen> is set (if C 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 isn't NULL) so that (S + C<*retlen>>) is the -next possible position in C that could begin a non-malformed character. -See L 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 - -Returns the Unicode code point of the first character in the string C which -is assumed to be in UTF-8 encoding; C points to 1 beyond the end of C. -C will be set to the length, in bytes, of that character. - -This function should only be used when the returned UV is considered -an index into the Unicode semantic tables (e.g. swashes). - -If C does not point to a well-formed UTF-8 character and UTF8 warnings are -enabled, zero is returned and C<*retlen> is set (if C 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 isn't NULL) so that (S + C<*retlen>>) is the -next possible position in C that could begin a non-malformed character. -See L for details on when the REPLACEMENT CHARACTER is returned. - -=cut -*/ - -UV -Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) -{ - PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF; - - assert(send > s); - - /* Call the low level routine asking for checks */ - return Perl_utf8n_to_uvuni(aTHX_ s, send -s, retlen, - ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); -} - -/* Like L(), but should only be called when it is known that - * there are no malformations in the input UTF-8 string C. Surrogates, - * non-character code points, and non-Unicode code points are allowed */ - -UV -Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) -{ UV expectlen = UTF8SKIP(s); const U8* send = s + expectlen; - UV uv = NATIVE_TO_UTF(*s); + UV uv = *s; - PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI; + PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR; + PERL_UNUSED_CONTEXT; if (retlen) { - *retlen = expectlen; + *retlen = expectlen; } /* An invariant is trivially returned */ @@ -1030,6 +986,10 @@ Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) return uv; } +#ifdef EBCDIC + uv = NATIVE_UTF8_TO_I8(uv); +#endif + /* Remove the leading bits that indicate the number of bytes, leaving just * the bits that are part of the value */ uv &= UTF_START_MASK(expectlen); @@ -1038,45 +998,49 @@ Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) * working total as we go. (I khw tried unrolling the loop for up to 4 * bytes, but there was no performance improvement) */ for (++s; s < send; s++) { - uv = UTF8_ACCUMULATE(uv, *s); + uv = UTF8_ACCUMULATE(uv, *s); } - return uv; + return UNI_TO_NATIVE(uv); + } /* -=for apidoc utf8_to_uvuni - -DEPRECATED! - -Returns the Unicode code point of the first character in the string C -which is assumed to be in UTF-8 encoding; C will be set to the -length, in bytes, of that character. +=for apidoc utf8_to_uvuni_buf -This function should only be used when the returned UV is considered -an index into the Unicode semantic tables (e.g. swashes). +Only in very rare circumstances should code need to be dealing in Unicode +(as opposed to native) code points. In those few cases, use +C> instead. -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 instead. +Returns the Unicode (not-native) code point of the first character in the +string C which +is assumed to be in UTF-8 encoding; C points to 1 beyond the end of C. +C will be set to the length, in bytes, of that character. -If C points to one of the detected malformations, and UTF8 warnings are -enabled, zero is returned and C<*retlen> is set (if C doesn't point to +If C does not point to a well-formed UTF-8 character and UTF8 warnings are +enabled, zero is returned and C<*retlen> is set (if C 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 isn't NULL) so that (S + C<*retlen>>) is the next possible position in C that could begin a non-malformed character. -See L for details on when the REPLACEMENT CHARACTER is returned. +See L for details on when the REPLACEMENT CHARACTER is returned. + +Code points above the platform's C will raise a deprecation warning, +unless those are turned off. =cut */ UV -Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) +Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) { - PERL_ARGS_ASSERT_UTF8_TO_UVUNI; + PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF; - return valid_utf8_to_uvuni(s, retlen); + assert(send > s); + + /* Call the low level routine asking for checks */ + return NATIVE_TO_UNI(Perl_utf8n_to_uvchr(aTHX_ s, send -s, retlen, + ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY)); } /* @@ -1092,7 +1056,6 @@ up past C, croaks. STRLEN Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) { - dVAR; STRLEN len = 0; PERL_ARGS_ASSERT_UTF8_LENGTH; @@ -1155,11 +1118,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. */ @@ -1182,12 +1144,14 @@ Perl_utf8_hop(pTHX_ const U8 *s, I32 off) =for apidoc bytes_cmp_utf8 Compares the sequence of characters (stored as octets) in C, C with the -sequence of characters (stored as UTF-8) in C, C. Returns 0 if they are +sequence of characters (stored as UTF-8) +in C, C. Returns 0 if they are equal, -1 or -2 if the first string is less than the second string, +1 or +2 if the first string is greater than the second string. -1 or +1 is returned if the shorter string was identical to the start of the -longer string. -2 or +2 is returned if the was a difference between characters +longer string. -2 or +2 is returned if +there was a difference between characters within the strings. =cut @@ -1201,8 +1165,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)) { @@ -1210,7 +1172,7 @@ Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen) if (u < uend) { U8 c1 = *u++; if (UTF8_IS_CONTINUATION(c1)) { - c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1)); + c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1); } else { Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Malformed UTF-8 character " @@ -1267,24 +1229,29 @@ 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) { - U8 c = *s++; - - if (!UTF8_IS_INVARIANT(c) && - (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send) - || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) { - *len = ((STRLEN) -1); - return 0; + if (! UTF8_IS_INVARIANT(*s)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) { + *len = ((STRLEN) -1); + return 0; + } + s++; } + s++; } d = s = save; while (s < send) { - STRLEN ulen; - *d++ = (U8)utf8_to_uvchr_buf(s, send, &ulen); - s += ulen; + U8 c = *s++; + if (! UTF8_IS_INVARIANT(c)) { + /* Then it is two-byte encoded */ + c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s); + s++; + } + *d++ = c; } *d = '\0'; *len = d - save; @@ -1298,9 +1265,9 @@ Converts a string C of length C from UTF-8 into native byte encoding. Unlike L but like L, returns a pointer to the newly-created string, and updates C to contain the new length. Returns the original string if no conversion occurs, C -is unchanged. Do nothing if C points to 0. Sets C to +is unchanged. Do nothing if C points to 0. Sets C to 0 if C is converted or consisted entirely of characters that are invariant -in utf8 (i.e., US-ASCII on non-EBCDIC machines). +in UTF-8 (i.e., US-ASCII on non-EBCDIC machines). =cut */ @@ -1314,21 +1281,20 @@ 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; /* ensure valid UTF-8 and chars < 256 before converting string */ for (send = s + *len; s < send;) { - U8 c = *s++; - if (!UTF8_IS_INVARIANT(c)) { - if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send && - (c = *s++) && UTF8_IS_CONTINUATION(c)) - count++; - else + if (! UTF8_IS_INVARIANT(*s)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) { return (U8 *)start; + } + count++; + s++; } + s++; } *is_utf8 = FALSE; @@ -1337,9 +1303,10 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) s = start; start = d; while (s < send) { U8 c = *s++; - if (!UTF8_IS_INVARIANT(c)) { + if (! UTF8_IS_INVARIANT(c)) { /* Then it is two-byte encoded */ - c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, *s++)); + c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s); + s++; } *d++ = c; } @@ -1356,7 +1323,7 @@ UTF-8. Returns a pointer to the newly-created string, and sets C to reflect the new length in bytes. -A NUL character will be written after the end of the string. +A C character will be written after the end of the string. If you want to convert to UTF-8 from encodings other than the native (Latin1 or EBCDIC), @@ -1382,13 +1349,8 @@ Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len) dst = d; while (s < send) { - const UV uv = NATIVE_TO_ASCII(*s++); - if (UNI_IS_INVARIANT(uv)) - *d++ = (U8)UTF_TO_NATIVE(uv); - else { - *d++ = (U8)UTF8_EIGHT_BIT_HI(uv); - *d++ = (U8)UTF8_EIGHT_BIT_LO(uv); - } + append_utf8_from_native_byte(*s, &d); + s++; } *d = '\0'; *len = d-dst; @@ -1417,32 +1379,43 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) while (p < pend) { UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */ p += 2; - if (uv < 0x80) { -#ifdef EBCDIC - *d++ = UNI_TO_NATIVE(uv); -#else - *d++ = (U8)uv; -#endif + if (OFFUNI_IS_INVARIANT(uv)) { + *d++ = LATIN1_TO_NATIVE((U8) uv); continue; } - if (uv < 0x800) { - *d++ = (U8)(( uv >> 6) | 0xc0); - *d++ = (U8)(( uv & 0x3f) | 0x80); + if (uv <= MAX_UTF8_TWO_BYTE) { + *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv)); + *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv)); continue; } - if (uv >= 0xd800 && uv <= 0xdbff) { /* surrogates */ - if (p >= pend) { - Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); - } else { +#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST +#define LAST_HIGH_SURROGATE 0xDBFF +#define FIRST_LOW_SURROGATE 0xDC00 +#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST + + /* This assumes that most uses will be in the first Unicode plane, not + * needing surrogates */ + if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST + && uv <= UNICODE_SURROGATE_LAST)) + { + if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) { + Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); + } + else { UV low = (p[0] << 8) + p[1]; - p += 2; - if (low < 0xdc00 || low > 0xdfff) + if ( UNLIKELY(low < FIRST_LOW_SURROGATE) + || UNLIKELY(low > LAST_LOW_SURROGATE)) + { Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); - uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000; + } + p += 2; + uv = ((uv - FIRST_HIGH_SURROGATE) << 10) + + (low - FIRST_LOW_SURROGATE) + 0x10000; } - } else if (uv >= 0xdc00 && uv <= 0xdfff) { - Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } +#ifdef EBCDIC + d = uvoffuni_to_utf8_flags(d, uv, 0); +#else if (uv < 0x10000) { *d++ = (U8)(( uv >> 12) | 0xe0); *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); @@ -1456,6 +1429,7 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) *d++ = (U8)(( uv & 0x3f) | 0x80); continue; } +#endif } *newlen = d - dstart; return d; @@ -1492,44 +1466,17 @@ Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c) return _is_utf8_FOO(classnum, tmpbuf); } -/* 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) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_WORDCHAR, tmpbuf); -} +/* Internal function so we can deprecate the external one, and call + this one from other deprecated functions in this file */ bool -Perl_is_uni_alnumc(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_ALPHANUMERIC, tmpbuf); -} - -bool /* Internal function so we can deprecate the external one, and call - this one from other deprecated functions in this file */ -S_is_utf8_idfirst(pTHX_ const U8 *p) +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"); -} - -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); + return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL); } bool @@ -1548,97 +1495,11 @@ Perl__is_uni_perl_idstart(pTHX_ UV c) return _is_utf8_perl_idstart(tmpbuf); } -bool -Perl_is_uni_alpha(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_ALPHA, tmpbuf); -} - -bool -Perl_is_uni_ascii(pTHX_ UV c) -{ - return isASCII(c); -} - -bool -Perl_is_uni_blank(pTHX_ UV c) -{ - return isBLANK_uni(c); -} - -bool -Perl_is_uni_space(pTHX_ UV c) -{ - return isSPACE_uni(c); -} - -bool -Perl_is_uni_digit(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_DIGIT, tmpbuf); -} - -bool -Perl_is_uni_upper(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_UPPER, tmpbuf); -} - -bool -Perl_is_uni_lower(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_LOWER, tmpbuf); -} - -bool -Perl_is_uni_cntrl(pTHX_ UV c) -{ - return isCNTRL_L1(c); -} - -bool -Perl_is_uni_graph(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_GRAPH, tmpbuf); -} - -bool -Perl_is_uni_print(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_PRINT, tmpbuf); -} - -bool -Perl_is_uni_punct(pTHX_ UV c) -{ - U8 tmpbuf[UTF8_MAXBYTES+1]; - uvchr_to_utf8(tmpbuf, c); - return _is_utf8_FOO(_CC_PUNCT, tmpbuf); -} - -bool -Perl_is_uni_xdigit(pTHX_ UV c) -{ - return isXDIGIT_uni(c); -} - 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 + * those, converting the result to UTF-8. 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 */ @@ -1649,8 +1510,8 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_ assert(S_or_s == 'S' || S_or_s == 's'); - if (UNI_IS_INVARIANT(converted)) { /* No difference between the two for - characters in this range */ + if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for + characters in this range */ *p = (U8) converted; *lenp = 1; return converted; @@ -1667,14 +1528,18 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_ case MICRO_SIGN: converted = GREEK_CAPITAL_LETTER_MU; break; +#if UNICODE_MAJOR_VERSION > 2 \ + || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ + && UNICODE_DOT_DOT_VERSION >= 8) case LATIN_SMALL_LETTER_SHARP_S: *(p)++ = 'S'; *p = S_or_s; *lenp = 2; return 'S'; +#endif default: Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } } @@ -1693,20 +1558,18 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_ * 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") +#define CALL_UPPER_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_toupper, "ToUc", "") +#define CALL_TITLE_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_totitle, "ToTc", "") +#define CALL_LOWER_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_tolower, "ToLc", "") -/* 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 +/* 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) +#define CALL_FOLD_CASE(uv, s, d, lenp, specials) _to_utf8_case(uv, s, d, lenp, &PL_utf8_tofold, "ToCf", (specials) ? "" : NULL) UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - /* Convert the Unicode character whose ordinal is to its uppercase * version and store that in UTF-8 in

and its length in bytes in . * Note that the

needs to be at least UTF8_MAXBYTES_CASE+1 bytes since @@ -1722,14 +1585,12 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) } uvchr_to_utf8(p, c); - return CALL_UPPER_CASE(p, p, lenp); + return CALL_UPPER_CASE(c, p, p, lenp); } UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - PERL_ARGS_ASSERT_TO_UNI_TITLE; if (c < 256) { @@ -1737,26 +1598,28 @@ Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) } uvchr_to_utf8(p, c); - return CALL_TITLE_CASE(p, p, lenp); + return CALL_TITLE_CASE(c, p, p, 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 + * those, converting the result to UTF-8. Since the result is always just * one character, we allow

to be NULL */ U8 converted = toLOWER_LATIN1(c); if (p != NULL) { - if (UNI_IS_INVARIANT(converted)) { + if (NATIVE_BYTE_IS_INVARIANT(converted)) { *p = converted; *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; } } @@ -1766,8 +1629,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) { @@ -1775,34 +1636,58 @@ Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) } uvchr_to_utf8(p, c); - return CALL_LOWER_CASE(p, p, lenp); + return CALL_LOWER_CASE(c, p, p, lenp); } UV -Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const bool flags) +Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int flags) { - /* Corresponds to to_lower_latin1(), is TRUE if to use full case - * folding */ + /* Corresponds to to_lower_latin1(); bits meanings: + * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited + * FOLD_FLAGS_FULL iff full folding is to be used; + * + * Not to be used for locale folds + */ UV converted; PERL_ARGS_ASSERT__TO_FOLD_LATIN1; + PERL_UNUSED_CONTEXT; + + assert (! (flags & FOLD_FLAGS_LOCALE)); - if (c == MICRO_SIGN) { + if (UNLIKELY(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'; +#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ + || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ + || UNICODE_DOT_DOT_VERSION > 0) + else if ( (flags & FOLD_FLAGS_FULL) + && UNLIKELY(c == LATIN_SMALL_LETTER_SHARP_S)) + { + /* If can't cross 127/128 boundary, can't return "ss"; instead return + * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}") + * under those circumstances. */ + if (flags & FOLD_FLAGS_NOMIX_ASCII) { + *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2; + Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8, + p, *lenp, U8); + return LATIN_SMALL_LETTER_LONG_S; + } + else { + *(p)++ = 's'; + *p = 's'; + *lenp = 2; + return 's'; + } } +#endif else { /* In this range the fold of all other characters is their lower case */ converted = toLOWER_LATIN1(c); } - if (UNI_IS_INVARIANT(converted)) { + if (UVCHR_IS_INVARIANT(converted)) { *p = (U8) converted; *lenp = 1; } @@ -1816,228 +1701,67 @@ Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const bool flags) } UV -Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const U8 flags) +Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags) { /* Not currently externally documented, and subject to change * bits meanings: * FOLD_FLAGS_FULL iff full folding is to be used; - * FOLD_FLAGS_LOCALE iff in locale + * FOLD_FLAGS_LOCALE is set iff the rules from the current underlying + * locale are to be used. * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited */ PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS; + if (flags & FOLD_FLAGS_LOCALE) { + /* Treat a UTF-8 locale as not being in locale at all */ + if (IN_UTF8_CTYPE_LOCALE) { + flags &= ~FOLD_FLAGS_LOCALE; + } + else { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + goto needs_full_generality; + } + } + if (c < 256) { - UV result = _to_fold_latin1((U8) c, p, lenp, - cBOOL(((flags & FOLD_FLAGS_FULL) - /* If ASCII-safe, don't allow full folding, - * as that could include SHARP S => ss; - * otherwise there is no crossing of - * ascii/non-ascii in the latin1 range */ - && ! (flags & FOLD_FLAGS_NOMIX_ASCII)))); - /* It is illegal for the fold to cross the 255/256 boundary under - * locale; in this case return the original */ - return (result > 256 && flags & FOLD_FLAGS_LOCALE) - ? c - : result; - } - - /* If no special needs, just use the macro */ + return _to_fold_latin1((U8) c, p, lenp, + flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)); + } + + /* Here, above 255. If no special needs, just use the macro */ if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) { uvchr_to_utf8(p, c); - return CALL_FOLD_CASE(p, p, lenp, flags & FOLD_FLAGS_FULL); + return CALL_FOLD_CASE(c, p, p, lenp, flags & FOLD_FLAGS_FULL); } else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with the special flags. */ U8 utf8_c[UTF8_MAXBYTES + 1]; - uvchr_to_utf8(utf8_c, c); - return _to_utf8_fold_flags(utf8_c, p, lenp, flags, NULL); - } -} - -bool -Perl_is_uni_alnum_lc(pTHX_ UV c) -{ - if (c < 256) { - return isALNUM_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_WORDCHAR, c); -} - -bool -Perl_is_uni_alnumc_lc(pTHX_ UV c) -{ - if (c < 256) { - return isALPHANUMERIC_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_ALPHANUMERIC, c); -} - -bool -Perl_is_uni_idfirst_lc(pTHX_ UV c) -{ - if (c < 256) { - return isIDFIRST_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_perl_idstart(c); -} - -bool -Perl_is_uni_alpha_lc(pTHX_ UV c) -{ - if (c < 256) { - return isALPHA_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_ALPHA, c); -} - -bool -Perl_is_uni_ascii_lc(pTHX_ UV c) -{ - if (c < 256) { - return isASCII_LC(UNI_TO_NATIVE(c)); - } - return 0; -} - -bool -Perl_is_uni_blank_lc(pTHX_ UV c) -{ - if (c < 256) { - return isBLANK_LC(UNI_TO_NATIVE(c)); - } - return isBLANK_uni(c); -} - -bool -Perl_is_uni_space_lc(pTHX_ UV c) -{ - if (c < 256) { - return isSPACE_LC(UNI_TO_NATIVE(c)); - } - return isSPACE_uni(c); -} - -bool -Perl_is_uni_digit_lc(pTHX_ UV c) -{ - if (c < 256) { - return isDIGIT_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_DIGIT, c); -} - -bool -Perl_is_uni_upper_lc(pTHX_ UV c) -{ - if (c < 256) { - return isUPPER_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_UPPER, c); -} - -bool -Perl_is_uni_lower_lc(pTHX_ UV c) -{ - if (c < 256) { - return isLOWER_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_LOWER, c); -} - -bool -Perl_is_uni_cntrl_lc(pTHX_ UV c) -{ - if (c < 256) { - return isCNTRL_LC(UNI_TO_NATIVE(c)); - } - return 0; -} - -bool -Perl_is_uni_graph_lc(pTHX_ UV c) -{ - if (c < 256) { - return isGRAPH_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_GRAPH, c); -} - -bool -Perl_is_uni_print_lc(pTHX_ UV c) -{ - if (c < 256) { - return isPRINT_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_PRINT, c); -} - -bool -Perl_is_uni_punct_lc(pTHX_ UV c) -{ - if (c < 256) { - return isPUNCT_LC(UNI_TO_NATIVE(c)); - } - return _is_uni_FOO(_CC_PUNCT, c); -} -bool -Perl_is_uni_xdigit_lc(pTHX_ UV c) -{ - if (c < 256) { - return isXDIGIT_LC(UNI_TO_NATIVE(c)); + needs_full_generality: + uvchr_to_utf8(utf8_c, c); + return _to_utf8_fold_flags(utf8_c, p, lenp, flags); } - return isXDIGIT_uni(c); -} - -U32 -Perl_to_uni_upper_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_upper(c, tmpbuf, &len); -} - -U32 -Perl_to_uni_title_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character XXX -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_title(c, tmpbuf, &len); -} - -U32 -Perl_to_uni_lower_lc(pTHX_ U32 c) -{ - /* XXX returns only the first character -- do not use XXX */ - /* XXX no locale support yet */ - STRLEN len; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - return (U32)to_uni_lower(c, tmpbuf, &len); } PERL_STATIC_INLINE bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, - const char *const swashname) + const char *const swashname, SV* const invlist) { /* returns a boolean giving whether or not the UTF8-encoded character that * starts at

is in the swash indicated by . * contains a pointer to where the swash indicated by * 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 + * look at <*swash> and only generate a swash if it is not null. + * is NULL or an inversion list that defines the swash. If not null, it + * saves time during initialization of the swash. * * Note that it is assumed that the buffer length of

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; /* The API should have included a length for the UTF-8 character in

, @@ -2045,7 +1769,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); @@ -2058,7 +1782,13 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, } if (!*swash) { U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; - *swash = _core_swash_init("utf8", swashname, &PL_sv_undef, 1, 0, NULL, &flags); + *swash = _core_swash_init("utf8", + + /* Only use the name if there is no inversion + * list; otherwise will go out to disk */ + (invlist) ? "" : swashname, + + &PL_sv_undef, 1, 0, invlist, &flags); } return swash_fetch(*swash, p, TRUE) != 0; @@ -2067,304 +1797,108 @@ 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); - return is_utf8_common(p, &PL_utf8_swash_ptrs[classnum], swash_property_names[classnum]); + return is_utf8_common(p, + &PL_utf8_swash_ptrs[classnum], + swash_property_names[classnum], + PL_XPosix_ptrs[classnum]); } bool -Perl_is_utf8_alnum(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_ALNUM; - - /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true - * descendant of isalnum(3), in other words, it doesn't - * contain the '_'. --jhi */ - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_WORDCHAR], "IsWord"); -} - -bool -Perl_is_utf8_alnumc(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_ALNUMC; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHANUMERIC], "IsAlnum"); -} - -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, "_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"); -} - -bool -Perl__is_utf8_perl_idstart(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART; - - return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart"); + return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL); } bool Perl__is_utf8_perl_idcont(pTHX_ const U8 *p) { - dVAR; + SV* invlist = NULL; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT; - return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont"); -} - - -bool -Perl_is_utf8_idcont(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_IDCONT; - - return is_utf8_common(p, &PL_utf8_idcont, "IdContinue"); -} - -bool -Perl_is_utf8_xidcont(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_XIDCONT; - - return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue"); -} - -bool -Perl_is_utf8_alpha(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_ALPHA; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHA], "IsAlpha"); -} - -bool -Perl_is_utf8_ascii(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_ASCII; - - /* ASCII characters are the same whether in utf8 or not. So the macro - * works on both utf8 and non-utf8 representations. */ - return isASCII(*p); -} - -bool -Perl_is_utf8_blank(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_BLANK; - - return isBLANK_utf8(p); -} - -bool -Perl_is_utf8_space(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_SPACE; - - return isSPACE_utf8(p); -} - -bool -Perl_is_utf8_perl_space(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE; - - /* Only true if is an ASCII space-like character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isSPACE_A(*p); -} - -bool -Perl_is_utf8_perl_word(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD; - - /* Only true if is an ASCII word character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isWORDCHAR_A(*p); -} - -bool -Perl_is_utf8_digit(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_DIGIT; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_DIGIT], "IsDigit"); -} - -bool -Perl_is_utf8_posix_digit(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT; - - /* Only true if is an ASCII digit character, and ASCII is invariant - * under utf8, so can just use the macro */ - return isDIGIT_A(*p); -} - -bool -Perl_is_utf8_upper(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_UPPER; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_UPPER], "IsUppercase"); -} - -bool -Perl_is_utf8_lower(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_LOWER; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_LOWER], "IsLowercase"); -} - -bool -Perl_is_utf8_cntrl(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_CNTRL; - - return isCNTRL_utf8(p); -} - -bool -Perl_is_utf8_graph(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_GRAPH; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_GRAPH], "IsGraph"); -} - -bool -Perl_is_utf8_print(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_PRINT; - - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PRINT], "IsPrint"); + if (! PL_utf8_perl_idcont) { + invlist = _new_invlist_C_array(_Perl_IDCont_invlist); + } + return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont", invlist); } bool -Perl_is_utf8_punct(pTHX_ const U8 *p) +Perl__is_utf8_idcont(pTHX_ const U8 *p) { - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_PUNCT; + PERL_ARGS_ASSERT__IS_UTF8_IDCONT; - return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PUNCT], "IsPunct"); + return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL); } bool -Perl_is_utf8_xdigit(pTHX_ const U8 *p) +Perl__is_utf8_xidcont(pTHX_ const U8 *p) { - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_XDIGIT; + PERL_ARGS_ASSERT__IS_UTF8_XIDCONT; - return is_XDIGIT_utf8(p); + return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL); } 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"); -} - - -bool -Perl_is_utf8_mark(pTHX_ const U8 *p) -{ - dVAR; - - PERL_ARGS_ASSERT_IS_UTF8_MARK; - - return _is_utf8_mark(p); + return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL); } /* =for apidoc to_utf8_case -The C

contains the pointer to the UTF-8 string encoding +Instead use the appropriate one of L, +L, +L, +or L. + +C

contains the pointer to the UTF-8 string encoding the character that is being converted. This routine assumes that the character at C

is well-formed. -The C is a pointer to the character buffer to put the -conversion result to. The C is a pointer to the length +C is a pointer to the character buffer to put the +conversion result to. C is a pointer to the length of the result. -The C is a pointer to the swash to use. +C is a pointer to the swash to use. Both the special and normal mappings are stored in F, -and loaded by SWASHNEW, using F. The C (usually, +and loaded by C, using F. C (usually, but not always, a multicharacter mapping), is tried first. -The C is a string like "utf8::ToSpecLower", which means the -hash %utf8::ToSpecLower. The access to the hash is through -Perl_to_utf8_case(). +C is a string, normally C or C<"">. C means to not use +any special mappings; C<""> means to use the special mappings. Values other +than these two are treated as the name of the hash containing the special +mappings, like C<"utf8::ToSpecLower">. -The C is a string like "ToLower" which means the swash -%utf8::ToLower. +C is a string like C<"ToLower"> which means the swash +C<%utf8::ToLower>. + +Code points above the platform's C will raise a deprecation warning, +unless those are turned off. =cut */ @@ -2372,101 +1906,159 @@ UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) { - dVAR; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; + PERL_ARGS_ASSERT_TO_UTF8_CASE; + + return _to_utf8_case(valid_utf8_to_uvchr(p, NULL), p, ustrp, lenp, swashp, normal, special); +} + + /* change namve uv1 to 'from' */ +STATIC UV +S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, + SV **swashp, const char *normal, const char *special) +{ STRLEN len = 0; - const UV uv0 = valid_utf8_to_uvchr(p, NULL); - /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings - * are necessary in EBCDIC, they are redundant no-ops - * in ASCII-ish platforms, and hopefully optimized away. */ - const UV uv1 = NATIVE_TO_UNI(uv0); - PERL_ARGS_ASSERT_TO_UTF8_CASE; + PERL_ARGS_ASSERT__TO_UTF8_CASE; + + /* For code points that don't change case, we already know that the output + * of this function is the unchanged input, so we can skip doing look-ups + * for them. Unfortunately the case-changing code points are scattered + * around. But there are some long consecutive ranges where there are no + * case changing code points. By adding tests, we can eliminate the lookup + * for all the ones in such ranges. This is currently done here only for + * just a few cases where the scripts are in common use in modern commerce + * (and scripts adjacent to those which can be included without additional + * tests). */ + + if (uv1 >= 0x0590) { + /* This keeps from needing further processing the code points most + * likely to be used in the following non-cased scripts: Hebrew, + * Arabic, Syriac, Thaana, NKo, Samaritan, Mandaic, Devanagari, + * Bengali, Gurmukhi, Gujarati, Oriya, Tamil, Telugu, Kannada, + * Malayalam, Sinhala, Thai, Lao, Tibetan, Myanmar */ + if (uv1 < 0x10A0) { + goto cases_to_self; + } - /* Note that swash_fetch() doesn't output warnings for these because it - * assumes we will */ - if (uv1 >= UNICODE_SURROGATE_FIRST) { - if (uv1 <= UNICODE_SURROGATE_LAST) { - if (ckWARN_d(WARN_SURROGATE)) { - const char* desc = (PL_op) ? OP_DESC(PL_op) : normal; - Perl_warner(aTHX_ packWARN(WARN_SURROGATE), - "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1); - } - } - else if (UNICODE_IS_SUPER(uv1)) { - if (ckWARN_d(WARN_NON_UNICODE)) { - const char* desc = (PL_op) ? OP_DESC(PL_op) : normal; - Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), - "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1); - } - } + /* The following largish code point ranges also don't have case + * changes, but khw didn't think they warranted extra tests to speed + * them up (which would slightly slow down everything else above them): + * 1100..139F Hangul Jamo, Ethiopic + * 1400..1CFF Unified Canadian Aboriginal Syllabics, Ogham, Runic, + * Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Mongolian, + * Limbu, Tai Le, New Tai Lue, Buginese, Tai Tham, + * Combining Diacritical Marks Extended, Balinese, + * Sundanese, Batak, Lepcha, Ol Chiki + * 2000..206F General Punctuation + */ + + if (uv1 >= 0x2D30) { + + /* This keeps the from needing further processing the code points + * most likely to be used in the following non-cased major scripts: + * CJK, Katakana, Hiragana, plus some less-likely scripts. + * + * (0x2D30 above might have to be changed to 2F00 in the unlikely + * event that Unicode eventually allocates the unused block as of + * v8.0 2FE0..2FEF to code points that are cased. khw has verified + * that the test suite will start having failures to alert you + * should that happen) */ + if (uv1 < 0xA640) { + goto cases_to_self; + } + + if (uv1 >= 0xAC00) { + if (UNLIKELY(UNICODE_IS_SURROGATE(uv1))) { + if (ckWARN_d(WARN_SURROGATE)) { + const char* desc = (PL_op) ? OP_DESC(PL_op) : normal; + Perl_warner(aTHX_ packWARN(WARN_SURROGATE), + "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1); + } + goto cases_to_self; + } + + /* AC00..FAFF Catches Hangul syllables and private use, plus + * some others */ + if (uv1 < 0xFB00) { + goto cases_to_self; + + } + + if (UNLIKELY(UNICODE_IS_SUPER(uv1))) { + if ( UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP) + && ckWARN_d(WARN_DEPRECATED)) + { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP); + } + if (ckWARN_d(WARN_NON_UNICODE)) { + const char* desc = (PL_op) ? OP_DESC(PL_op) : normal; + Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), + "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1); + } + goto cases_to_self; + } +#ifdef HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C + if (UNLIKELY(uv1 + > HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C)) + { + + /* As of this writing, this means we avoid swash creation + * for anything beyond low Plane 1 */ + goto cases_to_self; + } +#endif + } + } /* Note that non-characters are perfectly legal, so no warning should - * be given */ + * be given. There are so few of them, that it isn't worth the extra + * tests to avoid swash creation */ } - uvuni_to_utf8(tmpbuf, uv1); - if (!*swashp) /* load on-demand */ *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL); if (special) { /* It might be "special" (sometimes, but not always, * a multicharacter mapping) */ - HV * const hv = get_hv(special, 0); + HV *hv = NULL; SV **svp; - if (hv && - (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) && - (*svp)) { + /* If passed in the specials name, use that; otherwise use any + * given in the swash */ + if (*special != '\0') { + hv = get_hv(special, 0); + } + else { + svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0); + if (svp) { + hv = MUTABLE_HV(SvRV(*svp)); + } + } + + if (hv + && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE)) + && (*svp)) + { const char *s; s = SvPV_const(*svp, len); if (len == 1) - len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp; + /* EIGHTBIT */ + len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp; else { -#ifdef EBCDIC - /* If we have EBCDIC we need to remap the characters - * since any characters in the low 256 are Unicode - * code points, not EBCDIC. */ - U8 *t = (U8*)s, *tend = t + len, *d; - - d = tmpbuf; - if (SvUTF8(*svp)) { - STRLEN tlen = 0; - - while (t < tend) { - const UV c = utf8_to_uvchr_buf(t, tend, &tlen); - if (tlen > 0) { - d = uvchr_to_utf8(d, UNI_TO_NATIVE(c)); - t += tlen; - } - else - break; - } - } - else { - while (t < tend) { - d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t)); - t++; - } - } - len = d - tmpbuf; - Copy(tmpbuf, ustrp, len, U8); -#else Copy(s, ustrp, len, U8); -#endif } } } if (!len && *swashp) { - const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE /* => is utf8 */); + const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */); if (uv2) { /* It was "normal" (a single character mapping). */ - const UV uv3 = UNI_TO_NATIVE(uv2); - len = uvchr_to_utf8(ustrp, uv3) - ustrp; + len = uvchr_to_utf8(ustrp, uv2) - ustrp; } } @@ -2479,6 +2071,7 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, /* Here, there was no mapping defined, which means that the code point maps * to itself. Return the inputs */ + cases_to_self: len = UTF8SKIP(p); if (p != ustrp) { /* Don't copy onto itself */ Copy(p, ustrp, len, U8); @@ -2487,17 +2080,18 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, if (lenp) *lenp = len; - return uv0; + return uv1; } 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 for why; + /* This is called when changing the case of a UTF-8-encoded character above + * the Latin1 range, and the operation is in a non-UTF-8 locale. If the + * result contains a character that crosses the 255/256 boundary, disallow + * the change, and return the original code point. See L for + * why; * * p points to the original string whose case was changed; assumed * by this routine to be well-formed @@ -2509,7 +2103,7 @@ S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* c PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING; - assert(! UTF8_IS_INVARIANT(*p) && ! UTF8_IS_DOWNGRADEABLE_START(*p)); + assert(UTF8_IS_ABOVE_LATIN1(*p)); /* We know immediately if the first character in the string crosses the * boundary, so can skip */ @@ -2520,21 +2114,29 @@ S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* c U8* s = ustrp + UTF8SKIP(ustrp); U8* e = ustrp + *lenp; while (s < e) { - if (UTF8_IS_INVARIANT(*s) || UTF8_IS_DOWNGRADEABLE_START(*s)) - { + if (! UTF8_IS_ABOVE_LATIN1(*s)) { goto bad_crossing; } s += UTF8SKIP(s); } - /* Here, no characters crossed, result is ok as-is */ + /* Here, no characters crossed, result is ok as-is, but we warn. */ + _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p)); return result; } -bad_crossing: + bad_crossing: /* Failed, have to return the original */ original = valid_utf8_to_uvchr(p, lenp); + + /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */ + Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), + "Can't do %s(\"\\x{%"UVXf"}\") on non-UTF-8 locale; " + "resolved to \"\\x{%"UVXf"}\".", + OP_DESC(PL_op), + original, + original); Copy(p, ustrp, *lenp, char); return original; } @@ -2542,32 +2144,31 @@ bad_crossing: /* =for apidoc to_utf8_upper -Convert the UTF-8 encoded character at C

to its uppercase version and -store that in UTF-8 in C and its length in bytes in C. Note -that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since -the uppercase version may be longer than the original character. - -The first character of the uppercased version is returned -(but note, as explained above, that there may be more.) - -The character at C

is assumed by this routine to be well-formed. +Instead use L. =cut */ /* Not currently externally documented, and subject to change: - * is set iff locale semantics are to be used for code points < 256 - * if non-null, *tainted_ptr will be set TRUE iff locale rules - * were used in the calculation; otherwise unchanged. */ + * is set iff iff the rules from the current underlying locale are to + * be used. */ UV -Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr) +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; + if (flags) { + /* Treat a UTF-8 locale as not being in locale at all */ + if (IN_UTF8_CTYPE_LOCALE) { + flags = FALSE; + } + else { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + } + if (UTF8_IS_INVARIANT(*p)) { if (flags) { result = toUPPER_LC(*p); @@ -2578,15 +2179,16 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1))); + U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); + result = toUPPER_LC(c); } else { - return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)), + return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp, 'S'); } } - else { /* utf8, ord above 255 */ - result = CALL_UPPER_CASE(p, ustrp, lenp); + else { /* UTF-8, ord above 255 */ + result = CALL_UPPER_CASE(valid_utf8_to_uvchr(p, NULL), p, ustrp, lenp); if (flags) { result = check_locale_boundary_crossing(p, result, ustrp, lenp); @@ -2594,54 +2196,50 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool return result; } - /* Here, used locale rules. Convert back to utf8 */ + /* Here, used locale rules. Convert back to UTF-8 */ if (UTF8_IS_INVARIANT(result)) { *ustrp = (U8) result; *lenp = 1; } else { - *ustrp = UTF8_EIGHT_BIT_HI(result); - *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result); + *ustrp = UTF8_EIGHT_BIT_HI((U8) result); + *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); *lenp = 2; } - if (tainted_ptr) { - *tainted_ptr = TRUE; - } return result; } /* =for apidoc to_utf8_title -Convert the UTF-8 encoded character at C

to its titlecase version and -store that in UTF-8 in C and its length in bytes in C. Note -that the C needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the -titlecase version may be longer than the original character. - -The first character of the titlecased version is returned -(but note, as explained above, that there may be more.) - -The character at C

is assumed by this routine to be well-formed. +Instead use L. =cut */ /* Not currently externally documented, and subject to change: - * 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/ - * if non-null, *tainted_ptr will be set TRUE iff locale rules - * were used in the calculation; otherwise unchanged. */ + * is set iff the rules from the current underlying locale are to be + * used. Since titlecase is not defined in POSIX, for other than a + * UTF-8 locale, uppercase is used instead for code points < 256. + */ UV -Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr) +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; + if (flags) { + /* Treat a UTF-8 locale as not being in locale at all */ + if (IN_UTF8_CTYPE_LOCALE) { + flags = FALSE; + } + else { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + } + if (UTF8_IS_INVARIANT(*p)) { if (flags) { result = toUPPER_LC(*p); @@ -2652,15 +2250,16 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1))); + U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); + result = toUPPER_LC(c); } else { - return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)), + return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp, 's'); } } - else { /* utf8, ord above 255 */ - result = CALL_TITLE_CASE(p, ustrp, lenp); + else { /* UTF-8, ord above 255 */ + result = CALL_TITLE_CASE(valid_utf8_to_uvchr(p, NULL), p, ustrp, lenp); if (flags) { result = check_locale_boundary_crossing(p, result, ustrp, lenp); @@ -2668,52 +2267,49 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool return result; } - /* Here, used locale rules. Convert back to utf8 */ + /* Here, used locale rules. Convert back to UTF-8 */ if (UTF8_IS_INVARIANT(result)) { *ustrp = (U8) result; *lenp = 1; } else { - *ustrp = UTF8_EIGHT_BIT_HI(result); - *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result); + *ustrp = UTF8_EIGHT_BIT_HI((U8) result); + *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); *lenp = 2; } - if (tainted_ptr) { - *tainted_ptr = TRUE; - } return result; } /* =for apidoc to_utf8_lower -Convert the UTF-8 encoded character at C

to its lowercase version and -store that in UTF-8 in ustrp and its length in bytes in C. Note -that the C needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the -lowercase version may be longer than the original character. - -The first character of the lowercased version is returned -(but note, as explained above, that there may be more.) - -The character at C

is assumed by this routine to be well-formed. +Instead use L. =cut */ /* Not currently externally documented, and subject to change: - * is set iff locale semantics are to be used for code points < 256 - * if non-null, *tainted_ptr will be set TRUE iff locale rules - * were used in the calculation; otherwise unchanged. */ + * is set iff iff the rules from the current underlying locale are to + * be used. + */ UV -Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr) +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) { + /* Treat a UTF-8 locale as not being in locale at all */ + if (IN_UTF8_CTYPE_LOCALE) { + flags = FALSE; + } + else { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + } + if (UTF8_IS_INVARIANT(*p)) { if (flags) { result = toLOWER_LC(*p); @@ -2724,15 +2320,16 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1))); + U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); + result = toLOWER_LC(c); } else { - return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)), + return to_lower_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp); } } - else { /* utf8, ord above 255 */ - result = CALL_LOWER_CASE(p, ustrp, lenp); + else { /* UTF-8, ord above 255 */ + result = CALL_LOWER_CASE(valid_utf8_to_uvchr(p, NULL), p, ustrp, lenp); if (flags) { result = check_locale_boundary_crossing(p, result, ustrp, lenp); @@ -2741,56 +2338,40 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool return result; } - /* Here, used locale rules. Convert back to utf8 */ + /* Here, used locale rules. Convert back to UTF-8 */ if (UTF8_IS_INVARIANT(result)) { *ustrp = (U8) result; *lenp = 1; } else { - *ustrp = UTF8_EIGHT_BIT_HI(result); - *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result); + *ustrp = UTF8_EIGHT_BIT_HI((U8) result); + *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); *lenp = 2; } - if (tainted_ptr) { - *tainted_ptr = TRUE; - } return result; } /* =for apidoc to_utf8_fold -Convert the UTF-8 encoded character at C

to its foldcase version and -store that in UTF-8 in C and its length in bytes in C. Note -that the C needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the -foldcase version may be longer than the original character (up to -three characters). - -The first character of the foldcased version is returned -(but note, as explained above, that there may be more.) - -The character at C

is assumed by this routine to be well-formed. +Instead use L. =cut */ /* Not currently externally documented, and subject to change, * in - * 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_LOCALE is set iff the rules from the current underlying + * locale are to be used. * bit FOLD_FLAGS_FULL is set iff full case folds are to be used; * otherwise simple folds * bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are * prohibited - * if non-null, *tainted_ptr will be set TRUE iff locale rules - * were used in the calculation; otherwise unchanged. */ + */ UV -Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr) +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; @@ -2800,44 +2381,102 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, b assert(p != ustrp); /* Otherwise overwrites */ + if (flags & FOLD_FLAGS_LOCALE) { + /* Treat a UTF-8 locale as not being in locale at all */ + if (IN_UTF8_CTYPE_LOCALE) { + flags &= ~FOLD_FLAGS_LOCALE; + } + else { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + } + if (UTF8_IS_INVARIANT(*p)) { if (flags & FOLD_FLAGS_LOCALE) { - result = toLOWER_LC(*p); + result = toFOLD_LC(*p); } else { return _to_fold_latin1(*p, ustrp, lenp, - cBOOL(flags & FOLD_FLAGS_FULL)); + flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)); } } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags & FOLD_FLAGS_LOCALE) { - result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1))); + U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)); + result = toFOLD_LC(c); } else { - return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)), - ustrp, lenp, - cBOOL((flags & FOLD_FLAGS_FULL - /* If ASCII safe, don't allow full - * folding, as that could include SHARP - * S => ss; otherwise there is no - * crossing of ascii/non-ascii in the - * latin1 range */ - && ! (flags & FOLD_FLAGS_NOMIX_ASCII)))); + return _to_fold_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), + ustrp, lenp, + flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)); } } - else { /* utf8, ord above 255 */ - result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL); + else { /* UTF-8, ord above 255 */ + result = CALL_FOLD_CASE(valid_utf8_to_uvchr(p, NULL), p, ustrp, lenp, flags & FOLD_FLAGS_FULL); + + if (flags & FOLD_FLAGS_LOCALE) { + +# define LONG_S_T LATIN_SMALL_LIGATURE_LONG_S_T_UTF8 + const unsigned int long_s_t_len = sizeof(LONG_S_T) - 1; + +# ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8 +# define CAP_SHARP_S LATIN_CAPITAL_LETTER_SHARP_S_UTF8 + + const unsigned int cap_sharp_s_len = sizeof(CAP_SHARP_S) - 1; + + /* Special case these two characters, as what normally gets + * returned under locale doesn't work */ + if (UTF8SKIP(p) == cap_sharp_s_len + && memEQ((char *) p, CAP_SHARP_S, cap_sharp_s_len)) + { + /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */ + Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), + "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; " + "resolved to \"\\x{17F}\\x{17F}\"."); + goto return_long_s; + } + else +#endif + if (UTF8SKIP(p) == long_s_t_len + && memEQ((char *) p, LONG_S_T, long_s_t_len)) + { + /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */ + Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), + "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; " + "resolved to \"\\x{FB06}\"."); + goto return_ligature_st; + } + +#if UNICODE_MAJOR_VERSION == 3 \ + && UNICODE_DOT_VERSION == 0 \ + && UNICODE_DOT_DOT_VERSION == 1 +# define DOTTED_I LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE_UTF8 + + /* And special case this on this Unicode version only, for the same + * reaons the other two are special cased. They would cross the + * 255/256 boundary which is forbidden under /l, and so the code + * wouldn't catch that they are equivalent (which they are only in + * this release) */ + else if (UTF8SKIP(p) == sizeof(DOTTED_I) - 1 + && memEQ((char *) p, DOTTED_I, sizeof(DOTTED_I) - 1)) + { + /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */ + Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), + "Can't do fc(\"\\x{0130}\") on non-UTF-8 locale; " + "resolved to \"\\x{0131}\"."); + goto return_dotless_i; + } +#endif - if ((flags & FOLD_FLAGS_LOCALE)) { return check_locale_boundary_crossing(p, result, ustrp, lenp); } else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) { return result; } else { - /* This is called when changing the case of a utf8-encoded - * character above the Latin1 range, and the result should not - * contain an ASCII character. */ + /* This is called when changing the case of a UTF-8-encoded + * character above the ASCII range, and the result should not + * contain an ASCII character. */ UV original; /* To store the first code point of

*/ @@ -2849,6 +2488,27 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, b if (isASCII(*s)) { /* Crossed, have to return the original */ original = valid_utf8_to_uvchr(p, lenp); + + /* But in these instances, there is an alternative we can + * return that is valid */ + if (original == LATIN_SMALL_LETTER_SHARP_S +#ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */ + || original == LATIN_CAPITAL_LETTER_SHARP_S +#endif + ) { + goto return_long_s; + } + else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) { + goto return_ligature_st; + } +#if UNICODE_MAJOR_VERSION == 3 \ + && UNICODE_DOT_VERSION == 0 \ + && UNICODE_DOT_DOT_VERSION == 1 + + else if (original == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) { + goto return_dotless_i; + } +#endif Copy(p, ustrp, *lenp, char); return original; } @@ -2860,21 +2520,50 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, b } } - /* Here, used locale rules. Convert back to utf8 */ + /* Here, used locale rules. Convert back to UTF-8 */ if (UTF8_IS_INVARIANT(result)) { *ustrp = (U8) result; *lenp = 1; } else { - *ustrp = UTF8_EIGHT_BIT_HI(result); - *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result); + *ustrp = UTF8_EIGHT_BIT_HI((U8) result); + *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); *lenp = 2; } - if (tainted_ptr) { - *tainted_ptr = TRUE; - } return result; + + return_long_s: + /* Certain folds to 'ss' are prohibited by the options, but they do allow + * folds to a string of two of these characters. By returning this + * instead, then, e.g., + * fc("\x{1E9E}") eq fc("\x{17F}\x{17F}") + * works. */ + + *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2; + Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8, + ustrp, *lenp, U8); + return LATIN_SMALL_LETTER_LONG_S; + + return_ligature_st: + /* Two folds to 'st' are prohibited by the options; instead we pick one and + * have the other one fold to it */ + + *lenp = sizeof(LATIN_SMALL_LIGATURE_ST_UTF8) - 1; + Copy(LATIN_SMALL_LIGATURE_ST_UTF8, ustrp, *lenp, U8); + return LATIN_SMALL_LIGATURE_ST; + +#if UNICODE_MAJOR_VERSION == 3 \ + && UNICODE_DOT_VERSION == 0 \ + && UNICODE_DOT_DOT_VERSION == 1 + + return_dotless_i: + *lenp = sizeof(LATIN_SMALL_LETTER_DOTLESS_I_UTF8) - 1; + Copy(LATIN_SMALL_LETTER_DOTLESS_I_UTF8, ustrp, *lenp, U8); + return LATIN_SMALL_LETTER_DOTLESS_I; + +#endif + } /* Note: @@ -2898,6 +2587,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. @@ -2936,11 +2633,14 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * Thus there are three possible inputs to find the swash: , * , and . At least one must be specified. The result * will be the union of the specified ones, although 's various - * actions can intersect, etc. what gives. + * actions can intersect, etc. what gives. To avoid going out to + * disk at all, should specify completely what the swash should + * have, and should be &PL_sv_undef and should be "". * * 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 = @@ -2952,6 +2652,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, "")) { @@ -2975,17 +2679,17 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m 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 */ + if (!method) { /* demand load UTF-8 */ 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 @@ -3040,12 +2744,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 */ @@ -3118,7 +2822,7 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m /* 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 */ + * touched; otherwise save the computed one */ if (! invlist_in_swash_is_valid && (int) _invlist_len(swash_invlist) > invlist_swash_boundary) { @@ -3131,6 +2835,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m else SvREFCNT_inc_simple_void_NN(swash_invlist); } + SvREADONLY_on(swash_invlist); + /* Use the inversion list stand-alone if small enough */ if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) { SvREFCNT_dec(retval); @@ -3140,7 +2846,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 } @@ -3149,14 +2856,14 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is * the lower-level routine, and it is similarly broken for returning * multiple values. --jhi - * For those, you should use to_utf8_case() instead */ + * For those, you should use S__to_utf8_case() instead */ /* Now SWASHGET is recasted into S_swatch_get in this file. */ /* Note: * Returns the value of property/mapping C for the first character * of the string C. If C is true, the string C is - * assumed to be in utf8. If C is false, the string C is - * assumed to be in native 8-bit encoding. Caches the swatch in C. + * assumed to be in well-formed UTF-8. If C is false, the string C + * is assumed to be in native 8-bit encoding. Caches the swatch in C. * * 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 @@ -3189,17 +2896,14 @@ 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; - STRLEN slen; + STRLEN slen = 0; STRLEN needents; const U8 *tmps = NULL; - U32 bit; SV *swatch; - U8 tmputf8[2]; - const UV c = NATIVE_TO_ASCII(*ptr); + const U8 c = *ptr; PERL_ARGS_ASSERT_SWASH_FETCH; @@ -3212,35 +2916,64 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) : c); } - /* 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); - ptr = tmputf8; + /* We store the values in a "swatch" which is a vec() value in a swash + * hash. Code points 0-255 are a single vec() stored with key length + * (klen) 0. All other code points have a UTF-8 representation + * 0xAA..0xYY,0xZZ. A vec() is constructed containing all of them which + * share 0xAA..0xYY, which is the key in the hash to that vec. So the key + * length for them is the length of the encoded char - 1. ptr[klen] is the + * final byte in the sequence representing the character */ + if (!do_utf8 || UTF8_IS_INVARIANT(c)) { + klen = 0; + needents = 256; + off = c; } - /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ - * then the "swatch" is a vec() for all the chars which start - * with 0xAA..0xYY - * So the key in the hash (klen) is length of encoded char -1 - */ - klen = UTF8SKIP(ptr) - 1; - off = ptr[klen]; - - if (klen == 0) { - /* If char is invariant then swatch is for all the invariant chars - * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK - */ - needents = UTF_CONTINUATION_MARK; - off = NATIVE_TO_UTF(ptr[klen]); + else if (UTF8_IS_DOWNGRADEABLE_START(c)) { + klen = 0; + needents = 256; + off = EIGHT_BIT_UTF8_TO_NATIVE(c, *(ptr + 1)); } else { - /* If char is encoded then swatch is for the prefix */ + klen = UTF8SKIP(ptr) - 1; + + /* Each vec() stores 2**UTF_ACCUMULATION_SHIFT values. The offset into + * the vec is the final byte in the sequence. (In EBCDIC this is + * converted to I8 to get consecutive values.) To help you visualize + * all this: + * Straight 1047 After final byte + * UTF-8 UTF-EBCDIC I8 transform + * U+0400: \xD0\x80 \xB8\x41\x41 \xB8\x41\xA0 + * U+0401: \xD0\x81 \xB8\x41\x42 \xB8\x41\xA1 + * ... + * U+0409: \xD0\x89 \xB8\x41\x4A \xB8\x41\xA9 + * U+040A: \xD0\x8A \xB8\x41\x51 \xB8\x41\xAA + * ... + * U+0412: \xD0\x92 \xB8\x41\x59 \xB8\x41\xB2 + * U+0413: \xD0\x93 \xB8\x41\x62 \xB8\x41\xB3 + * ... + * U+041B: \xD0\x9B \xB8\x41\x6A \xB8\x41\xBB + * U+041C: \xD0\x9C \xB8\x41\x70 \xB8\x41\xBC + * ... + * U+041F: \xD0\x9F \xB8\x41\x73 \xB8\x41\xBF + * U+0420: \xD0\xA0 \xB8\x42\x41 \xB8\x42\x41 + * + * (There are no discontinuities in the elided (...) entries.) + * The UTF-8 key for these 33 code points is '\xD0' (which also is the + * key for the next 31, up through U+043F, whose UTF-8 final byte is + * \xBF). Thus in UTF-8, each key is for a vec() for 64 code points. + * The final UTF-8 byte, which ranges between \x80 and \xBF, is an + * index into the vec() swatch (after subtracting 0x80, which we + * actually do with an '&'). + * In UTF-EBCDIC, each key is for a 32 code point vec(). The first 32 + * code points above have key '\xB8\x41'. The final UTF-EBCDIC byte has + * dicontinuities which go away by transforming it into I8, and we + * effectively subtract 0xA0 to get the index. */ needents = (1 << UTF_ACCUMULATION_SHIFT); - off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK; + off = NATIVE_UTF8_TO_I8(ptr[klen]) & UTF_CONTINUATION_MASK; } /* - * This single-entry cache saves about 1/3 of the utf8 overhead in test + * This single-entry cache saves about 1/3 of the UTF-8 overhead in test * suite. (That is, only 7-8% overall over just a hash cache. Still, * it's nothing to sniff at.) Pity we usually come through at least * two function calls to get here... @@ -3261,17 +2994,18 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) /* 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 - Unicode tables, not a native character number. - */ - const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, - ckWARN(WARN_UTF8) ? - 0 : UTF8_ALLOW_ANY); - swatch = swatch_get(swash, - /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */ - (klen) ? (code_point & ~((UV)needents - 1)) : 0, - needents); + || !(tmps = (const U8*)SvPV_const(*svp, slen))) + { + if (klen) { + const UV code_point = valid_utf8_to_uvchr(ptr, NULL); + swatch = swatch_get(swash, + code_point & ~((UV)needents - 1), + needents); + } + else { /* For the first 256 code points, the swatch has a key of + length 0 */ + swatch = swatch_get(swash, 0, needents); + } if (IN_PERL_COMPILETIME) CopHINTS_set(PL_curcop, PL_hints); @@ -3297,17 +3031,21 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) switch ((int)((slen << 3) / needents)) { case 1: - bit = 1 << (off & 7); - off >>= 3; - return (tmps[off] & bit) != 0; + return ((UV) tmps[off >> 3] & (1 << (off & 7))) != 0; case 8: - return tmps[off]; + return ((UV) tmps[off]); case 16: off <<= 1; - return (tmps[off] << 8) + tmps[off + 1] ; + return + ((UV) tmps[off ] << 8) + + ((UV) tmps[off + 1]); case 32: off <<= 2; - return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ; + return + ((UV) tmps[off ] << 24) + + ((UV) tmps[off + 1] << 16) + + ((UV) tmps[off + 2] << 8) + + ((UV) tmps[off + 3]); } Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, " "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents); @@ -3345,9 +3083,12 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val, /* nl points to the next \n in the scan */ U8* const nl = (U8*)memchr(l, '\n', lend - l); + PERL_ARGS_ASSERT_SWASH_SCAN_LIST_LINE; + /* Get the first number on the line: the range minimum */ numlen = lend - l; *min = grok_hex((char *)l, &numlen, &flags, NULL); + *max = *min; /* So can never return without setting max */ if (numlen) /* If found a hex number, position past it */ l += numlen; else if (nl) { /* Else, go handle next line, if any */ @@ -3371,30 +3112,19 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val, *max = *min; /* Non-binary tables have a third entry: what the first element of the - * range maps to */ + * range maps to. The map for those currently read here is in hex */ if (wants_value) { if (isBLANK(*l)) { ++l; - - /* 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; - } + 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; @@ -3410,7 +3140,6 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val, } else { /* Nothing following range min, should be single element with no mapping expected */ - *max = *min; if (wants_value) { *val = 0; if (typeto) { @@ -3525,8 +3254,8 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span) lend = l + lcur; while (l < lend) { UV min, max, val, upper; - l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val, - cBOOL(octets), typestr); + l = swash_scan_list_line(l, lend, &min, &max, &val, + cBOOL(octets), typestr); if (l > lend) { break; } @@ -3761,10 +3490,13 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) * 004C 006C * 212A 006B * - * The returned hash would have two keys, the utf8 for 006B and the utf8 for + * The returned hash would have two keys, the UTF-8 for 006B and the UTF-8 for * 006C. The value for each key is an array. For 006C, the array would - * have a two elements, the utf8 for itself, and for 004C. For 006B, there - * would be three elements in its array, the utf8 for 006B, 004B and 212A. + * have two elements, the UTF-8 for itself, and for 004C. For 006B, there + * would be three elements in its array, the UTF-8 for 006B, 004B and 212A. + * + * Note that there are no elements in the hash for 004B, 004C, 212A. The + * keys are only code points that are folded-to, so it isn't a full closure. * * Essentially, for any code point, it gives all the code points that map to * it, or the list of 'froms' for that point. @@ -3775,7 +3507,7 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) * * The specials hash can be extra code points, and most likely consists of * maps from single code points to multiple ones (each expressed as a string - * of utf8 characters). This function currently returns only 1-1 mappings. + * of UTF-8 characters). This function currently returns only 1-1 mappings. * However consider this possible input in the specials hash: * "\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074 * "\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074 @@ -3784,7 +3516,24 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) * currently handle. But it also means that FB05 and FB06 are equivalent in * a 1-1 mapping which we should handle, and this relationship may not be in * the main table. Therefore this function examines all the multi-char - * sequences and adds the 1-1 mappings that come out of that. */ + * sequences and adds the 1-1 mappings that come out of that. + * + * XXX This function was originally intended to be multipurpose, but its + * only use is quite likely to remain for constructing the inversion of + * the CaseFolding (//i) property. If it were more general purpose for + * regex patterns, it would have to do the FB05/FB06 game for simple folds, + * because certain folds are prohibited under /iaa and /il. As an example, + * in Unicode 3.0.1 both U+0130 and U+0131 fold to 'i', and hence are both + * equivalent under /i. But under /iaa and /il, the folds to 'i' are + * prohibited, so we would not figure out that they fold to each other. + * Code could be written to automatically figure this out, similar to the + * code that does this for multi-character folds, but this is the only case + * where something like this is ever likely to happen, as all the single + * char folds to the 0-255 range are now quite settled. Instead there is a + * little special code that is compiled only for this Unicode version. This + * is smaller and didn't require much coding time to do. But this makes + * this routine strongly tied to being used just for CaseFolding. If ever + * it should be generalized, this would have to be fixed */ U8 *l, *lend; STRLEN lcur; @@ -3829,8 +3578,8 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) hv_iterinit(specials_hv); - /* The keys are the characters (in utf8) that map to the corresponding - * utf8 string value. Iterate through the list creating the inverse + /* The keys are the characters (in UTF-8) that map to the corresponding + * UTF-8 string value. Iterate through the list creating the inverse * list. */ while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) { SV** listp; @@ -3842,7 +3591,7 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", valid_utf8_to_uvchr((U8*) char_from, 0), valid_utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/ /* Each key in the inverse list is a mapped-to value, and the key's - * hash value is a list of the strings (each in utf8) that map to + * hash value is a list of the strings (each in UTF-8) that map to * it. Those strings are all one character long */ if ((listp = hv_fetch(specials_inverse, SvPVX(sv_to), @@ -3885,13 +3634,13 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) while ((from_list = (AV *) hv_iternextsv(specials_inverse, &char_to, &to_len))) { - if (av_len(from_list) > 0) { - int i; + if (av_tindex(from_list) > 0) { + SSize_t i; /* We iterate over all combinations of i,j to place each code * point on each list */ - for (i = 0; i <= av_len(from_list); i++) { - int j; + for (i = 0; i <= av_tindex(from_list); i++) { + SSize_t j; AV* i_list = newAV(); SV** entryp = av_fetch(from_list, i, FALSE); if (entryp == NULL) { @@ -3906,8 +3655,8 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed"); } - /* For debugging: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/ - for (j = 0; j <= av_len(from_list); j++) { + /* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/ + for (j = 0; j <= av_tindex(from_list); j++) { entryp = av_fetch(from_list, j, FALSE); if (entryp == NULL) { Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed"); @@ -3927,15 +3676,32 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) } /* End of specials */ /* read $swash->{LIST} */ + +#if UNICODE_MAJOR_VERSION == 3 \ + && UNICODE_DOT_VERSION == 0 \ + && UNICODE_DOT_DOT_VERSION == 1 + + /* For this version only U+130 and U+131 are equivalent under qr//i. Add a + * rule so that things work under /iaa and /il */ + + SV * mod_listsv = sv_mortalcopy(*listsvp); + sv_catpv(mod_listsv, "130\t130\t131\n"); + l = (U8*)SvPV(mod_listsv, lcur); + +#else + l = (U8*)SvPV(*listsvp, lcur); + +#endif + lend = l + lcur; /* Go through each input line */ while (l < lend) { UV min, max, val; UV inverse; - l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val, - cBOOL(octets), typestr); + l = swash_scan_list_line(l, lend, &min, &max, &val, + cBOOL(octets), typestr); if (l > lend) { break; } @@ -3950,7 +3716,7 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) /* The key is the inverse mapping */ char key[UTF8_MAXBYTES+1]; - char* key_end = (char *) uvuni_to_utf8((U8*) key, val); + char* key_end = (char *) uvchr_to_utf8((U8*) key, val); STRLEN key_len = key_end - key; /* Get the list for the map */ @@ -3966,18 +3732,20 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash) /* Look through list to see if this inverse mapping already is * listed, or if there is a mapping to itself already */ - for (i = 0; i <= av_len(list); i++) { + 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; } @@ -4077,43 +3845,85 @@ Perl__swash_to_invlist(pTHX_ SV* const swash) loc = (char *) l; lend = l + lcur; - /* Scan the input to count the number of lines to preallocate array size - * based on worst possible case, which is each line in the input creates 2 - * elements in the inversion list: 1) the beginning of a range in the list; - * 2) the beginning of a range not in the list. */ - while ((loc = (strchr(loc, '\n'))) != NULL) { - elements += 2; - loc++; - } + if (*l == 'V') { /* Inversion list format */ + const char *after_atou = (char *) lend; + UV element0; + UV* other_elements_ptr; - /* 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' && (lcur == 0 || *(lend - 1) == '\n')))) - { - elements++; + /* The first number is a count of the rest */ + l++; + if (!grok_atoUV((const char *)l, &elements, &after_atou)) { + Perl_croak(aTHX_ "panic: Expecting a valid count of elements at start of inversion list"); + } + if (elements == 0) { + invlist = _new_invlist(0); + } + else { + while (isSPACE(*l)) l++; + l = (U8 *) after_atou; + + /* Get the 0th element, which is needed to setup the inversion list */ + while (isSPACE(*l)) l++; + if (!grok_atoUV((const char *)l, &element0, &after_atou)) { + Perl_croak(aTHX_ "panic: Expecting a valid 0th element for inversion list"); + } + l = (U8 *) after_atou; + invlist = _setup_canned_invlist(elements, element0, &other_elements_ptr); + elements--; + + /* Then just populate the rest of the input */ + while (elements-- > 0) { + if (l > lend) { + Perl_croak(aTHX_ "panic: Expecting %"UVuf" more elements than available", elements); + } + while (isSPACE(*l)) l++; + if (!grok_atoUV((const char *)l, other_elements_ptr++, &after_atou)) { + Perl_croak(aTHX_ "panic: Expecting a valid element in inversion list"); + } + l = (U8 *) after_atou; + } + } } + else { + + /* Scan the input to count the number of lines to preallocate array + * size based on worst possible case, which is each line in the input + * creates 2 elements in the inversion list: 1) the beginning of a + * range in the list; 2) the beginning of a range not in the list. */ + while ((loc = (strchr(loc, '\n'))) != NULL) { + elements += 2; + loc++; + } - invlist = _new_invlist(elements); + /* 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' && (lcur == 0 || *(lend - 1) == '\n')))) + { + elements++; + } - /* Now go through the input again, adding each range to the list */ - while (l < lend) { - UV start, end; - UV val; /* Not used by this function */ + invlist = _new_invlist(elements); - l = S_swash_scan_list_line(aTHX_ l, lend, &start, &end, &val, - cBOOL(octets), typestr); + /* Now go through the input again, adding each range to the list */ + while (l < lend) { + UV start, end; + UV val; /* Not used by this function */ - if (l > lend) { - break; - } + l = swash_scan_list_line(l, lend, &start, &end, &val, + cBOOL(octets), typestr); + + if (l > lend) { + break; + } - invlist = _add_range_to_invlist(invlist, start, end); + invlist = _add_range_to_invlist(invlist, start, end); + } } /* Invert if the data says it should be */ if (invert_it_svp && SvUV(*invert_it_svp)) { - _invlist_invert_prop(invlist); + _invlist_invert(invlist); } /* This code is copied from swatch_get() @@ -4190,6 +4000,7 @@ Perl__swash_to_invlist(pTHX_ SV* const swash) sv_free(other); /* through with it! */ } + SvREADONLY_on(invlist); return invlist; } @@ -4218,75 +4029,16 @@ Perl__get_swash_invlist(pTHX_ SV* const swash) return *ptr; } -/* -=for apidoc uvchr_to_utf8 - -Adds the UTF-8 representation of the Native code point C to the end -of the string C; C should have at least C free -bytes available. The return value is the pointer to the byte after the -end of the new character. In other words, - - d = uvchr_to_utf8(d, uv); - -is the recommended wide native character-aware way of saying - - *(d++) = uv; - -=cut -*/ - -/* On ASCII machines this is normally a macro but we want a - real function in case XS code wants it -*/ -U8 * -Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) -{ - PERL_ARGS_ASSERT_UVCHR_TO_UTF8; - - return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0); -} - -U8 * -Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) -{ - PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS; - - return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags); -} - -/* -=for apidoc utf8n_to_uvchr - -Returns the native character value of the first character in the string -C -which is assumed to be in UTF-8 encoding; C will be set to the -length, in bytes, of that character. - -C and C are the same as L(). - -=cut -*/ -/* On ASCII machines this is normally a macro but we want - a real function in case XS code wants it -*/ -UV -Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, -U32 flags) -{ - const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); - - PERL_ARGS_ASSERT_UTF8N_TO_UVCHR; - - return UNI_TO_NATIVE(uv); -} - bool Perl_check_utf8_print(pTHX_ 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 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 */ + * to make sure that this won't exceed the string's length. + * + * Code points above the platform's C will raise a deprecation + * warning, unless those are turned off. */ const U8* const e = s + len; bool ok = TRUE; @@ -4299,31 +4051,51 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print"); return FALSE; } - if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) { + if (UNLIKELY(isUTF8_POSSIBLY_PROBLEMATIC(*s))) { STRLEN char_len; - if (UTF8_IS_SUPER(s)) { - if (ckWARN_d(WARN_NON_UNICODE)) { - UV uv = utf8_to_uvchr_buf(s, e, &char_len); - Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), - "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv); - ok = FALSE; - } + if (UTF8_IS_SUPER(s, e)) { + if ( ckWARN_d(WARN_NON_UNICODE) + || ( ckWARN_d(WARN_DEPRECATED) +#if defined(UV_IS_QUAD) + /* 2**63 and up meet these conditions provided we have + * a 64-bit word. */ +# ifdef EBCDIC + && *s == 0xFE && e - s >= UTF8_MAXBYTES + && s[1] >= 0x49 +# else + && *s == 0xFF && e -s >= UTF8_MAXBYTES + && s[2] >= 0x88 +# endif +#else /* Below is 32-bit words */ + /* 2**31 and above meet these conditions on all EBCDIC + * pages recognized for 32-bit platforms */ +# ifdef EBCDIC + && *s == 0xFE && e - s >= UTF8_MAXBYTES + && s[6] >= 0x43 +# else + && *s >= 0xFE +# endif +#endif + )) { + /* A side effect of this function will be to warn */ + (void) utf8n_to_uvchr(s, e - s, &char_len, UTF8_WARN_SUPER); + ok = FALSE; + } } - else if (UTF8_IS_SURROGATE(s)) { + else if (UTF8_IS_SURROGATE(s, e)) { if (ckWARN_d(WARN_SURROGATE)) { + /* This has a different warning than the one the called + * function would output, so can't just call it, unlike we + * do for the non-chars and above-unicodes */ UV uv = utf8_to_uvchr_buf(s, e, &char_len); Perl_warner(aTHX_ packWARN(WARN_SURROGATE), "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv); ok = FALSE; } } - else if - ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s)) - && (ckWARN_d(WARN_NONCHAR))) - { - UV uv = utf8_to_uvchr_buf(s, e, &char_len); - Perl_warner(aTHX_ packWARN(WARN_NONCHAR), - "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv); + else if ((UTF8_IS_NONCHAR(s, e)) && (ckWARN_d(WARN_NONCHAR))) { + /* A side effect of this function will be to warn */ + (void) utf8n_to_uvchr(s, e - s, &char_len, UTF8_WARN_NONCHAR); ok = FALSE; } } @@ -4338,17 +4110,19 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) Build to the scalar C a displayable version of the string C, length C, the displayable version being at most C bytes long -(if longer, the rest is truncated and "..." will be appended). +(if longer, the rest is truncated and C<"..."> will be appended). -The C argument can have UNI_DISPLAY_ISPRINT set to display -isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH -to display the \\[nrfta\\] as the backslashed versions (like '\n') -(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\). -UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both -UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on. +The C argument can have C set to display +Cable characters as themselves, C +to display the C<\\[nrfta\\]> as the backslashed versions (like C<"\n">) +(C is preferred over C for C<"\\">). +C (and its alias C) have both +C and C turned on. The pointer to the PV of the C is returned. +See also L. + =cut */ char * Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags) @@ -4428,9 +4202,12 @@ The pointer to the PV of the C is returned. char * Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags) { + const char * const ptr = + isREGEXP(ssv) ? RX_WRAPPED((REGEXP*)ssv) : SvPVX_const(ssv); + PERL_ARGS_ASSERT_SV_UNI_DISPLAY; - return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv), + return Perl_pv_uni_display(aTHX_ dsv, (const U8*)ptr, SvCUR(ssv), pvlim, flags); } @@ -4451,7 +4228,7 @@ scan will not be considered to be a match unless the goal is reached, and scanning won't continue past that goal. Correspondingly for C with respect to C. -If C is non-NULL and the pointer it points to is not NULL, that pointer is +If C is non-C and the pointer it points to is not C, that pointer is considered an end pointer to the position 1 byte past the maximum point in C beyond which scanning will not continue under any circumstances. (This routine assumes that UTF-8 encoded input strings are not malformed; @@ -4468,7 +4245,7 @@ reached for a successful match. Also, if the fold of a character is multiple characters, all of them must be matched (see tr21 reference below for 'folding'). -Upon a successful match, if C is non-NULL, +Upon a successful match, if C is non-C, it will be set to point to the beginning of the I character of C beyond what was matched. Correspondingly for C and C. @@ -4483,18 +4260,25 @@ L (Case Mappings). * 0 for as-documented above * FOLDEQ_UTF8_NOMIX_ASCII meaning that if a non-ASCII character folds to an ASCII one, to not match - * FOLDEQ_UTF8_LOCALE meaning that locale rules are to be used for code - * 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. + * FOLDEQ_LOCALE is set iff the rules from the current underlying + * locale are to be used. + * FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this + * routine. This allows that step to be skipped. + * Currently, this requires s1 to be encoded as UTF-8 + * (u1 must be true), which is asserted for. + * FOLDEQ_S1_FOLDS_SANE With either NOMIX_ASCII or LOCALE, no folds may + * cross certain boundaries. Hence, the caller should + * let this function do the folding instead of + * pre-folding. This code contains an assertion to + * that effect. However, if the caller knows what + * it's doing, it can pass this flag to indicate that, + * and the assertion is skipped. + * FOLDEQ_S2_ALREADY_FOLDED Similarly. + * FOLDEQ_S2_FOLDS_SANE */ 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 */ @@ -4506,13 +4290,34 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const c STRLEN n1 = 0, n2 = 0; /* Number of bytes in current char */ U8 foldbuf1[UTF8_MAXBYTES_CASE+1]; U8 foldbuf2[UTF8_MAXBYTES_CASE+1]; + U8 flags_for_folder = FOLD_FLAGS_FULL; 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)))); + assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_LOCALE)) + && (((flags & FOLDEQ_S1_ALREADY_FOLDED) + && !(flags & FOLDEQ_S1_FOLDS_SANE)) + || ((flags & FOLDEQ_S2_ALREADY_FOLDED) + && !(flags & FOLDEQ_S2_FOLDS_SANE))))); + /* The algorithm is to trial the folds without regard to the flags on + * the first line of the above assert(), and then see if the result + * violates them. This means that the inputs can't be pre-folded to a + * violating result, hence the assert. This could be changed, with the + * addition of extra tests here for the already-folded case, which would + * slow it down. That cost is more than any possible gain for when these + * flags are specified, as the flags indicate /il or /iaa matching which + * is less common than /iu, and I (khw) also believe that real-world /il + * and /iaa matches are most likely to involve code points 0-255, and this + * function only under rare conditions gets called for 0-255. */ + + if (flags & FOLDEQ_LOCALE) { + if (IN_UTF8_CTYPE_LOCALE) { + flags &= ~FOLDEQ_LOCALE; + } + else { + flags_for_folder |= FOLD_FLAGS_LOCALE; + } + } if (pe1) { e1 = *(U8**)pe1; @@ -4563,110 +4368,65 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const c while (p1 < e1 && p2 < e2) { /* If at the beginning of a new character in s1, get its fold to use - * and the length of the fold. (exception: locale rules just get the - * character to a single byte) */ + * and the length of the fold. */ if (n1 == 0) { if (flags & FOLDEQ_S1_ALREADY_FOLDED) { f1 = (U8 *) p1; + assert(u1); n1 = UTF8SKIP(f1); } 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))) - { - /* 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 */ - - /* 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 if (u1) { - to_utf8_fold(p1, foldbuf1, &n1); - } - else { /* Not utf8, get utf8 fold */ - to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1); - } - f1 = foldbuf1; - } + if (isASCII(*p1) && ! (flags & FOLDEQ_LOCALE)) { + + /* We have to forbid mixing ASCII with non-ASCII if the + * flags so indicate. And, we can short circuit having to + * call the general functions for this common ASCII case, + * all of whose non-locale folds are also ASCII, and hence + * UTF-8 invariants, so the UTF8ness of the strings is not + * relevant. */ + if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) { + return 0; + } + n1 = 1; + *foldbuf1 = toFOLD(*p1); + } + else if (u1) { + _to_utf8_fold_flags(p1, foldbuf1, &n1, flags_for_folder); + } + else { /* Not UTF-8, get UTF-8 fold */ + _to_uni_fold_flags(*p1, foldbuf1, &n1, flags_for_folder); + } + f1 = foldbuf1; + } } if (n2 == 0) { /* Same for s2 */ if (flags & FOLDEQ_S2_ALREADY_FOLDED) { f2 = (U8 *) p2; + assert(u2); n2 = UTF8SKIP(f2); } else { - 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))) - { - 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 if (isASCII(*p2)) { - if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) { - return 0; - } - n2 = 1; - *foldbuf2 = toLOWER(*p2); - } - else if (u2) { - to_utf8_fold(p2, foldbuf2, &n2); - } - else { - to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2); - } - f2 = foldbuf2; + if (isASCII(*p2) && ! (flags & FOLDEQ_LOCALE)) { + if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) { + return 0; + } + n2 = 1; + *foldbuf2 = toFOLD(*p2); + } + else if (u2) { + _to_utf8_fold_flags(p2, foldbuf2, &n2, flags_for_folder); + } + else { + _to_uni_fold_flags(*p2, foldbuf2, &n2, flags_for_folder); + } + f2 = foldbuf2; } } /* Here f1 and f2 point to the beginning of the strings to compare. * These strings are the folds of the next character from each input - * string, stored in utf8. */ + * string, stored in UTF-8. */ /* While there is more to look for in both folds, see if they * continue to match */ @@ -4715,12 +4475,66 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const c return 1; } +/* 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 */ + +U8 * +Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv) +{ + PERL_ARGS_ASSERT_UVUNI_TO_UTF8; + + return Perl_uvoffuni_to_utf8_flags(aTHX_ d, uv, 0); +} + +/* +=for apidoc utf8n_to_uvuni + +Instead use L, or rarely, L. + +This function was useful for code that wanted to handle both EBCDIC and +ASCII platforms with Unicode properties, but starting in Perl v5.20, the +distinctions between the platforms have mostly been made invisible to most +code, so this function is quite unlikely to be what you want. If you do need +this precise functionality, use instead +C> +or C>. + +=cut +*/ + +UV +Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) +{ + PERL_ARGS_ASSERT_UTF8N_TO_UVUNI; + + return NATIVE_TO_UNI(utf8n_to_uvchr(s, curlen, retlen, flags)); +} + +/* +=for apidoc uvuni_to_utf8_flags + +Instead you almost certainly want to use L or +L. + +This function is a deprecated synonym for L, +which itself, while not deprecated, should be used only in isolated +circumstances. These functions were useful for code that wanted to handle +both EBCDIC and ASCII platforms with Unicode properties, but starting in Perl +v5.20, the distinctions between the platforms have mostly been made invisible +to most code, so this function is quite unlikely to be what you want. + +=cut +*/ + +U8 * +Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) +{ + PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS; + + return uvoffuni_to_utf8_flags(d, uv, flags); +} + /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */