#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
-
static const char unees[] =
"Malformed UTF-8 character (unexpected end of string)";
}
/*
-=for apidoc uvuni_to_utf8_flags
-
-Adds the UTF-8 representation of the 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,
+=for apidoc uvoffuni_to_utf8_flags
- d = uvuni_to_utf8_flags(d, uv, flags);
+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>>.
-or, in most cases,
-
- d = uvuni_to_utf8(d, uv);
-
-(which is equivalent to)
-
- d = uvuni_to_utf8_flags(d, uv, 0);
-
-This is the recommended Unicode-aware way of saying
-
- *(d++) = uv;
-
-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 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.
-
-The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags correspondingly
-affect how the function handles a Unicode non-character. And, likewise for the
-UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, and 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.
-
-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.
+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.
+For details, see the description for L</uvchr_to_utf8_flags>>.
=cut
*/
U8 *
-Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
{
- PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
+ PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS;
+
+ if (UNI_IS_INVARIANT(uv)) {
+ *d++ = (U8) LATIN1_TO_NATIVE(uv);
+ return d;
+ }
/* The first problematic code point is the first surrogate */
if (uv >= UNICODE_SURROGATE_FIRST
}
}
}
- 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-- = (U8) 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 = (U8) I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
return d+len;
}
#else /* Non loop style */
*d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
-#ifdef HAS_QUAD
+#ifdef UTF8_QUAD_MAX
if (uv < UTF8_QUAD_MAX)
#endif
{
*d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
-#ifdef HAS_QUAD
+#ifdef UTF8_QUAD_MAX
{
*d++ = 0xff; /* Can't match U+FFFE! */
*d++ = 0x80; /* 6 Reserved bits */
return d;
}
#endif
-#endif /* Loop style */
+#endif /* Non loop style */
+}
+/*
+=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;
+
+This function accepts any UV as input. To forbid or warn on non-Unicode code
+points, or those that may be problematic, see L</uvchr_to_utf8_flags>.
+
+=cut
+*/
+
+/* This is also a macro */
+PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
+
+U8 *
+Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
+{
+ return uvchr_to_utf8(d, uv);
+}
+
+/*
+=for apidoc uvchr_to_utf8_flags
+
+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_flags(d, uv, flags);
+
+or, in most cases,
+
+ d = uvchr_to_utf8_flags(d, uv, 0);
+
+This is the Unicode-aware way of saying
+
+ *(d++) = uv;
+
+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 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.
+
+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.
+
+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.
+
+=cut
+*/
+
+/* This is also a macro */
+PERL_CALLCONV U8* Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags);
+
+U8 *
+Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+{
+ return uvchr_to_utf8_flags(d, uv, flags);
}
/*
Tests if the first C<len> bytes of string C<s> form a valid UTF-8
-character. Note that an INVARIANT (i.e. ASCII) character is a valid
-UTF-8 character. The number of bytes in the UTF-8 character
+character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a
+valid UTF-8 character. The number of bytes in the UTF-8 character
will be returned if it is valid, otherwise 0.
This is the "slow" version as opposed to the "fast" version which is
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" (the infamous 'v-strings') will encode into
+the "Perl extended UTF-8" (e.g, the infamous 'v-strings') will encode into
five bytes or more.
=cut */
-STATIC STRLEN
+PERL_STATIC_INLINE STRLEN
S_is_utf8_char_slow(const U8 *s, const STRLEN len)
{
dTHX; /* The function called below requires thread context */
PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
- utf8n_to_uvuni(s, len, &actual_len, UTF8_CHECK_ONLY);
+ utf8n_to_uvchr(s, len, &actual_len, UTF8_CHECK_ONLY);
return (actual_len == (STRLEN) -1) ? 0 : actual_len;
}
len = UTF8SKIP(buf);
}
-#ifdef IS_UTF8_CHAR
if (IS_UTF8_CHAR_FAST(len))
return IS_UTF8_CHAR(buf, len) ? len : 0;
-#endif /* #ifdef IS_UTF8_CHAR */
return is_utf8_char_slow(buf, len);
}
/*
=for apidoc is_utf8_char
-DEPRECATED!
-
Tests if some arbitrary number of bytes begins in a valid UTF-8
character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
character is a valid UTF-8 character. The actual number of bytes in the UTF-8
/*
-=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.
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;
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 */
#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;
}
}
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.
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.
+NULL) to -1. If those warnings are off, the computed value, if well-defined
+(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
+C<*retlen> is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is
+the next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
+returned.
=cut
*/
UV
Perl_utf8_to_uvchr_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);
+ UV expectlen = UTF8SKIP(s);
+ const U8* send = s + expectlen;
+ UV uv = *s;
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
+ if (retlen) {
+ *retlen = expectlen;
+ }
+
+ /* An invariant is trivially returned */
+ if (expectlen == 1) {
+ 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);
+
+ /* Now, loop through the remaining bytes, accumulating each into the
+ * 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);
+ }
+
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.
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.
=cut
*/
/*
=for apidoc utf8_to_uvuni_buf
-Returns the Unicode code point of the first character in the string C<s> which
+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.
+
+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.
-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.
+See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
=cut
*/
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);
+ return NATIVE_TO_UNI(Perl_utf8n_to_uvchr(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
+/* DEPRECATED!
+ * Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
* there are no malformations in the input UTF-8 string C<s>. Surrogates,
* non-character code points, and non-Unicode code points are allowed */
UV
Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
{
- UV expectlen = UTF8SKIP(s);
- const U8* send = s + expectlen;
- UV uv = NATIVE_TO_UTF(*s);
-
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
- if (retlen) {
- *retlen = expectlen;
- }
-
- /* An invariant is trivially returned */
- if (expectlen == 1) {
- return uv;
- }
-
- /* 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);
-
- /* Now, loop through the remaining bytes, accumulating each into the
- * 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);
- }
-
- return uv;
+ return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
}
/*
=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.
-This function should only be used when the returned UV is considered
-an index into the Unicode semantic tables (e.g. swashes).
-
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.
+is one reason why this function is deprecated. The other is that only in
+extremely limited circumstances should the Unicode versus native code point be
+of any interest to you. See L</utf8_to_uvuni_buf> for alternatives.
If C<s> points to one of the detected malformations, and UTF8 warnings are
enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
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.
=cut
*/
{
PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
- return valid_utf8_to_uvuni(s, retlen);
+ return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
}
/*
if (u < uend) {
U8 c1 = *u++;
if (UTF8_IS_CONTINUATION(c1)) {
- c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1));
+ c = TWO_BYTE_UTF8_TO_NATIVE(c, c1);
} else {
Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
"Malformed UTF-8 character "
/* 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 = TWO_BYTE_UTF8_TO_NATIVE(c, *s);
+ s++;
+ }
+ *d++ = c;
}
*d = '\0';
*len = d - save;
/* 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 = TWO_BYTE_UTF8_TO_NATIVE(c, *s);
+ s++;
}
*d++ = c;
}
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 (UNI_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 */
+#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
+#define LAST_HIGH_SURROGATE 0xDBFF
+#define FIRST_LOW_SURROGATE 0xDC00
+#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
+ if (uv >= FIRST_HIGH_SURROGATE && uv <= LAST_HIGH_SURROGATE) {
if (p >= pend) {
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
} else {
UV low = (p[0] << 8) + p[1];
p += 2;
- if (low < 0xdc00 || low > 0xdfff)
+ if (low < FIRST_LOW_SURROGATE || low > LAST_LOW_SURROGATE)
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
- uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
+ uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
+ + (low - FIRST_LOW_SURROGATE) + 0x10000;
}
- } else if (uv >= 0xdc00 && uv <= 0xdfff) {
+ } else if (uv >= FIRST_LOW_SURROGATE && uv <= LAST_LOW_SURROGATE) {
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
}
+#ifdef EBCDIC
+ d = uvoffuni_to_utf8_flags(d, uv, 0);
+#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 utf16_to_utf8(p, d, bytelen, newlen);
}
+bool
+Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_FOO(classnum, tmpbuf);
+}
+
/* for now these are all defined (inefficiently) in terms of the utf8 versions.
* Note that the macros in handy.h that call these short-circuit calling them
* for Latin-1 range inputs */
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_alnum(tmpbuf);
+ return _is_utf8_FOO(_CC_WORDCHAR, tmpbuf);
+}
+
+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);
+}
+
+/* Internal function so we can deprecate the external one, and call
+ this one from other deprecated functions in this file */
+
+PERL_STATIC_INLINE bool
+S_is_utf8_idfirst(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ if (*p == '_')
+ return TRUE;
+ /* is_utf8_idstart would be more logical. */
+ return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_idfirst(tmpbuf);
+ return S_is_utf8_idfirst(aTHX_ tmpbuf);
+}
+
+bool
+Perl__is_uni_perl_idcont(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_perl_idcont(tmpbuf);
+}
+
+bool
+Perl__is_uni_perl_idstart(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_perl_idstart(tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_alpha(tmpbuf);
+ return _is_utf8_FOO(_CC_ALPHA, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_digit(tmpbuf);
+ return _is_utf8_FOO(_CC_DIGIT, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_upper(tmpbuf);
+ return _is_utf8_FOO(_CC_UPPER, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_lower(tmpbuf);
+ return _is_utf8_FOO(_CC_LOWER, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_graph(tmpbuf);
+ return _is_utf8_FOO(_CC_GRAPH, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_print(tmpbuf);
+ return _is_utf8_FOO(_CC_PRINT, tmpbuf);
}
bool
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_punct(tmpbuf);
+ return _is_utf8_FOO(_CC_PUNCT, tmpbuf);
}
bool
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;
U8 converted = toLOWER_LATIN1(c);
if (p != NULL) {
- if (UNI_IS_INVARIANT(converted)) {
+ if (NATIVE_BYTE_IS_INVARIANT(converted)) {
*p = converted;
*lenp = 1;
}
}
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;
+ assert (! (flags & FOLD_FLAGS_LOCALE));
+
if (c == MICRO_SIGN) {
converted = GREEK_SMALL_LETTER_MU;
}
- else if (flags && c == LATIN_SMALL_LETTER_SHARP_S) {
- *(p)++ = 's';
- *p = 's';
- *lenp = 2;
- return 's';
+ else if ((flags & FOLD_FLAGS_FULL) && 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';
+ }
}
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;
}
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))));
+ flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
/* It is illegal for the fold to cross the 255/256 boundary under
* locale; in this case return the original */
return (result > 256 && flags & FOLD_FLAGS_LOCALE)
}
}
-/* for now these all assume no locale info available for Unicode > 255; and
- * the corresponding macros in handy.h (like isALNUM_LC_uvchr) should have been
- * called instead, so that these don't get called for < 255 */
-
bool
Perl_is_uni_alnum_lc(pTHX_ UV c)
{
- return is_uni_alnum(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALNUM_LC(c);
+ }
+ return _is_uni_FOO(_CC_WORDCHAR, c);
+}
+
+bool
+Perl_is_uni_alnumc_lc(pTHX_ UV c)
+{
+ if (c < 256) {
+ return isALPHANUMERIC_LC(c);
+ }
+ return _is_uni_FOO(_CC_ALPHANUMERIC, c);
}
bool
Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
- return is_uni_idfirst(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isIDFIRST_LC(c);
+ }
+ return _is_uni_perl_idstart(c);
}
bool
Perl_is_uni_alpha_lc(pTHX_ UV c)
{
- return is_uni_alpha(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALPHA_LC(c);
+ }
+ return _is_uni_FOO(_CC_ALPHA, c);
}
bool
Perl_is_uni_ascii_lc(pTHX_ UV c)
{
- return is_uni_ascii(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isASCII_LC(c);
+ }
+ return 0;
}
bool
Perl_is_uni_blank_lc(pTHX_ UV c)
{
- return is_uni_blank(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isBLANK_LC(c);
+ }
+ return isBLANK_uni(c);
}
bool
Perl_is_uni_space_lc(pTHX_ UV c)
{
- return is_uni_space(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isSPACE_LC(c);
+ }
+ return isSPACE_uni(c);
}
bool
Perl_is_uni_digit_lc(pTHX_ UV c)
{
- return is_uni_digit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isDIGIT_LC(c);
+ }
+ return _is_uni_FOO(_CC_DIGIT, c);
}
bool
Perl_is_uni_upper_lc(pTHX_ UV c)
{
- return is_uni_upper(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isUPPER_LC(c);
+ }
+ return _is_uni_FOO(_CC_UPPER, c);
}
bool
Perl_is_uni_lower_lc(pTHX_ UV c)
{
- return is_uni_lower(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isLOWER_LC(c);
+ }
+ return _is_uni_FOO(_CC_LOWER, c);
}
bool
Perl_is_uni_cntrl_lc(pTHX_ UV c)
{
- return is_uni_cntrl(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isCNTRL_LC(c);
+ }
+ return 0;
}
bool
Perl_is_uni_graph_lc(pTHX_ UV c)
{
- return is_uni_graph(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isGRAPH_LC(c);
+ }
+ return _is_uni_FOO(_CC_GRAPH, c);
}
bool
Perl_is_uni_print_lc(pTHX_ UV c)
{
- return is_uni_print(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPRINT_LC(c);
+ }
+ return _is_uni_FOO(_CC_PRINT, c);
}
bool
Perl_is_uni_punct_lc(pTHX_ UV c)
{
- return is_uni_punct(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPUNCT_LC(c);
+ }
+ return _is_uni_FOO(_CC_PUNCT, c);
}
bool
Perl_is_uni_xdigit_lc(pTHX_ UV c)
{
- return is_uni_xdigit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isXDIGIT_LC(c);
+ }
+ return isXDIGIT_uni(c);
}
U32
PERL_ARGS_ASSERT_IS_UTF8_COMMON;
/* The API should have included a length for the UTF-8 character in <p>,
- * but it doesn't. We therefor assume that p has been validated at least
+ * but it doesn't. We therefore assume that p has been validated at least
* as far as there being enough bytes available in it to accommodate the
* character without reading beyond the end, and pass that number on to the
* validating routine */
- if (!is_utf8_char_buf(p, p + UTF8SKIP(p)))
- return FALSE;
+ if (! is_utf8_char_buf(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 (ckWARN(WARN_UTF8)) { /* This will output details as to the
+ what the malformation is */
+ utf8_to_uvchr_buf(p, p + UTF8SKIP(p), NULL);
+ }
+ }
+ return FALSE;
+ }
if (!*swash) {
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
*swash = _core_swash_init("utf8", swashname, &PL_sv_undef, 1, 0, NULL, &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]);
+}
+
+bool
Perl_is_utf8_alnum(pTHX_ const U8 *p)
{
dVAR;
/* 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_alnum, "IsWord");
+ 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_ARGS_ASSERT_IS_UTF8_IDFIRST;
- if (*p == '_')
- return TRUE;
- /* is_utf8_idstart would be more logical. */
- return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
+ return S_is_utf8_idfirst(aTHX_ p);
}
bool
}
bool
-Perl__is_utf8__perl_idstart(pTHX_ const U8 *p)
+Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT__IS_UTF8__PERL_IDSTART;
+ PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart");
}
bool
+Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ 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_ALPHA;
- return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHA], "IsAlpha");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
- return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_DIGIT], "IsDigit");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_UPPER;
- return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_UPPER], "IsUppercase");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_LOWER;
- return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_LOWER], "IsLowercase");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
- return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_GRAPH], "IsGraph");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_PRINT;
- return is_utf8_common(p, &PL_utf8_print, "IsPrint");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PRINT], "IsPrint");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
- return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
+ return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PUNCT], "IsPunct");
}
bool
}
bool
-Perl_is_utf8_mark(pTHX_ const U8 *p)
+Perl__is_utf8_mark(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_MARK;
+ PERL_ARGS_ASSERT__IS_UTF8_MARK;
return is_utf8_common(p, &PL_utf8_mark, "IsM");
}
-bool
-Perl_is_utf8_X_regular_begin(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_REGULAR_BEGIN;
-
- return is_utf8_common(p, &PL_utf8_X_regular_begin, "_X_Regular_Begin");
-}
bool
-Perl_is_utf8_X_extend(pTHX_ const U8 *p)
+Perl_is_utf8_mark(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
+ PERL_ARGS_ASSERT_IS_UTF8_MARK;
- return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
+ return _is_utf8_mark(p);
}
/*
SV **swashp, const char *normal, const char *special)
{
dVAR;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
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);
+ const UV uv1 = valid_utf8_to_uvchr(p, NULL);
PERL_ARGS_ASSERT_TO_UTF8_CASE;
* be given */
}
- uvuni_to_utf8(tmpbuf, uv1);
-
if (!*swashp) /* load on-demand */
*swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
SV **svp;
if (hv &&
- (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
+ (svp = hv_fetch(hv, (const char*)p, UNISKIP(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 utf8 */);
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;
}
}
if (lenp)
*lenp = len;
- return uv0;
+ return uv1;
}
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);
/*
=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 */
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ result = toUPPER_LC(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)));
}
else {
- return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp, 'S');
}
}
*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;
}
/*
=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 */
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ result = toUPPER_LC(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)));
}
else {
- return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp, 's');
}
}
*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;
}
/*
=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 */
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ result = toLOWER_LC(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)));
}
else {
- return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
+ return to_lower_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp);
}
}
*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;
}
/*
=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 */
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)));
+ result = toFOLD_LC(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)));
}
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(TWO_BYTE_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);
- if ((flags & FOLD_FLAGS_LOCALE)) {
+ if (flags & FOLD_FLAGS_LOCALE) {
+
+ /* Special case these characters, as what normally gets returned
+ * under locale doesn't work */
+ if (UTF8SKIP(p) == sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1
+ && memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
+ sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1))
+ {
+ goto return_long_s;
+ }
+ else if (UTF8SKIP(p) == sizeof(LATIN_SMALL_LIGATURE_LONG_S_T) - 1
+ && memEQ((char *) p, LATIN_SMALL_LIGATURE_LONG_S_T_UTF8,
+ sizeof(LATIN_SMALL_LIGATURE_LONG_S_T_UTF8) - 1))
+ {
+ goto return_ligature_st;
+ }
return check_locale_boundary_crossing(p, result, ustrp, lenp);
}
else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
}
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. */
+ * 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_CAPITAL_LETTER_SHARP_S
+ || original == LATIN_SMALL_LETTER_SHARP_S)
+ {
+ goto return_long_s;
+ }
+ else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) {
+ goto return_ligature_st;
+ }
Copy(p, ustrp, *lenp, char);
return original;
}
*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;
}
*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;
}
/* Note:
method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
if (!method) { /* demand load utf8 */
ENTER;
- errsv_save = newSVsv(ERRSV);
- SAVEFREESV(errsv_save);
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
/* 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
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
NULL);
{
- SV * const errsv = ERRSV;
- if (!SvTRUE_NN(errsv))
- sv_setsv(errsv, errsv_save);
+ /* Not ERRSV, as there is no need to vivify a scalar we are
+ about to discard. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
}
LEAVE;
}
mPUSHi(minbits);
mPUSHi(none);
PUTBACK;
- errsv_save = newSVsv(ERRSV);
- SAVEFREESV(errsv_save);
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
/* If we already have a pointer to the method, no need to use
* call_method() to repeat the lookup. */
if (method
SvREFCNT_inc(retval);
}
{
- SV * const errsv = ERRSV;
- if (!SvTRUE_NN(errsv))
- sv_setsv(errsv, errsv_save);
+ /* Not ERRSV. See above. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
}
LEAVE;
POPSTACK;
/* 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 utf8. If C<do_utf8> is false, the string C<ptr>
+ * is assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
*
* A "swash" is a hash which contains initially the keys/values set up by
* SWASHNEW. The purpose is to be able to completely represent a Unicode
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 = TWO_BYTE_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;
}
/*
/* 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);
*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;
*
* The returned hash would have two keys, the utf8 for 006B and the utf8 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
+ * have two elements, the utf8 for itself, and for 004C. For 006B, there
* would be three elements in its array, the utf8 for 006B, 004B and 212A.
*
* Essentially, for any code point, it gives all the code points that map to
&char_to, &to_len)))
{
if (av_len(from_list) > 0) {
- int i;
+ 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;
+ SSize_t j;
AV* i_list = newAV();
SV** entryp = av_fetch(from_list, i, FALSE);
if (entryp == NULL) {
/* 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 */
Perl__swash_to_invlist(pTHX_ SV* const swash)
{
- /* Subject to change or removal. For use only in one place in regcomp.c */
+ /* Subject to change or removal. For use only in one place in regcomp.c.
+ * Ownership is given to one reference count in the returned SV* */
U8 *l, *lend;
char *loc;
SV* invlist;
+ PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
+
/* If not a hash, it must be the swash's inversion list instead */
if (SvTYPE(hv) != SVt_PVHV) {
- return (SV*) hv;
+ return SvREFCNT_inc_simple_NN((SV*) hv);
}
/* The string containing the main body of the table */
bits = SvUV(*bitssvp);
octets = bits >> 3; /* if bits == 1, then octets == 0 */
- PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
-
/* read $swash->{LIST} */
if (SvPOK(*listsvp)) {
l = (U8*)SvPV(*listsvp, lcur);
_invlist_union(invlist, other, &invlist);
break;
case '!':
- _invlist_invert(other);
- _invlist_union(invlist, other, &invlist);
+ _invlist_union_maybe_complement_2nd(invlist, other, TRUE, &invlist);
break;
case '-':
_invlist_subtract(invlist, other, &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_ register const U8* s, const STRLEN len)
+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
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);
}
* FOLDEQ_S2_ALREADY_FOLDED Similarly.
*/
I32
-Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)
+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 */
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))));
+ && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
+ /* 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 (pe1) {
e1 = *(U8**)pe1;
* 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)))
+ && (! u1 || ! UTF8_IS_ABOVE_LATIN1(*p1)))
{
/* There is no mixing of code points above and below 255. */
- if (u2 && (! UTF8_IS_INVARIANT(*p2)
- && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
- {
+ if (u2 && UTF8_IS_ABOVE_LATIN1(*p2)) {
return 0;
}
*foldbuf1 = *p1;
}
else {
- *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+ *foldbuf1 = TWO_BYTE_UTF8_TO_NATIVE(*p1, *(p1 + 1));
}
n1 = 1;
}
return 0;
}
n1 = 1;
- *foldbuf1 = toLOWER(*p1); /* Folds in the ASCII range are
- just lowercased */
+ *foldbuf1 = toFOLD(*p1);
}
else if (u1) {
to_utf8_fold(p1, foldbuf1, &n1);
}
else { /* Not utf8, get utf8 fold */
- to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1);
+ to_uni_fold(*p1, foldbuf1, &n1);
}
f1 = foldbuf1;
}
}
else {
if ((flags & FOLDEQ_UTF8_LOCALE)
- && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
+ && (! u2 || ! UTF8_IS_ABOVE_LATIN1(*p2)))
{
/* Here, the next char in s2 is < 256. We've already
* worked on s1, and if it isn't also < 256, can't match */
- if (u1 && (! UTF8_IS_INVARIANT(*p1)
- && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
- {
+ if (u1 && UTF8_IS_ABOVE_LATIN1(*p1)) {
return 0;
}
if (! u2 || UTF8_IS_INVARIANT(*p2)) {
*foldbuf2 = *p2;
}
else {
- *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+ *foldbuf2 = TWO_BYTE_UTF8_TO_NATIVE(*p2, *(p2 + 1));
}
/* Use another function to handle locale rules. We've made
return 0;
}
n2 = 1;
- *foldbuf2 = toLOWER(*p2);
+ *foldbuf2 = toFOLD(*p2);
}
else if (u2) {
to_utf8_fold(p2, foldbuf2, &n2);
}
else {
- to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2);
+ to_uni_fold(*p2, foldbuf2, &n2);
}
f2 = foldbuf2;
}
return 1;
}
+/* XXX The next four 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);
+}
+
+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);
+}
+
+/*
+=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
+*/
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff