#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.
*/
/*
-=for apidoc is_ascii_string
+=for apidoc is_invariant_string
-Returns true if the first C<len> bytes of the string C<s> 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<len> bytes of the string C<s> 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<len> is 0, it will be calculated using C<strlen(s)>.
+If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
+use this option, that C<s> can't have embedded C<NUL> characters and has to
+have a terminating C<NUL> byte).
See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
*/
bool
-Perl_is_ascii_string(const U8 *s, STRLEN len)
+Perl_is_invariant_string(const U8 *s, STRLEN len)
{
const U8* const send = s + (len ? len : strlen((const char *)s));
const U8* x = s;
- PERL_ARGS_ASSERT_IS_ASCII_STRING;
+ PERL_ARGS_ASSERT_IS_INVARIANT_STRING;
for (; x < send; ++x) {
if (!UTF8_IS_INVARIANT(*x))
}
/*
-=for apidoc uvuni_to_utf8_flags
-
-Adds the UTF-8 representation of the Unicode code point C<uv> to the end
-of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
-bytes available. The return value is the pointer to the byte after the
-end of the new character. In other words,
-
- 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<Almost all code should use L</uvchr_to_utf8> or
+L</uvchr_to_utf8_flags>>.
-(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</uvchr_to_utf8_flags>.
-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<Almost all code should instead use L</uvchr_to_utf8>
-or L</uvchr_to_utf8_flags>>.
+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<flags> contains one or more of the
-following flags:
+ if (OFFUNI_IS_INVARIANT(uv)) {
+ *d++ = LATIN1_TO_NATIVE(uv);
+ return d;
+ }
-If C<uv> 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<len> bytes of string C<s> 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<uv> to the end
+of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
+C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
+the byte after the end of the new character. In other words,
- 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<IV_MAX> 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<buf>. C<buf_end> should point to one position beyond the end of the
-buffer. 0 is returned if C<buf> does not point to a complete, valid UTF-8
-encoded character.
+It is possible to forbid or warn on non-Unicode code points, or those that may
+be problematic by using L</uvchr_to_utf8_flags>.
-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<uv> to the end
+of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
+C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
+the byte after the end of the new character. In other words,
- 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<flags> is 0, this function accepts any UV as input, but very high code
+points (above C<IV_MAX> for the platform) will raise a deprecation warning.
+This is typically 0x7FFF_FFFF in a 32-bit word.
+
+Specifying C<flags> can further restrict what is allowed and not warned on, as
+follows:
+
+If C<uv> is a Unicode surrogate code point and C<UNICODE_WARN_SURROGATE> is set,
+the function will raise a warning, provided UTF8 warnings are enabled. If
+instead C<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.
+
+Similarly, the C<UNICODE_WARN_NONCHAR> and C<UNICODE_DISALLOW_NONCHAR> flags
+affect how the function handles a Unicode non-character.
+
+And likewise, the C<UNICODE_WARN_SUPER> and C<UNICODE_DISALLOW_SUPER> 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<UNICODE_WARN_ILLEGAL_INTERCHANGE> selects all three of
+the above WARN flags; and C<UNICODE_DISALLOW_ILLEGAL_INTERCHANGE> 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<UNICODE_WARN_ABOVE_31_BIT> and C<UNICODE_DISALLOW_ABOVE_31_BIT> flags. These
+are entirely independent from the deprecation warning for code points above
+C<IV_MAX>. 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<UNICODE_DISALLOW_ABOVE_31_BIT> flag will always be set on
+32-bit machines. (Of course C<UNICODE_DISALLOW_SUPER> will treat all
+above-Unicode code points, including these, as malformations; and
+C<UNICODE_WARN_SUPER> 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<UNICODE_WARN_ABOVE_31_BIT>
+and C<UNICODE_DISALLOW_ABOVE_31_BIT> 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</is_utf8_char_buf>
-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<len> bytes of string C<s> form a valid
UTF-8 string, false otherwise. If C<len> is 0, it will be calculated
-using C<strlen(s)> (which means if you use this option, that C<s> has to have a
-terminating NUL byte). Note that all characters being ASCII constitute 'a
-valid UTF-8 string'.
+using C<strlen(s)> (which means if you use this option, that C<s> can't have
+embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
+that all characters being ASCII constitute 'a valid UTF-8 string'.
-See also L</is_ascii_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
+See also L</is_invariant_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
=cut
*/
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;
{
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:
/*
-=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</utf8_to_uvchr_buf>() rather than call this directly.
Bottom level UTF-8 decode routine.
-Returns the code point value of the first character in the string C<s>,
+Returns the native code point value of the first character in the string C<s>,
which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
the length, in bytes, of that character.
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<UTF8_CHECK_ONLY> 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<retlen> to C<-1> (cast to C<STRLEN>) 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<NUL>
+character, and an error return (unless the C<UTF8_CHECK_ONLY> flag is set), as
in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
-first byte of C<s> is 0 as well. If so, the input was a NUL; if not, the input
-had an error.
+first byte of C<s> is 0 as well. If so, the input was a C<NUL>; 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<flags> contains
-UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
-malformations and handled as such. The flags UTF8_DISALLOW_SURROGATE,
-UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
-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<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, all three classes are treated as
+malformations and handled as such. The flags C<UTF8_DISALLOW_SURROGATE>,
+C<UTF8_DISALLOW_NONCHAR>, and C<UTF8_DISALLOW_SUPER> (meaning above the legal
+Unicode maximum) can be set to disallow these categories individually.
+
+The flags C<UTF8_WARN_ILLEGAL_INTERCHANGE>, C<UTF8_WARN_SURROGATE>,
+C<UTF8_WARN_NONCHAR>, and C<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.
(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<UTF8_CHECK_ONLY> is also specified.)
+
+It is now deprecated to have very high code points (above C<IV_MAX> 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<UTF8_WARN_ABOVE_31_BIT> and C<UTF8_DISALLOW_ABOVE_31_BIT> flags. These
+are entirely independent from the deprecation warning for code points above
+C<IV_MAX>. 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<UTF8_DISALLOW_ABOVE_31_BIT> flag will always be set on
+32-bit machines. (Of course C<UTF8_DISALLOW_SUPER> will treat all
+above-Unicode code points, including these, as malformations; and
+C<UTF8_WARN_SUPER> 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<UTF8_WARN_ABOVE_31_BIT>
+and C<UTF8_DISALLOW_ABOVE_31_BIT> 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</utf8_to_uvchr_buf>() 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;
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
* 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 */
/* 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 */
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 */
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
overflowed = TRUE;
overflow_byte = *s; /* Save for warning message's use */
}
-#endif
uv = UTF8_ACCUMULATE(uv, *s);
}
else {
}
}
-#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.
* 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;
}
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;
}
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;
}
* to return it */
}
- return uv;
+ return UNI_TO_NATIVE(uv);
/* There are three cases which get to beyond this point. In all 3 cases:
* <sv> if not null points to a string to print as a warning.
* is the label <malformed>.
*/
-malformed:
+ malformed:
if (sv && ckWARN_d(WARN_UTF8)) {
pack_warn = packWARN(WARN_UTF8);
}
-disallowed:
+ disallowed:
if (flags & UTF8_CHECK_ONLY) {
if (retlen)
return 0;
}
-do_warn:
+ do_warn:
if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
if warnings are to be raised. */
If C<s> 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<retlen> isn't
-NULL) to -1. If those warnings are off, the computed value, if well-defined
+C<NULL>) to -1. If those warnings are off, the computed value, if well-defined
(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
-C<*retlen> is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is
+C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
the next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is
+See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
returned.
+Code points above the platform's C<IV_MAX> will raise a deprecation warning,
+unless those are turned off.
+
=cut
*/
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,
/* Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
* there are no malformations in the input UTF-8 string C<s>. surrogates,
- * non-character code points, and non-Unicode code points are allowed. 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<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-Some, but not all, UTF-8 malformations are detected, and in fact, some
-malformed input could cause reading beyond the end of the input buffer, which
-is why this function is deprecated. Use L</utf8_to_uvchr_buf> instead.
-
-If C<s> points to one of the detected malformations, and UTF8 warnings are
-enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
-NULL) to -1. If those warnings are off, the computed value if well-defined (or
-the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
-is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
-next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvuni> 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<s> which
-is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
-C<retlen> 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<s> 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<retlen> isn't
-NULL) to -1. If those warnings are off, the computed value if well-defined (or
-the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
-is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
-next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvuni> 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</utf8_to_uvuni_buf>(), but should only be called when it is known that
- * there are no malformations in the input UTF-8 string C<s>. Surrogates,
- * non-character code points, and non-Unicode code points are allowed */
-
-UV
-Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
-{
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 */
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);
* 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<s>
-which is assumed to be in UTF-8 encoding; C<retlen> 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<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>> 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</utf8_to_uvuni_buf> instead.
+Returns the Unicode (not-native) code point of the first character in the
+string C<s> which
+is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
+C<retlen> will be set to the length, in bytes, of that character.
-If C<s> points to one of the detected malformations, and UTF8 warnings are
-enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
+If C<s> 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<retlen> isn't
NULL) to -1. If those warnings are off, the computed value if well-defined (or
the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
next possible position in C<s> that could begin a non-malformed character.
-See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
+See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
+
+Code points above the platform's C<IV_MAX> 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));
}
/*
STRLEN
Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
{
- dVAR;
STRLEN len = 0;
PERL_ARGS_ASSERT_UTF8_LENGTH;
*/
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. */
=for apidoc bytes_cmp_utf8
Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
-sequence of characters (stored as UTF-8) in C<u>, C<ulen>. Returns 0 if they are
+sequence of characters (stored as UTF-8)
+in C<u>, C<ulen>. 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
PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
- PERL_UNUSED_CONTEXT;
-
while (b < bend && u < uend) {
U8 c = *u++;
if (!UTF8_IS_INVARIANT(c)) {
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 "
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;
Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
the newly-created string, and updates C<len> to contain the new
length. Returns the original string if no conversion occurs, C<len>
-is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
+is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
0 if C<s> 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
*/
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;
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;
}
Returns a pointer to the newly-created string, and sets C<len> to
reflect the new length in bytes.
-A NUL character will be written after the end of the string.
+A C<NUL> 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),
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;
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);
*d++ = (U8)(( uv & 0x3f) | 0x80);
continue;
}
+#endif
}
*newlen = d - dstart;
return d;
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
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 */
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;
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 */
}
}
* 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 <c> to its uppercase
* version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
* Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
}
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) {
}
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 <p> 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;
}
}
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TO_UNI_LOWER;
if (c < 256) {
}
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(), <flags> is TRUE if to use full case
- * folding */
+ /* Corresponds to to_lower_latin1(); <flags> 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;
}
}
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
* <flags> 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 <p> is in the swash indicated by <swashname>. <swash>
* contains a pointer to where the swash indicated by <swashname>
* is to be stored; which this routine will do, so that future calls will
- * look at <*swash> and only generate a swash if it is not null
+ * look at <*swash> and only generate a swash if it is not null. <invlist>
+ * 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 <p> is enough to
* contain all the bytes that comprise the character. Thus, <*p> should
* have been checked before this call for mal-formedness enough to assure
* that. */
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_COMMON;
/* The API should have included a length for the UTF-8 character in <p>,
* 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);
}
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;
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<p> contains the pointer to the UTF-8 string encoding
+Instead use the appropriate one of L</toUPPER_utf8>,
+L</toTITLE_utf8>,
+L</toLOWER_utf8>,
+or L</toFOLD_utf8>.
+
+C<p> contains the pointer to the UTF-8 string encoding
the character that is being converted. This routine assumes that the character
at C<p> is well-formed.
-The C<ustrp> is a pointer to the character buffer to put the
-conversion result to. The C<lenp> is a pointer to the length
+C<ustrp> is a pointer to the character buffer to put the
+conversion result to. C<lenp> is a pointer to the length
of the result.
-The C<swashp> is a pointer to the swash to use.
+C<swashp> is a pointer to the swash to use.
Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
-and loaded by SWASHNEW, using F<lib/utf8_heavy.pl>. The C<special> (usually,
+and loaded by C<SWASHNEW>, using F<lib/utf8_heavy.pl>. C<special> (usually,
but not always, a multicharacter mapping), is tried first.
-The C<special> is a string like "utf8::ToSpecLower", which means the
-hash %utf8::ToSpecLower. The access to the hash is through
-Perl_to_utf8_case().
+C<special> is a string, normally C<NULL> or C<"">. C<NULL> 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<normal> is a string like "ToLower" which means the swash
-%utf8::ToLower.
+C<normal> is a string like C<"ToLower"> which means the swash
+C<%utf8::ToLower>.
+
+Code points above the platform's C<IV_MAX> will raise a deprecation warning,
+unless those are turned off.
=cut */
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;
}
}
/* 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);
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<perlfunc/lc> 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<perlfunc/lc> for
+ * why;
*
* p points to the original string whose case was changed; assumed
* by this routine to be well-formed
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 */
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;
}
/*
=for apidoc to_utf8_upper
-Convert the UTF-8 encoded character at C<p> to its uppercase version and
-store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. 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<p> is assumed by this routine to be well-formed.
+Instead use L</toUPPER_utf8>.
=cut */
/* Not currently externally documented, and subject to change:
- * <flags> is set iff locale semantics are to be used for code points < 256
- * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
- * were used in the calculation; otherwise unchanged. */
+ * <flags> 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);
}
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);
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<p> to its titlecase version and
-store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. Note
-that the C<ustrp> 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<p> is assumed by this routine to be well-formed.
+Instead use L</toTITLE_utf8>.
=cut */
/* Not currently externally documented, and subject to change:
- * <flags> is set iff locale semantics are to be used for code points < 256
- * Since titlecase is not defined in POSIX, uppercase is used instead
- * for these/
- * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
- * were used in the calculation; otherwise unchanged. */
+ * <flags> 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);
}
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);
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<p> to its lowercase version and
-store that in UTF-8 in ustrp and its length in bytes in C<lenp>. Note
-that the C<ustrp> 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<p> is assumed by this routine to be well-formed.
+Instead use L</toLOWER_utf8>.
=cut */
/* Not currently externally documented, and subject to change:
- * <flags> is set iff locale semantics are to be used for code points < 256
- * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
- * were used in the calculation; otherwise unchanged. */
+ * <flags> 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);
}
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);
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<p> to its foldcase version and
-store that in UTF-8 in C<ustrp> and its length in bytes in C<lenp>. Note
-that the C<ustrp> 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<p> is assumed by this routine to be well-formed.
+Instead use L</toFOLD_utf8>.
=cut */
/* Not currently externally documented, and subject to change,
* in <flags>
- * bit FOLD_FLAGS_LOCALE is set iff locale semantics are to be used for code
- * points < 256. Since foldcase is not defined in
- * POSIX, lowercase is used instead
+ * bit FOLD_FLAGS_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
- * <tainted_ptr> 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;
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 <p> */
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;
}
}
}
- /* 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:
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.
* Thus there are three possible inputs to find the swash: <name>,
* <listsv>, and <invlist>. At least one must be specified. The result
* will be the union of the specified ones, although <listsv>'s various
- * actions can intersect, etc. what <name> gives.
+ * actions can intersect, etc. what <name> gives. To avoid going out to
+ * disk at all, <invlist> should specify completely what the swash should
+ * have, and <listsv> should be &PL_sv_undef and <name> should be "".
*
* <invlist> is only valid for binary properties */
- dVAR;
+ PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
+
SV* retval = &PL_sv_undef;
HV* swash_hv = NULL;
const int invlist_swash_boundary =
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, "")) {
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
/* 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 */
/* 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)
{
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);
}
}
- return retval;
+ CORE_SWASH_INIT_RETURN(retval);
+#undef CORE_SWASH_INIT_RETURN
}
* (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<swash> for the first character
* of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
- * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
- * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
+ * assumed to be in well-formed UTF-8. If C<do_utf8> is false, the string C<ptr>
+ * is assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
*
* A "swash" is a hash which contains initially the keys/values set up by
* SWASHNEW. The purpose is to be able to completely represent a Unicode
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;
: 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...
/* 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);
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);
/* 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 */
*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;
}
else { /* Nothing following range min, should be single element with no
mapping expected */
- *max = *min;
if (wants_value) {
*val = 0;
if (typeto) {
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;
}
* 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.
*
* 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
* 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;
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;
/*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),
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) {
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");
} /* 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;
}
/* 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 */
/* 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;
}
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()
sv_free(other); /* through with it! */
}
+ SvREADONLY_on(invlist);
return invlist;
}
return *ptr;
}
-/*
-=for apidoc uvchr_to_utf8
-
-Adds the UTF-8 representation of the Native code point C<uv> to the end
-of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
-bytes available. The return value is the pointer to the byte after the
-end of the new character. In other words,
-
- 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<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-C<length> and C<flags> are the same as L</utf8n_to_uvuni>().
-
-=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<IV_MAX> will raise a deprecation
+ * warning, unless those are turned off. */
const U8* const e = s + len;
bool ok = TRUE;
"%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;
}
}
Build to the scalar C<dsv> a displayable version of the string C<spv>,
length C<len>, the displayable version being at most C<pvlim> 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<flags> 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<flags> argument can have C<UNI_DISPLAY_ISPRINT> set to display
+C<isPRINT()>able characters as themselves, C<UNI_DISPLAY_BACKSLASH>
+to display the C<\\[nrfta\\]> as the backslashed versions (like C<"\n">)
+(C<UNI_DISPLAY_BACKSLASH> is preferred over C<UNI_DISPLAY_ISPRINT> for C<"\\">).
+C<UNI_DISPLAY_QQ> (and its alias C<UNI_DISPLAY_REGEX>) have both
+C<UNI_DISPLAY_BACKSLASH> and C<UNI_DISPLAY_ISPRINT> turned on.
The pointer to the PV of the C<dsv> is returned.
+See also L</sv_uni_display>.
+
=cut */
char *
Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
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);
}
scanning won't continue past that goal. Correspondingly for C<l2> with respect to
C<s2>.
-If C<pe1> is non-NULL and the pointer it points to is not NULL, that pointer is
+If C<pe1> is non-C<NULL> and the pointer it points to is not C<NULL>, that pointer is
considered an end pointer to the position 1 byte past the maximum point
in C<s1> beyond which scanning will not continue under any circumstances.
(This routine assumes that UTF-8 encoded input strings are not malformed;
characters, all of them must be matched (see tr21 reference below for
'folding').
-Upon a successful match, if C<pe1> is non-NULL,
+Upon a successful match, if C<pe1> is non-C<NULL>,
it will be set to point to the beginning of the I<next> character of C<s1>
beyond what was matched. Correspondingly for C<pe2> and C<s2>.
* 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 */
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;
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 */
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</utf8_to_uvchr_buf>, or rarely, L</utf8n_to_uvchr>.
+
+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<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>>
+or C<L<NATIVE_TO_UNI(utf8n_to_uvchr(...))|/utf8n_to_uvchr>>.
+
+=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</uvchr_to_utf8> or
+L</uvchr_to_utf8_flags>.
+
+This function is a deprecated synonym for L</uvoffuni_to_utf8_flags>,
+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:
*/
https://perl5.git.perl.org / perl5.git / blobdiff