if (ckWARN_d(WARN_UTF8)) {
if (UNICODE_IS_SURROGATE(uv)) {
if (flags & UNICODE_WARN_SURROGATE) {
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),
"UTF-16 surrogate U+%04"UVXf, uv);
}
if (flags & UNICODE_DISALLOW_SURROGATE) {
if (flags & UNICODE_WARN_SUPER
|| (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_WARN_FE_FF)))
{
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE),
"Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
}
if (flags & UNICODE_DISALLOW_SUPER
}
else if (UNICODE_IS_NONCHAR(uv)) {
if (flags & UNICODE_WARN_NONCHAR) {
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),
"Unicode non-character U+%04"UVXf" is illegal for open interchange",
uv);
}
}
bool
+Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
+
+ if (*p == '_')
+ return TRUE;
+ /* is_utf8_idstart would be more logical. */
+ return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart");
+}
+
+bool
Perl_is_utf8_idcont(pTHX_ const U8 *p)
{
dVAR;
}
bool
+Perl_is_utf8_xidcont(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
+
+ if (*p == '_')
+ return TRUE;
+ return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue");
+}
+
+bool
Perl_is_utf8_alpha(pTHX_ const U8 *p)
{
dVAR;
/* Note that swash_fetch() doesn't output warnings for these because it
* assumes we will */
- if (uv1 >= UNICODE_SURROGATE_FIRST && ckWARN_d(WARN_UTF8)) {
+ if (uv1 >= UNICODE_SURROGATE_FIRST) {
if (uv1 <= UNICODE_SURROGATE_LAST) {
- const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1);
+ if (ckWARN_d(WARN_SURROGATE)) {
+ const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
+ Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
+ "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1);
+ }
}
else if (UNICODE_IS_SUPER(uv1)) {
- const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1);
+ if (ckWARN_d(WARN_NON_UNICODE)) {
+ const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
+ Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
+ "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1);
+ }
}
/* Note that non-characters are perfectly legal, so no warning should
/* If char is encoded then swatch is for the prefix */
needents = (1 << UTF_ACCUMULATION_SHIFT);
off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
- if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_UTF8)) {
+ if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
/* This outputs warnings for binary properties only, assuming that
* for, as that would warn on things like /\p{Gc=Cs}/ */
SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
if (SvUV(*bitssvp) == 1) {
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
"Code point 0x%04"UVXf" is not Unicode, no properties match it; all inverse properties do", code_point);
}
}
if (*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE) {
STRLEN char_len;
if (UTF8_IS_SUPER(s)) {
- UV uv = utf8_to_uvchr(s, &char_len);
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
- ok = FALSE;
+ if (ckWARN_d(WARN_NON_UNICODE)) {
+ UV uv = utf8_to_uvchr(s, &char_len);
+ Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
+ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
+ ok = FALSE;
+ }
}
else if (UTF8_IS_SURROGATE(s)) {
- UV uv = utf8_to_uvchr(s, &char_len);
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
- ok = FALSE;
+ if (ckWARN_d(WARN_SURROGATE)) {
+ UV uv = utf8_to_uvchr(s, &char_len);
+ Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
+ "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
+ ok = FALSE;
+ }
}
else if
- (UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
+ ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
+ && (ckWARN_d(WARN_NONCHAR)))
{
UV uv = utf8_to_uvchr(s, &char_len);
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ Perl_warner(aTHX_ packWARN(WARN_NONCHAR),
"Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
ok = FALSE;
}
* 0 for as-documented above
* FOLDEQ_UTF8_NOMIX_ASCII meaning that if a non-ASCII character folds to an
ASCII one, to not match
+ * FOLDEQ_UTF8_LOCALE meaning that locale rules are to be used for code
+ * points below 256; unicode rules for above 255; and
+ * folds that cross those boundaries are disallowed,
+ * like the NOMIX_ASCII option
*/
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)
while (p1 < e1 && p2 < e2) {
/* If at the beginning of a new character in s1, get its fold to use
- * and the length of the fold */
+ * and the length of the fold. (exception: locale rules just get the
+ * character to a single byte) */
if (n1 == 0) {
- if (isASCII(*p1)) {
- /* But if not to mix non- with ASCII, fail */
+ /* If in locale matching, we use two sets of rules, depending on if
+ * the code point is above or below 255. Here, we test for and
+ * handle locale rules */
+ if ((flags & FOLDEQ_UTF8_LOCALE)
+ && (! u1 || UTF8_IS_INVARIANT(*p1) || UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ {
+ /* There is no mixing of code points above and below 255. */
+ if (u2 && (! UTF8_IS_INVARIANT(*p2)
+ && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
+ {
+ return 0;
+ }
+
+ /* We handle locale rules by converting, if necessary, the code
+ * point to a single byte. */
+ if (! u1 || UTF8_IS_INVARIANT(*p1)) {
+ *foldbuf1 = *p1;
+ }
+ else {
+ *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
+ }
+ n1 = 1;
+ }
+ else if (isASCII(*p1)) { /* Note, that here won't be both ASCII
+ and using locale rules */
+
+ /* If trying to mix non- with ASCII, and not supposed to, fail */
if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
return 0;
}
n1 = 1;
- *foldbuf1 = toLOWER(*p1); /* ASCII range fold is lowercase */
+ *foldbuf1 = toLOWER(*p1); /* Folds in the ASCII range are
+ just lowercased */
}
else if (u1) {
to_utf8_fold(p1, foldbuf1, &n1);
}
if (n2 == 0) { /* Same for s2 */
- if (isASCII(*p2)) {
+ if ((flags & FOLDEQ_UTF8_LOCALE)
+ && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
+ {
+ /* Here, the next char in s2 is < 256. We've already worked on
+ * s1, and if it isn't also < 256, can't match */
+ if (u1 && (! UTF8_IS_INVARIANT(*p1)
+ && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
+ {
+ return 0;
+ }
+ if (! u2 || UTF8_IS_INVARIANT(*p2)) {
+ *foldbuf2 = *p2;
+ }
+ else {
+ *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
+ }
+
+ /* Use another function to handle locale rules. We've made
+ * sure that both characters to compare are single bytes */
+ if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
+ return 0;
+ }
+ n1 = n2 = 0;
+ }
+ else if (isASCII(*p2)) {
if (flags && ! isASCII(*p1)) {
return 0;
}
f2 = foldbuf2;
}
+ /* Here f1 and f2 point to the beginning of the strings to compare.
+ * These strings are the folds of the input characters, stored in utf8.
+ */
+
/* While there is more to look for in both folds, see if they
* continue to match */
while (n1 && n2) {
https://perl5.git.perl.org / perl5.git / blobdiff