{
PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
- if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
+ /* 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),
STATIC STRLEN
S_is_utf8_char_slow(const U8 *s, const STRLEN len)
{
- U8 u = *s;
- STRLEN slen;
- UV uv, ouv;
-
- PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
+ dTHX; /* The function called below requires thread context */
- if (UTF8_IS_INVARIANT(u))
- return len == 1;
+ STRLEN actual_len;
- if (!UTF8_IS_START(u))
- return 0;
-
- if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
- return 0;
-
- slen = len - 1;
- s++;
-#ifdef EBCDIC
- u = NATIVE_TO_UTF(u);
-#endif
- u &= UTF_START_MASK(len);
- uv = u;
- ouv = uv;
- while (slen--) {
- if (!UTF8_IS_CONTINUATION(*s))
- return 0;
- uv = UTF8_ACCUMULATE(uv, *s);
- if (uv < ouv)
- return 0;
- ouv = uv;
- s++;
- }
+ PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
- if ((STRLEN)UNISKIP(uv) < len)
- return 0;
+ utf8n_to_uvuni(s, len, &actual_len, UTF8_CHECK_ONLY);
- return len;
+ return (actual_len == (STRLEN) -1) ? 0 : actual_len;
}
/*
=for apidoc utf8n_to_uvuni
Bottom level UTF-8 decode routine.
-Returns the 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> will be set to the length, in bytes, of that
-character.
+Returns the 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.
The value of C<flags> determines the behavior when C<s> does not point to a
well-formed UTF-8 character. If C<flags> is 0, when a malformation is found,
-C<retlen> is set to the expected length of the UTF-8 character in bytes, zero
-is returned, and if UTF-8 warnings haven't been lexically disabled, a warning
-is raised.
+zero is returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+Also, if UTF-8 warnings haven't been lexically disabled, a warning is raised.
Various ALLOW flags can be set in C<flags> to allow (and not warn on)
individual types of malformations, such as the sequence being overlong (that
overlong sequences are expressly forbidden in the UTF-8 standard due to
potential security issues). Another malformation example is the first byte of
a character not being a legal first byte. See F<utf8.h> for the list of such
-flags. Of course, the value returned by this function under such conditions is
-not reliable.
+flags. For allowed 0 length strings, this function returns 0; for allowed
+overlong sequences, the computed code point is returned; for all other allowed
+malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no
+determinable reasonable value.
The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
flags) malformation is found. If this flag is set, the routine assumes that
C<retlen> to C<-1> and return zero.
Certain code points are considered problematic. These are Unicode surrogates,
-Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
+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
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 do not fit into a 32-bit word, are not representable on EBCDIC
-platforms, and the original UTF-8 specification never went above
-this number (the current 0x10FFF limit was imposed later). 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.
+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.
All other code points corresponding to Unicode characters, including private
use and those yet to be assigned, are never considered malformed and never
{
dVAR;
const U8 * const s0 = s;
- UV uv = *s, ouv = 0;
- STRLEN len = 1;
- bool dowarn = ckWARN_d(WARN_UTF8);
- const UV startbyte = *s;
- STRLEN expectlen = 0;
- U32 warning = 0;
+ U8 overflow_byte = '\0'; /* Save byte in case of overflow */
+ U8 * send;
+ UV uv = *s;
+ STRLEN expectlen;
SV* sv = NULL;
+ UV outlier_ret = 0; /* return value when input is in error or problematic
+ */
+ UV pack_warn = 0; /* Save result of packWARN() for later */
+ bool unexpected_non_continuation = FALSE;
+ bool overflowed = FALSE;
+ bool do_overlong_test = TRUE; /* May have to skip this test */
- PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
+ const char* const malformed_text = "Malformed UTF-8 character";
-/* This list is a superset of the UTF8_ALLOW_XXX. */
+ PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
-#define UTF8_WARN_EMPTY 1
-#define UTF8_WARN_CONTINUATION 2
-#define UTF8_WARN_NON_CONTINUATION 3
-#define UTF8_WARN_SHORT 4
-#define UTF8_WARN_OVERFLOW 5
-#define UTF8_WARN_LONG 6
+ /* 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
+ * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
+ * http://unicode.org/reports/tr36 for more discussion as to why. For
+ * example, once we've done a UTF8SKIP, we can tell the expected number of
+ * bytes, and could fail right off the bat if the input parameters indicate
+ * that there are too few available. But it could be that just that first
+ * byte is garbled, and the intended character occupies fewer bytes. If we
+ * blindly assumed that the first byte is correct, and skipped based on
+ * that number, we could skip over a valid input character. So instead, we
+ * always examine the sequence byte-by-byte.
+ *
+ * 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
+ * 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 */
+
+ /* Zero length strings, if allowed, of necessity are zero */
+ if (UNLIKELY(curlen == 0)) {
+ if (retlen) {
+ *retlen = 0;
+ }
- if (curlen == 0 &&
- !(flags & UTF8_ALLOW_EMPTY)) {
- warning = UTF8_WARN_EMPTY;
+ if (flags & UTF8_ALLOW_EMPTY) {
+ return 0;
+ }
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
+ }
goto malformed;
}
+ expectlen = UTF8SKIP(s);
+
+ /* A well-formed UTF-8 character, as the vast majority of calls to this
+ * function will be for, has this expected length. For efficiency, set
+ * things up here to return it. It will be overriden only in those rare
+ * cases where a malformation is found */
+ if (retlen) {
+ *retlen = expectlen;
+ }
+
+ /* An invariant is trivially well-formed */
if (UTF8_IS_INVARIANT(uv)) {
- if (retlen)
- *retlen = 1;
return (UV) (NATIVE_TO_UTF(*s));
}
- if (UTF8_IS_CONTINUATION(uv) &&
- !(flags & UTF8_ALLOW_CONTINUATION)) {
- warning = UTF8_WARN_CONTINUATION;
- goto malformed;
- }
+ /* A continuation character can't start a valid sequence */
+ if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
+ if (flags & UTF8_ALLOW_CONTINUATION) {
+ if (retlen) {
+ *retlen = 1;
+ }
+ return UNICODE_REPLACEMENT;
+ }
- if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- warning = UTF8_WARN_NON_CONTINUATION;
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
+ }
+ curlen = 1;
goto malformed;
}
#ifdef EBCDIC
uv = NATIVE_TO_UTF(uv);
-#else
- if (uv == 0xfe || uv == 0xff) {
- if (flags & (UTF8_WARN_SUPER|UTF8_WARN_FE_FF)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point beginning with byte 0x%02"UVXf" is not Unicode, and not portable", uv));
- flags &= ~UTF8_WARN_SUPER; /* Only warn once on this problem */
- }
- if (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_FE_FF)) {
- goto malformed;
- }
- }
#endif
- if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
- else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
- else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
- else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
-#ifdef EBCDIC
- else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
- else { len = 7; uv &= 0x01; }
-#else
- else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
- else if (!(uv & 0x01)) { len = 7; uv = 0; }
- else { len = 13; uv = 0; } /* whoa! */
+ /* Here is not a continuation byte, nor an invariant. The only thing left
+ * is a start byte (possibly for an overlong) */
+
+ /* 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 */
+ uv &= UTF_START_MASK(expectlen);
+
+ /* Now, loop through the remaining bytes in the character's sequence,
+ * accumulating each into the working value as we go. Be sure to not look
+ * past the end of the input string */
+ send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
+
+ 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
+ * serious than the others (though I, khw, don't understand
+ * why, since other malformations also give very very wrong
+ * results), so there is no way to turn off checking for it.
+ * Set a flag, but keep going in the loop, so that we absorb
+ * the rest of the bytes that comprise the character. */
+ overflowed = TRUE;
+ overflow_byte = *s; /* Save for warning message's use */
+ }
#endif
+ uv = UTF8_ACCUMULATE(uv, *s);
+ }
+ else {
+ /* Here, found a non-continuation before processing all expected
+ * bytes. This byte begins a new character, so quit, even if
+ * allowing this malformation. */
+ unexpected_non_continuation = TRUE;
+ break;
+ }
+ } /* End of loop through the character's bytes */
+
+ /* Save how many bytes were actually in the character */
+ curlen = s - s0;
+
+ /* The loop above finds two types of malformations: non-continuation and/or
+ * overflow. The non-continuation malformation is really a too-short
+ * malformation, as it means that the current character ended before it was
+ * expected to (being terminated prematurely by the beginning of the next
+ * character, whereas in the too-short malformation there just are too few
+ * bytes available to hold the character. In both cases, the check below
+ * that we have found the expected number of bytes would fail if executed.)
+ * Thus the non-continuation malformation is really unnecessary, being a
+ * subset of the too-short malformation. But there may be existing
+ * applications that are expecting the non-continuation type, so we retain
+ * it, and return it in preference to the too-short malformation. (If this
+ * code were being written from scratch, the two types might be collapsed
+ * into one.) I, khw, am also giving priority to returning the
+ * non-continuation and too-short malformations over overflow when multiple
+ * ones are present. I don't know of any real reason to prefer one over
+ * the other, except that it seems to me that multiple-byte errors trumps
+ * errors from a single byte */
+ if (UNLIKELY(unexpected_non_continuation)) {
+ if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ if (curlen == 1) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
+ }
+ else {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
+ }
+ }
+ goto malformed;
+ }
+ uv = UNICODE_REPLACEMENT;
- if (retlen)
- *retlen = len;
+ /* Skip testing for overlongs, as the REPLACEMENT may not be the same
+ * as what the original expectations were. */
+ do_overlong_test = FALSE;
+ if (retlen) {
+ *retlen = curlen;
+ }
+ }
+ else if (UNLIKELY(curlen < expectlen)) {
+ if (! (flags & UTF8_ALLOW_SHORT)) {
+ 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)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
+ }
+ goto malformed;
+ }
+ uv = UNICODE_REPLACEMENT;
+ do_overlong_test = FALSE;
+ if (retlen) {
+ *retlen = curlen;
+ }
+ }
- expectlen = len;
+#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 ((curlen < expectlen) &&
- !(flags & UTF8_ALLOW_SHORT)) {
- warning = UTF8_WARN_SHORT;
+ /* 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
- len--;
- s++;
- ouv = uv; /* ouv is the value from the previous iteration */
-
- while (len--) {
- if (!UTF8_IS_CONTINUATION(*s) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- s--;
- warning = UTF8_WARN_NON_CONTINUATION;
- goto malformed;
- }
- else
- uv = UTF8_ACCUMULATE(uv, *s);
- if (!(uv > ouv)) { /* If the value didn't grow from the previous
- iteration, something is horribly wrong */
- /* These cannot be allowed. */
- if (uv == ouv) {
- if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
- goto malformed;
- }
- }
- else { /* uv < ouv */
- /* This cannot be allowed. */
- warning = UTF8_WARN_OVERFLOW;
- goto malformed;
- }
+ if (do_overlong_test
+ && expectlen > (STRLEN)UNISKIP(uv)
+ && ! (flags & UTF8_ALLOW_LONG))
+ {
+ /* The overlong malformation has lower precedence than the others.
+ * Note that if this malformation is allowed, we return the actual
+ * 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));
}
- s++;
- ouv = uv;
+ goto malformed;
}
- if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
- goto malformed;
- } else if (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE)) {
+ /* Here, the input is considered to be well-formed , but 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)))
+ {
if (UNICODE_IS_SURROGATE(uv)) {
- if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE) {
+ if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
+ && ckWARN2_d(WARN_UTF8, WARN_SURROGATE))
+ {
sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
+ pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE);
}
if (flags & UTF8_DISALLOW_SURROGATE) {
goto disallowed;
}
}
- else if (UNICODE_IS_NONCHAR(uv)) {
- if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR ) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
+ else if ((uv > PERL_UNICODE_MAX)) {
+ if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
+ && ckWARN2_d(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 = packWARN2(WARN_UTF8, WARN_NON_UNICODE);
}
- if (flags & UTF8_DISALLOW_NONCHAR) {
+ if (flags & UTF8_DISALLOW_SUPER) {
goto disallowed;
}
}
- else if ((uv > PERL_UNICODE_MAX)) {
- if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
+ else if (UNICODE_IS_NONCHAR(uv)) {
+ if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
+ && ckWARN2_d(WARN_UTF8, 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);
}
- if (flags & UTF8_DISALLOW_SUPER) {
+ if (flags & UTF8_DISALLOW_NONCHAR) {
goto disallowed;
}
}
+ if (sv) {
+ outlier_ret = uv;
+ goto do_warn;
+ }
+
/* Here, this is not considered a malformed character, so drop through
* to return it */
}
return uv;
-disallowed: /* Is disallowed, but otherwise not malformed. 'sv' will have been
- set if there is to be a warning. */
- if (!sv) {
- dowarn = 0;
- }
+ /* 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.
+ * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
+ * set.
+ * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
+ * This is done by initializing it to 0, and changing it only
+ * for case 1).
+ * The 3 cases are:
+ * 1) The input is valid but problematic, and to be warned about. The
+ * return value is the resultant code point; <*retlen> is set to
+ * <curlen>, the number of bytes that comprise the code point.
+ * <pack_warn> contains the result of packWARN() for the warning
+ * types. The entry point for this case is the label <do_warn>;
+ * 2) The input is a valid code point but disallowed by the parameters to
+ * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
+ * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
+ * comprise the code point. <pack_warn> contains the result of
+ * packWARN() for the warning types. The entry point for this case is
+ * the label <disallowed>.
+ * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
+ * is set, <*relen> is -1; otherwise it is <curlen>, the number of
+ * bytes that comprise the malformation. All such malformations are
+ * assumed to be warning type <utf8>. The entry point for this case
+ * is the label <malformed>.
+ */
malformed:
+ if (sv && ckWARN_d(WARN_UTF8)) {
+ pack_warn = packWARN(WARN_UTF8);
+ }
+
+disallowed:
+
if (flags & UTF8_CHECK_ONLY) {
if (retlen)
*retlen = ((STRLEN) -1);
return 0;
}
- if (dowarn) {
- if (! sv) {
- sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
- }
-
- switch (warning) {
- case 0: /* Intentionally empty. */ break;
- case UTF8_WARN_EMPTY:
- sv_catpvs(sv, "(empty string)");
- break;
- case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
- break;
- case UTF8_WARN_NON_CONTINUATION:
- if (s == s0)
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
- (UV)s[1], startbyte);
- else {
- const int len = (int)(s-s0);
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
- (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
- }
+do_warn:
- break;
- case UTF8_WARN_SHORT:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
- expectlen = curlen; /* distance for caller to skip */
- break;
- case UTF8_WARN_OVERFLOW:
- Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
- ouv, *s, startbyte);
- break;
- case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
- break;
- default:
- sv_catpvs(sv, "(unknown reason)");
- break;
- }
-
- if (sv) {
- const char * const s = SvPVX_const(sv);
+ if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
+ if warnings are to be raised. */
+ const char * const string = SvPVX_const(sv);
- if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "%s in %s", s, OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
- }
+ if (PL_op)
+ Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
+ else
+ Perl_warner(aTHX_ pack_warn, "%s", string);
}
- if (retlen)
- *retlen = expectlen ? expectlen : len;
+ if (retlen) {
+ *retlen = curlen;
+ }
- return 0;
+ return outlier_ret;
}
/*
Returns the 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.
+C<*retlen> will be set to the length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF-8 character, zero is
-returned and C<retlen> is set, if possible, to -1.
+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
*/
}
/* 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>. Currently, some
- * malformations are checked for, but this checking likely will be removed in
- * the future */
+ * 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_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
{
+ const UV uv = valid_utf8_to_uvuni(s, retlen);
+
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
- return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
+ return UNI_TO_NATIVE(uv);
}
/*
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, zero is
-returned and C<retlen> is set, if possible, to -1.
+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
*/
{
PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
- return valid_utf8_to_uvchr(s, retlen);
+ return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
}
/*
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, zero is
-returned and C<retlen> is set, if possible, to -1.
+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
*/
}
/* 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>. Currently, some
- * malformations are checked for, but this checking likely will be removed in
- * the future */
+ * 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;
- return utf8_to_uvuni_buf(s, s + UTF8_MAXBYTES, retlen);
+ 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 */
+ for (++s; s < send; s++) {
+ uv = UTF8_ACCUMULATE(uv, *s);
+ }
+
+ return uv;
}
/*
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.
-If C<s> points to one of the detected malformations, zero is
-returned and C<retlen> is set, if possible, to -1.
+If C<s> points to one of the detected malformations, and UTF8 warnings are
+enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
+NULL) to -1. If those warnings are off, the computed value if well-defined (or
+the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
+is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
+next possible position in C<s> that could begin a non-malformed character.
+See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
=cut
*/
}
bool
+Perl_is_uni_blank(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return is_utf8_blank(tmpbuf);
+}
+
+bool
Perl_is_uni_space(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
return 'S';
default:
Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
- /* NOTREACHED */
+ assert(0); /* NOTREACHED */
}
}
}
UV
-Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const bool flags)
+Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const U8 flags)
{
- /* Not currently externally documented, and subject to change, <flags> is
- * TRUE iff full folding is to be used */
+ /* 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_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
+ */
PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
if (c < 256) {
- return _to_fold_latin1((U8) c, p, lenp, flags);
+ 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;
}
- uvchr_to_utf8(p, c);
- return CALL_FOLD_CASE(p, p, lenp, flags);
+ /* 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);
+ }
+ 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);
+ }
}
/* for now these all assume no locale info available for Unicode > 255; and
}
bool
+Perl_is_uni_blank_lc(pTHX_ UV c)
+{
+ return is_uni_blank(c); /* XXX no locale support yet */
+}
+
+bool
Perl_is_uni_space_lc(pTHX_ UV c)
{
return is_uni_space(c); /* XXX no locale support yet */
}
bool
+Perl_is_utf8_blank(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_BLANK;
+
+ return is_utf8_common(p, &PL_utf8_blank, "XPosixBlank");
+}
+
+bool
Perl_is_utf8_space(pTHX_ const U8 *p)
{
dVAR;
PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
- return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
+ return is_utf8_common(p, &PL_utf8_X_prepend, "_X_GCB_Prepend");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
- return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
+ return is_utf8_common(p, &PL_utf8_X_non_hangul, "_X_HST_Not_Applicable");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_L;
- return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
+ return is_utf8_common(p, &PL_utf8_X_L, "_X_GCB_L");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_LV;
- return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
+ return is_utf8_common(p, &PL_utf8_X_LV, "_X_GCB_LV");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
- return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
+ return is_utf8_common(p, &PL_utf8_X_LVT, "_X_GCB_LVT");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_T;
- return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
+ return is_utf8_common(p, &PL_utf8_X_T, "_X_GCB_T");
}
bool
PERL_ARGS_ASSERT_IS_UTF8_X_V;
- return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
+ return is_utf8_common(p, &PL_utf8_X_V, "_X_GCB_V");
}
bool
}
if (!len && *swashp) {
- const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
+ const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE /* => is utf8 */);
if (uv2) {
/* It was "normal" (a single character mapping). */
}
}
- if (!len) /* Neither: just copy. In other words, there was no mapping
- defined, which means that the code point maps to itself */
- len = uvchr_to_utf8(ustrp, uv0) - ustrp;
+ if (len) {
+ if (lenp) {
+ *lenp = len;
+ }
+ return valid_utf8_to_uvchr(ustrp, 0);
+ }
+
+ /* Here, there was no mapping defined, which means that the code point maps
+ * to itself. Return the inputs */
+ len = UTF8SKIP(p);
+ Copy(p, ustrp, len, U8);
if (lenp)
*lenp = len;
- return len ? valid_utf8_to_uvchr(ustrp, 0) : 0;
+ return uv0;
+
}
STATIC UV
* POSIX, lowercase is used instead
* 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. */
PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
+ /* These are mutually exclusive */
+ assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
+
+ assert(p != ustrp); /* Otherwise overwrites */
+
if (UTF8_IS_INVARIANT(*p)) {
if (flags & FOLD_FLAGS_LOCALE) {
result = toLOWER_LC(*p);
}
else {
return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
- ustrp, lenp, cBOOL(flags & FOLD_FLAGS_FULL));
+ 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))));
}
}
else { /* utf8, ord above 255 */
- result = CALL_FOLD_CASE(p, ustrp, lenp, flags);
+ result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
if ((flags & FOLD_FLAGS_LOCALE)) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ 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. */
+
+ UV original; /* To store the first code point of <p> */
+
+ /* Look at every character in the result; if any cross the
+ * boundary, the whole thing is disallowed */
+ U8* s = ustrp;
+ U8* e = ustrp + *lenp;
+ while (s < e) {
+ if (isASCII(*s)) {
+ /* Crossed, have to return the original */
+ original = valid_utf8_to_uvchr(p, lenp);
+ Copy(p, ustrp, *lenp, char);
+ return original;
+ }
+ s += UTF8SKIP(s);
+ }
- return result;
+ /* Here, no characters crossed, result is ok as-is */
+ return result;
+ }
}
/* Here, used locale rules. Convert back to utf8 */
Copy(ptr, PL_last_swash_key, klen, U8);
}
- if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
-
- /* This outputs warnings for binary properties only, assuming that
- * to_utf8_case() will output any for non-binary. Also, surrogates
- * aren't checked for, as that would warn on things like /\p{Gc=Cs}/ */
-
- if (! bitssvp || SvUV(*bitssvp) == 1) {
- /* User-defined properties can silently match above-Unicode */
- SV** const user_defined_svp = hv_fetchs(hv, "USER_DEFINED", FALSE);
- if (! user_defined_svp || ! SvUV(*user_defined_svp)) {
- const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
- Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
- "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", code_point);
- }
- }
- }
-
switch ((int)((slen << 3) / needents)) {
case 1:
bit = 1 << (off & 7);
(U8*) SvPVX(*entryp),
(U8*) SvPVX(*entryp) + SvCUR(*entryp),
0)));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
}
}
}
/* Make sure there is a mapping to itself on the list */
if (! found_key) {
av_push(list, newSVuv(val));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", val, val));*/
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, val, val));*/
}
/* Simply add the value to the list */
if (! found_inverse) {
av_push(list, newSVuv(inverse));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", inverse, val));*/
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, inverse, val));*/
}
/* swatch_get() increments the value of val for each element in the
return invlist;
}
+bool
+Perl__is_swash_user_defined(pTHX_ SV* const swash)
+{
+ SV** ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "USER_DEFINED", FALSE);
+
+ PERL_ARGS_ASSERT__IS_SWASH_USER_DEFINED;
+
+ if (! ptr) {
+ return FALSE;
+ }
+ return cBOOL(SvUV(*ptr));
+}
+
+SV*
+Perl__get_swash_invlist(pTHX_ SV* const swash)
+{
+ SV** ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "INVLIST", FALSE);
+
+ PERL_ARGS_ASSERT__GET_SWASH_INVLIST;
+
+ if (! ptr) {
+ return NULL;
+ }
+
+ return *ptr;
+}
+
/*
=for apidoc uvchr_to_utf8
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff