X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/148f39b7de6eae9ddd59e0b0aff691d6abea7aca..b3599c2e40dc16eb21fd9f39307cf8a4bb42f6d3:/utf8.c diff --git a/utf8.c b/utf8.c index 264ddb7..1cb3f6d 100644 --- a/utf8.c +++ b/utf8.c @@ -31,8 +31,7 @@ #include "EXTERN.h" #define PERL_IN_UTF8_C #include "perl.h" -#include "inline_invlist.c" -#include "charclass_invlists.h" +#include "invlist_inline.h" static const char unees[] = "Malformed UTF-8 character (unexpected end of string)"; @@ -49,12 +48,15 @@ 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, (which means if you use this option, that C can't have embedded C characters and has to @@ -66,12 +68,12 @@ See also L(), L(), and L>. +For details, see the description for L. =cut */ @@ -107,8 +109,14 @@ Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) return d; } +#ifdef EBCDIC + /* Not representable in UTF-EBCDIC */ + flags |= UNICODE_DISALLOW_FE_FF; +#endif + /* The first problematic code point is the first surrogate */ - if (uv >= UNICODE_SURROGATE_FIRST + if ( flags /* It's common to turn off all these */ + && uv >= UNICODE_SURROGATE_FIRST && ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { if (UNICODE_IS_SURROGATE(uv)) { @@ -130,13 +138,17 @@ Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) if (flags & UNICODE_DISALLOW_SUPER || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF))) { +#ifdef EBCDIC + Perl_die(aTHX_ "Can't represent character for Ox%"UVXf" on this platform", uv); + NOT_REACHED; /* NOTREACHED */ +#endif 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", + "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv); } if (flags & UNICODE_DISALLOW_NONCHAR) { @@ -229,7 +241,7 @@ Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) =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 (up to +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, @@ -258,7 +270,7 @@ Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) =for apidoc uvchr_to_utf8_flags 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 +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, @@ -276,23 +288,23 @@ 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 C is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set, +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 -UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL. +C is set, the function will fail and return NULL. If both flags are set, the function will both warn and return NULL. -The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags +The C and C flags affect how the function handles a Unicode non-character. And likewise, the -UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags affect the handling of +C and C 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. +code points are accepted, by the C and +C flags. -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. +And finally, the flag C selects all four of +the above WARN flags; and C selects all +four DISALLOW flags. =cut */ @@ -307,22 +319,6 @@ Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) } /* -=for apidoc is_utf8_char_buf - -This is identical to the macro L. - -=cut */ - -STRLEN -Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end) -{ - - PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF; - - return isUTF8_CHAR(buf, buf_end); -} - -/* =for apidoc is_utf8_string Returns true if the first C bytes of string C form a valid @@ -331,7 +327,7 @@ 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 */ @@ -435,13 +431,13 @@ 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 C -character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as +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 C; if not, the input had an error. @@ -450,18 +446,18 @@ 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.) +C 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 @@ -472,11 +468,11 @@ 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 +byte containing 0xFE or 0xFF. The C 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, +(Of course C will treat all above-Unicode code points, including these, as malformations.) -Similarly, UTF8_WARN_FE_FF acts just like +Similarly, C acts just like the other WARN flags, but applies just to these code points. All other code points corresponding to Unicode characters, including private @@ -489,7 +485,6 @@ warn. UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { - dVAR; const U8 * const s0 = s; U8 overflow_byte = '\0'; /* Save byte in case of overflow */ U8 * send; @@ -748,7 +743,7 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == 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)); + 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) { @@ -795,13 +790,13 @@ Perl_utf8n_to_uvchr(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) @@ -809,7 +804,7 @@ disallowed: return 0; } -do_warn: + do_warn: if (pack_warn) { /* was initialized to 0, and changed only if warnings are to be raised. */ @@ -837,9 +832,9 @@ 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 returned. @@ -869,6 +864,7 @@ Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) UV uv = *s; PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR; + PERL_UNUSED_CONTEXT; if (retlen) { *retlen = expectlen; @@ -946,7 +942,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; @@ -1009,11 +1004,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. */ @@ -1057,8 +1051,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)) { @@ -1066,7 +1058,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 = TWO_BYTE_UTF8_TO_NATIVE(c, c1); + c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1); } else { Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Malformed UTF-8 character " @@ -1123,6 +1115,7 @@ Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) U8 *d; PERL_ARGS_ASSERT_UTF8_TO_BYTES; + PERL_UNUSED_CONTEXT; /* ensure valid UTF-8 and chars < 256 before updating string */ while (s < send) { @@ -1141,7 +1134,7 @@ Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) U8 c = *s++; if (! UTF8_IS_INVARIANT(c)) { /* Then it is two-byte encoded */ - c = TWO_BYTE_UTF8_TO_NATIVE(c, *s); + c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s); s++; } *d++ = c; @@ -1160,7 +1153,7 @@ 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 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 */ @@ -1174,7 +1167,6 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) I32 count = 0; PERL_ARGS_ASSERT_BYTES_FROM_UTF8; - PERL_UNUSED_CONTEXT; if (!*is_utf8) return (U8 *)start; @@ -1199,7 +1191,7 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) U8 c = *s++; if (! UTF8_IS_INVARIANT(c)) { /* Then it is two-byte encoded */ - c = TWO_BYTE_UTF8_TO_NATIVE(c, *s); + c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s); s++; } *d++ = c; @@ -1286,19 +1278,26 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) #define LAST_HIGH_SURROGATE 0xDBFF #define FIRST_LOW_SURROGATE 0xDC00 #define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST - if (uv >= FIRST_HIGH_SURROGATE && uv <= LAST_HIGH_SURROGATE) { - if (p >= pend) { - Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); - } else { + + /* 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 < FIRST_LOW_SURROGATE || low > LAST_LOW_SURROGATE) + if ( UNLIKELY(low < FIRST_LOW_SURROGATE) + || UNLIKELY(low > LAST_LOW_SURROGATE)) + { Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); + } + p += 2; uv = ((uv - FIRST_HIGH_SURROGATE) << 10) + (low - FIRST_LOW_SURROGATE) + 0x10000; } - } else if (uv >= FIRST_LOW_SURROGATE && uv <= LAST_LOW_SURROGATE) { - Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } #ifdef EBCDIC d = uvoffuni_to_utf8_flags(d, uv, 0); @@ -1359,7 +1358,6 @@ Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c) bool Perl__is_utf8_idstart(pTHX_ const U8 *p) { - dVAR; PERL_ARGS_ASSERT__IS_UTF8_IDSTART; if (*p == '_') @@ -1387,7 +1385,7 @@ 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 */ @@ -1416,15 +1414,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); - /* NOTREACHED */ - assert(0); + NOT_REACHED; /* NOTREACHED */ } } @@ -1455,8 +1456,6 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_ UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - /* Convert the Unicode character whose ordinal is 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 @@ -1478,8 +1477,6 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - PERL_ARGS_ASSERT_TO_UNI_TITLE; if (c < 256) { @@ -1491,10 +1488,10 @@ Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) } STATIC U8 -S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp) +S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp) { /* We have the latin1-range values compiled into the core, so just use - * those, converting the result to utf8. Since the result is always just + * 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); @@ -1505,8 +1502,10 @@ S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp) *lenp = 1; } else { - *p = UTF8_TWO_BYTE_HI(converted); - *(p+1) = UTF8_TWO_BYTE_LO(converted); + /* Result is known to always be < 256, so can use the EIGHT_BIT + * macros */ + *p = UTF8_EIGHT_BIT_HI(converted); + *(p+1) = UTF8_EIGHT_BIT_LO(converted); *lenp = 2; } } @@ -1516,8 +1515,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) { @@ -1541,12 +1538,16 @@ Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int f UV converted; PERL_ARGS_ASSERT__TO_FOLD_LATIN1; + PERL_UNUSED_CONTEXT; assert (! (flags & FOLD_FLAGS_LOCALE)); if (c == MICRO_SIGN) { converted = GREEK_SMALL_LETTER_MU; } +#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) && c == LATIN_SMALL_LETTER_SHARP_S) { /* If can't cross 127/128 boundary, can't return "ss"; instead return @@ -1565,6 +1566,7 @@ Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int f return 's'; } } +#endif else { /* In this range the fold of all other characters is their lower case */ converted = toLOWER_LATIN1(c); @@ -1597,22 +1599,23 @@ Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags) PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS; - /* Tread a UTF-8 locale as not being in locale at all */ - if (IN_UTF8_CTYPE_LOCALE) { - flags &= ~FOLD_FLAGS_LOCALE; + 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, + return _to_fold_latin1((U8) c, p, lenp, flags & (FOLD_FLAGS_FULL | 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 */ + /* 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); @@ -1620,6 +1623,8 @@ Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags) else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with the special flags. */ U8 utf8_c[UTF8_MAXBYTES + 1]; + + needs_full_generality: uvchr_to_utf8(utf8_c, c); return _to_utf8_fold_flags(utf8_c, p, lenp, flags); } @@ -1642,8 +1647,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, * have been checked before this call for mal-formedness enough to assure * that. */ - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_COMMON; /* The API should have included a length for the UTF-8 character in

, @@ -1679,8 +1682,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, bool Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_FOO; assert(classnum < _FIRST_NON_SWASH_CC); @@ -1694,7 +1695,6 @@ Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p) bool Perl__is_utf8_perl_idstart(pTHX_ const U8 *p) { - dVAR; SV* invlist = NULL; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART; @@ -1702,14 +1702,12 @@ Perl__is_utf8_perl_idstart(pTHX_ const U8 *p) if (! PL_utf8_perl_idstart) { invlist = _new_invlist_C_array(_Perl_IDStart_invlist); } - return is_utf8_common(p, &PL_utf8_perl_idstart, "", invlist); + return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart", invlist); } bool Perl__is_utf8_xidstart(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_XIDSTART; if (*p == '_') @@ -1720,7 +1718,6 @@ Perl__is_utf8_xidstart(pTHX_ const U8 *p) bool Perl__is_utf8_perl_idcont(pTHX_ const U8 *p) { - dVAR; SV* invlist = NULL; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT; @@ -1728,14 +1725,12 @@ Perl__is_utf8_perl_idcont(pTHX_ const U8 *p) if (! PL_utf8_perl_idcont) { invlist = _new_invlist_C_array(_Perl_IDCont_invlist); } - return is_utf8_common(p, &PL_utf8_perl_idcont, "", invlist); + return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont", invlist); } 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", NULL); @@ -1744,8 +1739,6 @@ Perl__is_utf8_idcont(pTHX_ const U8 *p) 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", NULL); @@ -1754,8 +1747,6 @@ Perl__is_utf8_xidcont(pTHX_ const U8 *p) bool Perl__is_utf8_mark(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_MARK; return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL); @@ -1775,7 +1766,7 @@ of the result. 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. C (usually, +and loaded by C, using F. C (usually, but not always, a multicharacter mapping), is tried first. C is a string, normally C or C<"">. C means to not use @@ -1783,8 +1774,8 @@ 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">. -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>. =cut */ @@ -1792,7 +1783,6 @@ UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) { - dVAR; STRLEN len = 0; const UV uv1 = valid_utf8_to_uvchr(p, NULL); @@ -1842,7 +1832,7 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, } if (hv - && (svp = hv_fetch(hv, (const char*)p, UNISKIP(uv1), FALSE)) + && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE)) && (*svp)) { const char *s; @@ -1858,7 +1848,7 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, } if (!len && *swashp) { - const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is utf8 */); + const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */); if (uv2) { /* It was "normal" (a single character mapping). */ @@ -1890,7 +1880,7 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, 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 + /* 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 @@ -1923,14 +1913,23 @@ S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* c 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; } @@ -1949,14 +1948,18 @@ Instead use L. UV Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS; - if (flags && IN_UTF8_CTYPE_LOCALE) { - flags = FALSE; + 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)) { @@ -1969,15 +1972,15 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - U8 c = TWO_BYTE_UTF8_TO_NATIVE(*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_NATIVE(*p, *(p+1)), + return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp, 'S'); } } - else { /* utf8, ord above 255 */ + else { /* UTF-8, ord above 255 */ result = CALL_UPPER_CASE(p, ustrp, lenp); if (flags) { @@ -1986,7 +1989,7 @@ Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags 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; @@ -2016,14 +2019,18 @@ Instead use L. UV Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS; - if (flags && IN_UTF8_CTYPE_LOCALE) { - flags = FALSE; + 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)) { @@ -2036,15 +2043,15 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - U8 c = TWO_BYTE_UTF8_TO_NATIVE(*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_NATIVE(*p, *(p+1)), + return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp, 's'); } } - else { /* utf8, ord above 255 */ + else { /* UTF-8, ord above 255 */ result = CALL_TITLE_CASE(p, ustrp, lenp); if (flags) { @@ -2053,7 +2060,7 @@ Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags 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; @@ -2084,12 +2091,16 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags { UV result; - dVAR; - PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS; - if (flags && IN_UTF8_CTYPE_LOCALE) { - flags = FALSE; + 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)) { @@ -2102,15 +2113,15 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags) { - U8 c = TWO_BYTE_UTF8_TO_NATIVE(*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_NATIVE(*p, *(p+1)), + return to_lower_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), ustrp, lenp); } } - else { /* utf8, ord above 255 */ + else { /* UTF-8, ord above 255 */ result = CALL_LOWER_CASE(p, ustrp, lenp); if (flags) { @@ -2120,7 +2131,7 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags 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; @@ -2154,8 +2165,6 @@ Instead use L. UV Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS; @@ -2165,8 +2174,14 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) assert(p != ustrp); /* Otherwise overwrites */ - if (flags & FOLD_FLAGS_LOCALE && IN_UTF8_CTYPE_LOCALE) { - flags &= ~FOLD_FLAGS_LOCALE; + 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)) { @@ -2180,41 +2195,79 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) } else if UTF8_IS_DOWNGRADEABLE_START(*p) { if (flags & FOLD_FLAGS_LOCALE) { - U8 c = TWO_BYTE_UTF8_TO_NATIVE(*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_NATIVE(*p, *(p+1)), + 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 */ + else { /* UTF-8, ord above 255 */ result = CALL_FOLD_CASE(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) == sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1 - && memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8, - sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1)) + 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 if (UTF8SKIP(p) == sizeof(LATIN_SMALL_LIGATURE_LONG_S_T) - 1 - && memEQ((char *) p, LATIN_SMALL_LIGATURE_LONG_S_T_UTF8, - sizeof(LATIN_SMALL_LIGATURE_LONG_S_T_UTF8) - 1)) + 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 + 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 + /* 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. */ @@ -2231,14 +2284,24 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) /* But in these instances, there is an alternative we can * return that is valid */ - if (original == LATIN_CAPITAL_LETTER_SHARP_S - || original == LATIN_SMALL_LETTER_SHARP_S) - { + 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; } @@ -2250,7 +2313,7 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) } } - /* 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; @@ -2282,6 +2345,18 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) *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: @@ -2305,6 +2380,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. @@ -2349,7 +2432,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * * 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 = @@ -2361,6 +2445,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, "")) { @@ -2384,17 +2472,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 @@ -2449,13 +2537,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)); - /* NOTREACHED */ - NOT_REACHED; + NOT_REACHED; /* NOTREACHED */ } } /* End of calling the module to find the swash */ @@ -2552,7 +2639,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 } @@ -2567,7 +2655,7 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m /* 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 well-formed utf8. If C is false, the string 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 @@ -2601,7 +2689,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) { - dVAR; HV *const hv = MUTABLE_HV(SvRV(swash)); U32 klen; U32 off; @@ -2637,7 +2724,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) else if (UTF8_IS_DOWNGRADEABLE_START(c)) { klen = 0; needents = 256; - off = TWO_BYTE_UTF8_TO_NATIVE(c, *(ptr + 1)); + off = EIGHT_BIT_UTF8_TO_NATIVE(c, *(ptr + 1)); } else { klen = UTF8SKIP(ptr) - 1; @@ -2679,7 +2766,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) } /* - * 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... @@ -3196,10 +3283,10 @@ 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 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. @@ -3213,7 +3300,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 @@ -3222,7 +3309,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; @@ -3267,8 +3371,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; @@ -3280,7 +3384,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), @@ -3365,7 +3469,24 @@ 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 */ @@ -3518,22 +3639,28 @@ Perl__swash_to_invlist(pTHX_ SV* const swash) lend = l + lcur; if (*l == 'V') { /* Inversion list format */ - char *after_strtol = (char *) lend; + const char *after_atou = (char *) lend; UV element0; UV* other_elements_ptr; /* The first number is a count of the rest */ l++; - elements = Strtoul((char *)l, &after_strtol, 10); + 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 { - l = (U8 *) after_strtol; + while (isSPACE(*l)) l++; + l = (U8 *) after_atou; /* Get the 0th element, which is needed to setup the inversion list */ - element0 = (UV) Strtoul((char *)l, &after_strtol, 10); - l = (U8 *) after_strtol; + while (isSPACE(*l)) l++; + 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--; @@ -3542,8 +3669,11 @@ Perl__swash_to_invlist(pTHX_ SV* const swash) if (l > lend) { Perl_croak(aTHX_ "panic: Expecting %"UVuf" more elements than available", elements); } - *other_elements_ptr++ = (UV) Strtoul((char *)l, &after_strtol, 10); - l = (U8 *) after_strtol; + while (isSPACE(*l)) l++; + 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; } } } @@ -3711,9 +3841,9 @@ 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 (UTF8_IS_SUPER(s, e)) { if (ckWARN_d(WARN_NON_UNICODE)) { UV uv = utf8_to_uvchr_buf(s, e, &char_len); Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), @@ -3721,7 +3851,7 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) ok = FALSE; } } - else if (UTF8_IS_SURROGATE(s)) { + else if (UTF8_IS_SURROGATE(s, e)) { if (ckWARN_d(WARN_SURROGATE)) { UV uv = utf8_to_uvchr_buf(s, e, &char_len); Perl_warner(aTHX_ packWARN(WARN_SURROGATE), @@ -3729,13 +3859,10 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) ok = FALSE; } } - else if - ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s)) - && (ckWARN_d(WARN_NONCHAR))) - { + else if ((UTF8_IS_NONCHAR(s, e)) && (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); + "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv); ok = FALSE; } } @@ -3750,17 +3877,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) @@ -3866,7 +3995,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; @@ -3883,7 +4012,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. @@ -3901,13 +4030,22 @@ L (Case Mappings). * 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. + * 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 */ @@ -3919,11 +4057,15 @@ 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; assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_LOCALE)) - && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED)))); + && (((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 @@ -3935,8 +4077,13 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const c * 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 (IN_UTF8_CTYPE_LOCALE) { - flags &= ~FOLDEQ_LOCALE; + if (flags & FOLDEQ_LOCALE) { + if (IN_UTF8_CTYPE_LOCALE) { + flags &= ~FOLDEQ_LOCALE; + } + else { + flags_for_folder |= FOLD_FLAGS_LOCALE; + } } if (pe1) { @@ -3988,104 +4135,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_LOCALE) - && (! u1 || ! UTF8_IS_ABOVE_LATIN1(*p1))) - { - /* There is no mixing of code points above and below 255. */ - if (u2 && UTF8_IS_ABOVE_LATIN1(*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_NATIVE(*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 = toFOLD(*p1); - } - else if (u1) { - to_utf8_fold(p1, foldbuf1, &n1); - } - else { /* Not utf8, get utf8 fold */ - to_uni_fold(*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_LOCALE) - && (! u2 || ! UTF8_IS_ABOVE_LATIN1(*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_ABOVE_LATIN1(*p1)) { - return 0; - } - if (! u2 || UTF8_IS_INVARIANT(*p2)) { - *foldbuf2 = *p2; - } - else { - *foldbuf2 = TWO_BYTE_UTF8_TO_NATIVE(*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 = toFOLD(*p2); - } - else if (u2) { - to_utf8_fold(p2, foldbuf2, &n2); - } - else { - to_uni_fold(*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 */ @@ -4174,7 +4282,7 @@ Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) =for apidoc uvuni_to_utf8_flags Instead you almost certainly want to use L or -L>. +L. This function is a deprecated synonym for L, which itself, while not deprecated, should be used only in isolated @@ -4195,11 +4303,5 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, 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: */