#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
/*
=for apidoc uvuni_to_utf8_flags
-Adds the UTF-8 representation of the code point C<uv> to the end
+Adds the UTF-8 representation of the Unicode code point C<uv> to the end
of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
*(d++) = uv;
+where uv is a code point expressed in Latin-1 or above, not the platform's
+native character set. B<Almost all code should instead use L</uvchr_to_utf8>
+or L</uvchr_to_utf8_flags>>.
+
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 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
+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
return d;
}
#endif
-#endif /* Loop style */
+#endif /* Non loop style */
}
/*
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 */
/*
=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
if (UTF8_IS_INVARIANT(*x)) {
x++;
}
- else if (!UTF8_IS_START(*x))
- return FALSE;
else {
/* ... and call is_utf8_char() only if really needed. */
const STRLEN c = UTF8SKIP(x);
/* Inline the easy bits of is_utf8_char() here for speed... */
if (UTF8_IS_INVARIANT(*x))
next_char_ptr = x + 1;
- else if (!UTF8_IS_START(*x))
- goto out;
else {
/* ... and call is_utf8_char() only if really needed. */
c = UTF8SKIP(x);
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.
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_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>. surrogates,
- * non-character code points, and non-Unicode code points are allowed */
+ * 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)
/*
=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.
uv &= UTF_START_MASK(expectlen);
/* Now, loop through the remaining bytes, accumulating each into the
- * working total as we go */
+ * 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);
}
/*
=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.
if (e < s)
goto warn_and_return;
while (s < e) {
- if (!UTF8_IS_INVARIANT(*s))
- s += UTF8SKIP(s);
- else
- s++;
+ s += UTF8SKIP(s);
len++;
}
*d++ = (U8)(( uv & 0x3f) | 0x80);
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");
}
if (uv < 0x10000) {
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
bool
Perl_is_uni_blank(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_blank(tmpbuf);
+ return isBLANK_uni(c);
}
bool
Perl_is_uni_space(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_space(tmpbuf);
+ return isSPACE_uni(c);
}
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
Perl_is_uni_xdigit(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_xdigit(tmpbuf);
+ return isXDIGIT_uni(c);
}
UV
}
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 */
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(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_WORDCHAR, c);
+}
+
+bool
+Perl_is_uni_alnumc_lc(pTHX_ UV c)
+{
+ if (c < 256) {
+ return isALPHANUMERIC_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_ALPHANUMERIC, c);
}
bool
Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
- return is_uni_idfirst(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isIDFIRST_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_perl_idstart(c);
}
bool
Perl_is_uni_alpha_lc(pTHX_ UV c)
{
- return is_uni_alpha(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALPHA_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_FOO(_CC_ALPHA, c);
}
bool
Perl_is_uni_ascii_lc(pTHX_ UV c)
{
- return is_uni_ascii(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isASCII_LC(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(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(UNI_TO_NATIVE(c));
+ }
+ return isXDIGIT_uni(c);
}
U32
return (U32)to_uni_lower(c, tmpbuf, &len);
}
-static bool
+PERL_STATIC_INLINE bool
S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
const char *const swashname)
{
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 (!*swash)
- *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
+ 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_BLANK;
- return is_utf8_common(p, &PL_utf8_blank, "XPosixBlank");
+ return isBLANK_utf8(p);
}
bool
PERL_ARGS_ASSERT_IS_UTF8_SPACE;
- return is_utf8_common(p, &PL_utf8_space, "IsXPerlSpace");
+ return isSPACE_utf8(p);
}
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_CNTRL;
- if (isASCII(*p)) {
- return isCNTRL_A(*p);
- }
-
- /* All controls are in Latin1 */
- if (! UTF8_IS_DOWNGRADEABLE_START(*p)) {
- return 0;
- }
- return isCNTRL_L1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ return isCNTRL_utf8(p);
}
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
PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
- return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
+ return is_XDIGIT_utf8(p);
}
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_begin(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
-
- return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
-}
-
-bool
-Perl_is_utf8_X_extend(pTHX_ const U8 *p)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
-
- 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, "_X_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, "_X_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, "_X_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, "_X_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, "_X_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, "_X_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, "_X_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)
+Perl_is_utf8_mark(pTHX_ const U8 *p)
{
- /* For exclusive use of pp_quotemeta() */
-
dVAR;
- PERL_ARGS_ASSERT__IS_UTF8_QUOTEMETA;
+ PERL_ARGS_ASSERT_IS_UTF8_MARK;
- return is_utf8_common(p, &PL_utf8_quotemeta, "_Perl_Quotemeta");
+ return _is_utf8_mark(p);
}
/*
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,
/* 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 (p != ustrp) { /* Don't copy onto itself */
+ Copy(p, ustrp, len, U8);
+ }
if (lenp)
*lenp = len;
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 */
/*
=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 */
/*
=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 */
/*
=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_UNI(*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))));
+ 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 this character, 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;
+ }
return check_locale_boundary_crossing(p, result, ustrp, lenp);
}
else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
if (isASCII(*s)) {
/* Crossed, have to return the original */
original = valid_utf8_to_uvchr(p, lenp);
+
+ /* But in this one instance, there is an alternative we can
+ * return that is valid */
+ if (original == LATIN_CAPITAL_LETTER_SHARP_S) {
+ goto return_long_s;
+ }
Copy(p, ustrp, *lenp, char);
return original;
}
*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;
}
/* Note:
* 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(), _get_swash_invlist(),
+ * and swash_to_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);
+ 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
* 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);
+ {
+ /* 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;
}
SPAGAIN;
mPUSHi(minbits);
mPUSHi(none);
PUTBACK;
- errsv_save = newSVsv(ERRSV);
+ 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 ? call_sv(MUTABLE_SV(method), G_SCALAR)
+ if (method
+ ? call_sv(MUTABLE_SV(method), G_SCALAR)
: call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
{
retval = *PL_stack_sp--;
SvREFCNT_inc(retval);
}
- if (!SvTRUE(ERRSV))
- sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(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;
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;
+ bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
+ an unclaimed reference count */
/* 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 {
swash_invlist = _swash_to_invlist(retval);
+ swash_invlist_unclaimed = 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_noinc(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");
}
+ /* We just stole a reference count. */
+ if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
+ else SvREFCNT_inc_simple_void_NN(swash_invlist);
}
+
+ /* Use the inversion list stand-alone if small enough */
+ if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
+ SvREFCNT_dec(retval);
+ if (!swash_invlist_unclaimed)
+ SvREFCNT_inc_simple_void_NN(swash_invlist);
+ retval = newRV_noinc(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);
* 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
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
STRLEN lcur;
HV *const hv = MUTABLE_HV(SvRV(swash));
- /* The string containing the main body of the table */
+ /* The string containing the main body of the table. This will have its
+ * assertion fail if the swash has been converted to its inversion list */
SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
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;
HV *const hv = MUTABLE_HV(SvRV(swash));
UV elements = 0; /* Number of elements in the inversion list */
U8 empty[] = "";
+ SV** listsvp;
+ SV** typesvp;
+ SV** bitssvp;
+ SV** extssvp;
+ SV** invert_it_svp;
- /* The string containing the main body of the table */
- SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
- SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
- SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
- SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
-
- const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
- const STRLEN bits = SvUV(*bitssvp);
- const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ U8* typestr;
+ STRLEN bits;
+ STRLEN octets; /* if bits == 1, then octets == 0 */
U8 *x, *xend;
STRLEN xcur;
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 SvREFCNT_inc_simple_NN((SV*) hv);
+ }
+
+ /* The string containing the main body of the table */
+ listsvp = hv_fetchs(hv, "LIST", FALSE);
+ typesvp = hv_fetchs(hv, "TYPE", FALSE);
+ bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+ invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
+
+ typestr = (U8*)SvPV_nolen(*typesvp);
+ bits = SvUV(*bitssvp);
+ octets = bits >> 3; /* if bits == 1, then octets == 0 */
+
/* 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 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);
+ 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;
}
}
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);
}
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
* 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;
- 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];
f1 = (U8 *) p1;
n1 = UTF8SKIP(f1);
}
-
else {
/* If in locale matching, we use two sets of rules, depending
* on if the code point is above or below 255. Here, we test
* for and handle locale rules */
if ((flags & FOLDEQ_UTF8_LOCALE)
- && (! u1 || UTF8_IS_INVARIANT(*p1)
- || UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ && (! 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;
}
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 {
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)) {
return 0;
}
n2 = 1;
- *foldbuf2 = toLOWER(*p2);
+ *foldbuf2 = toFOLD(*p2);
}
else if (u2) {
to_utf8_fold(p2, foldbuf2, &n2);