#include "EXTERN.h"
#define PERL_IN_UTF8_C
#include "perl.h"
+#include "inline_invlist.c"
#ifndef EBCDIC
/* Separate prototypes needed because in ASCII systems these are
* usually macros but they still are compiled as code, too. */
PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
+PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen);
PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
#endif
{
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;
}
/*
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
the caller will raise a warning, and this function will silently just set
-C<retlen> to C<-1> and return zero.
+C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
+
+Note that this API requires disambiguation between successful decoding a NUL
+character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as
+in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
+first byte of C<s> is 0 as well. If so, the input was a NUL; if not, the input
+had an error.
Certain code points are considered problematic. These are Unicode surrogates,
Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
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 */
const char* const malformed_text = "Malformed UTF-8 character";
* sequence and process the rest, inappropriately */
/* Zero length strings, if allowed, of necessity are zero */
- if (curlen == 0) {
+ if (UNLIKELY(curlen == 0)) {
if (retlen) {
*retlen = 0;
}
}
/* A continuation character can't start a valid sequence */
- if (UTF8_IS_CONTINUATION(uv)) {
+ if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
if (flags & UTF8_ALLOW_CONTINUATION) {
if (retlen) {
*retlen = 1;
send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
for (s = s0 + 1; s < send; s++) {
- if (UTF8_IS_CONTINUATION(*s)) {
+ if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
#ifndef EBCDIC /* Can't overflow in EBCDIC */
if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
* 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 (unexpected_non_continuation) {
+ if (UNLIKELY(unexpected_non_continuation)) {
if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
if (! (flags & UTF8_CHECK_ONLY)) {
if (curlen == 1) {
goto malformed;
}
uv = UNICODE_REPLACEMENT;
+
+ /* 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 (curlen < expectlen) {
+ 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;
}
}
#ifndef EBCDIC /* EBCDIC allows FE, FF, can't overflow */
- else if ((*s0 & 0xFE) == 0xFE /* matches FE or FF */
+ 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
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);
}
goto malformed;
}
}
- else if (overflowed) {
+ if (UNLIKELY(overflowed)) {
/* If the first byte is FF, it will overflow a 32-bit word. If the
* first byte is FE, it will overflow a signed 32-bit word. The
}
#endif
- else if (expectlen > (STRLEN)UNISKIP(uv) && ! (flags & UTF8_ALLOW_LONG)) {
+ 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
goto disallowed;
}
}
- 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_NONCHAR) {
- goto disallowed;
- }
- }
else if ((uv > PERL_UNICODE_MAX)) {
if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
&& ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE))
goto disallowed;
}
}
+ 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_NONCHAR) {
+ goto disallowed;
+ }
+ }
if (sv) {
outlier_ret = uv;
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);
+ const char * const string = SvPVX_const(sv);
- 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 (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) {
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. A macro
+ * in utf8.h is used to normally avoid this function wrapper */
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. (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;
}
/*
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
*/
if (e < s)
goto warn_and_return;
while (s < e) {
- if (!UTF8_IS_INVARIANT(*s))
- s += UTF8SKIP(s);
- else
- s++;
+ s += UTF8SKIP(s);
len++;
}
}
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 */
* validating routine */
if (!is_utf8_char_buf(p, p + UTF8SKIP(p)))
return FALSE;
- if (!*swash)
- *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
+ 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_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;
}
bool
-Perl_is_utf8_X_begin(pTHX_ const U8 *p)
+Perl_is_utf8_X_regular_begin(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
+ PERL_ARGS_ASSERT_IS_UTF8_X_REGULAR_BEGIN;
- return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
+ return is_utf8_common(p, &PL_utf8_X_regular_begin, "_X_Regular_Begin");
}
bool
return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
}
-bool
-Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
-
- return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
-}
-
-bool
-Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
-
- return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
-}
-
-bool
-Perl_is_utf8_X_L(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_L;
-
- return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
-}
-
-bool
-Perl_is_utf8_X_LV(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LV;
-
- return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
-}
-
-bool
-Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
-
- return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
-}
-
-bool
-Perl_is_utf8_X_T(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_T;
-
- return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
-}
-
-bool
-Perl_is_utf8_X_V(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_V;
-
- return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
-}
-
-bool
-Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
-
- return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
-}
-
-bool
-Perl__is_utf8_quotemeta(pTHX_ const U8 *p)
-{
- /* For exclusive use of pp_quotemeta() */
-
- dVAR;
-
- PERL_ARGS_ASSERT__IS_UTF8_QUOTEMETA;
-
- return is_utf8_common(p, &PL_utf8_quotemeta, "_Perl_Quotemeta");
-}
-
/*
=for apidoc to_utf8_case
uvuni_to_utf8(tmpbuf, uv1);
if (!*swashp) /* load on-demand */
- *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
+ *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
if (special) {
/* It might be "special" (sometimes, but not always,
}
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 */
* public interface, and returning a copy prevents others from doing
* mischief on the original */
- return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, FALSE, NULL, FALSE));
+ return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, NULL, NULL));
}
SV*
-Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, bool return_if_undef, SV* invlist, bool passed_in_invlist_has_user_defined_property)
+Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
{
/* Initialize and return a swash, creating it if necessary. It does this
- * by calling utf8_heavy.pl in the general case.
+ * by calling utf8_heavy.pl in the general case. The returned value may be
+ * the swash's inversion list instead if the input parameters allow it.
+ * Which is returned should be immaterial to callers, as the only
+ * operations permitted on a swash, swash_fetch() and
+ * _get_swash_invlist(), handle both these transparently.
*
* This interface should only be used by functions that won't destroy or
* adversely change the swash, as doing so affects all other uses of the
* minbits is the number of bits required to represent each data element.
* It is '1' for binary properties.
* none I (khw) do not understand this one, but it is used only in tr///.
- * return_if_undef is TRUE if the routine shouldn't croak if it can't find
- * the requested property
* invlist is an inversion list to initialize the swash with (or NULL)
- * has_user_defined_property is TRUE if <invlist> has some component that
- * came from a user-defined property
+ * flags_p if non-NULL is the address of various input and output flag bits
+ * to the routine, as follows: ('I' means is input to the routine;
+ * 'O' means output from the routine. Only flags marked O are
+ * meaningful on return.)
+ * _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
+ * came from a user-defined property. (I O)
+ * _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
+ * when the swash cannot be located, to simply return NULL. (I)
+ * _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
+ * return of an inversion list instead of a swash hash if this routine
+ * thinks that would result in faster execution of swash_fetch() later
+ * on. (I)
*
* Thus there are three possible inputs to find the swash: <name>,
* <listsv>, and <invlist>. At least one must be specified. The result
dVAR;
SV* retval = &PL_sv_undef;
+ HV* swash_hv = NULL;
+ const int invlist_swash_boundary =
+ (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
+ ? 512 /* Based on some benchmarking, but not extensive, see commit
+ message */
+ : -1; /* Never return just an inversion list */
assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
assert(! invlist || minbits == 1);
ENTER;
SAVEHINTS();
save_re_context();
+ /* We might get here via a subroutine signature which uses a utf8
+ * parameter name, at which point PL_subname will have been set
+ * but not yet used. */
+ save_item(PL_subname);
if (PL_parser && PL_parser->error_count)
SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
if (!method) { /* demand load utf8 */
ENTER;
errsv_save = newSVsv(ERRSV);
+ SAVEFREESV(errsv_save);
/* It is assumed that callers of this routine are not passing in
* any user derived data. */
/* Need to do this after save_re_context() as it will set
* PL_tainted to 1 while saving $1 etc (see the code after getrx:
* in Perl_magic_get). Even line to create errsv_save can turn on
* PL_tainted. */
- SAVEBOOL(PL_tainted);
- PL_tainted = 0;
+#ifndef NO_TAINT_SUPPORT
+ SAVEBOOL(TAINT_get);
+ TAINT_NOT;
+#endif
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
NULL);
if (!SvTRUE(ERRSV))
sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(errsv_save);
LEAVE;
}
SPAGAIN;
mPUSHi(none);
PUTBACK;
errsv_save = newSVsv(ERRSV);
+ SAVEFREESV(errsv_save);
/* If we already have a pointer to the method, no need to use
* call_method() to repeat the lookup. */
if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
}
if (!SvTRUE(ERRSV))
sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(errsv_save);
LEAVE;
POPSTACK;
if (IN_PERL_COMPILETIME) {
if (SvPOK(retval))
/* If caller wants to handle missing properties, let them */
- if (return_if_undef) {
+ if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
return NULL;
}
Perl_croak(aTHX_
}
} /* End of calling the module to find the swash */
+ /* If this operation fetched a swash, and we will need it later, get it */
+ if (retval != &PL_sv_undef
+ && (minbits == 1 || (flags_p
+ && ! (*flags_p
+ & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
+ {
+ swash_hv = MUTABLE_HV(SvRV(retval));
+
+ /* If we don't already know that there is a user-defined component to
+ * this swash, and the user has indicated they wish to know if there is
+ * one (by passing <flags_p>), find out */
+ if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
+ SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
+ if (user_defined && SvUV(*user_defined)) {
+ *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
+ }
+ }
+ }
+
/* Make sure there is an inversion list for binary properties */
if (minbits == 1) {
SV** swash_invlistsvp = NULL;
SV* swash_invlist = NULL;
bool invlist_in_swash_is_valid = FALSE;
- HV* swash_hv = NULL;
/* If this operation fetched a swash, get its already existing
- * inversion list or create one for it */
- if (retval != &PL_sv_undef) {
- swash_hv = MUTABLE_HV(SvRV(retval));
+ * inversion list, or create one for it */
- swash_invlistsvp = hv_fetchs(swash_hv, "INVLIST", FALSE);
+ if (swash_hv) {
+ swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
if (swash_invlistsvp) {
swash_invlist = *swash_invlistsvp;
invlist_in_swash_is_valid = TRUE;
}
else {
- /* Here, there is no swash already. Set up a minimal one */
- swash_hv = newHV();
- retval = newRV_inc(MUTABLE_SV(swash_hv));
+ /* Here, there is no swash already. Set up a minimal one, if
+ * we are going to return a swash */
+ if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
+ swash_hv = newHV();
+ retval = newRV_inc(MUTABLE_SV(swash_hv));
+ }
swash_invlist = invlist;
}
-
- if (passed_in_invlist_has_user_defined_property) {
- if (! hv_stores(swash_hv, "USER_DEFINED", newSVuv(1))) {
- Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
- }
- }
}
/* Here, we have computed the union of all the passed-in data. It may
* be that there was an inversion list in the swash which didn't get
* touched; otherwise save the one computed one */
- if (! invlist_in_swash_is_valid) {
- if (! hv_stores(MUTABLE_HV(SvRV(retval)), "INVLIST", swash_invlist))
+ if (! invlist_in_swash_is_valid
+ && (int) _invlist_len(swash_invlist) > invlist_swash_boundary)
+ {
+ if (! hv_stores(MUTABLE_HV(SvRV(retval)), "V", swash_invlist))
{
Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
}
}
+
+ if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
+ SvREFCNT_dec(retval);
+ retval = newRV_inc(swash_invlist);
+ }
}
return retval;
PERL_ARGS_ASSERT_SWASH_FETCH;
+ /* If it really isn't a hash, it isn't really swash; must be an inversion
+ * list */
+ if (SvTYPE(hv) != SVt_PVHV) {
+ return _invlist_contains_cp((SV*)hv,
+ (do_utf8)
+ ? valid_utf8_to_uvchr(ptr, NULL)
+ : c);
+ }
+
/* Convert to utf8 if not already */
if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
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 *l, *lend, *x, *xend, *s, *send;
STRLEN lcur, xcur, scur;
HV *const hv = MUTABLE_HV(SvRV(swash));
- SV** const invlistsvp = hv_fetchs(hv, "INVLIST", FALSE);
+ SV** const invlistsvp = hv_fetchs(hv, "V", FALSE);
SV** listsvp = NULL; /* The string containing the main body of the table */
SV** extssvp = NULL;
Perl__swash_inversion_hash(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 regcomp.c and regexec.c
* Can't be used on a property that is subject to user override, as it
* relies on the value of SPECIALS in the swash which would be set by
* utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
(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;
}
+SV*
+Perl__get_swash_invlist(pTHX_ SV* const swash)
+{
+ SV** ptr;
+
+ PERL_ARGS_ASSERT__GET_SWASH_INVLIST;
+
+ if (! SvROK(swash)) {
+ return NULL;
+ }
+
+ /* If it really isn't a hash, it isn't really swash; must be an inversion
+ * list */
+ if (SvTYPE(SvRV(swash)) != SVt_PVHV) {
+ return SvRV(swash);
+ }
+
+ ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "V", FALSE);
+ if (! ptr) {
+ return NULL;
+ }
+
+ return *ptr;
+}
+
/*
=for apidoc uvchr_to_utf8
C<s2>.
If C<pe1> is non-NULL and the pointer it points to is not NULL, that pointer is
-considered an end pointer beyond which scanning of C<s1> will not continue under
-any circumstances. This means that if both C<l1> and C<pe1> are specified, and
-C<pe1>
+considered an end pointer to the position 1 byte past the maximum point
+in C<s1> beyond which scanning will not continue under any circumstances.
+(This routine assumes that UTF-8 encoded input strings are not malformed;
+malformed input can cause it to read past C<pe1>).
+This means that if both C<l1> and C<pe1> are specified, and C<pe1>
is less than C<s1>+C<l1>, the match will never be successful because it can
never
get as far as its goal (and in fact is asserted against). Correspondingly for
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)
{
dVAR;
- register const U8 *p1 = (const U8*)s1; /* Point to current char */
- register const U8 *p2 = (const U8*)s2;
- register const U8 *g1 = NULL; /* goal for s1 */
- register const U8 *g2 = NULL;
- register const U8 *e1 = NULL; /* Don't scan s1 past this */
- register U8 *f1 = NULL; /* Point to current folded */
- register const U8 *e2 = NULL;
- register U8 *f2 = NULL;
+ const U8 *p1 = (const U8*)s1; /* Point to current char */
+ const U8 *p2 = (const U8*)s2;
+ const U8 *g1 = NULL; /* goal for s1 */
+ const U8 *g2 = NULL;
+ const U8 *e1 = NULL; /* Don't scan s1 past this */
+ U8 *f1 = NULL; /* Point to current folded */
+ const U8 *e2 = NULL;
+ U8 *f2 = NULL;
STRLEN n1 = 0, n2 = 0; /* Number of bytes in current char */
U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
* 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