static const char unees[] =
"Malformed UTF-8 character (unexpected end of string)";
static const char cp_above_legal_max[] =
- "It is deprecated to use code point 0x%"UVXf"; the permissible max is 0x%"UVXf"";
+ "Use of code point 0x%"UVXf" is deprecated; the permissible max is 0x%"UVXf"";
-#define MAX_NON_DEPRECATED_CP (IV_MAX)
+#define MAX_NON_DEPRECATED_CP ((UV) (IV_MAX))
/*
=head1 Unicode Support
*d++ = LATIN1_TO_NATIVE(uv);
return d;
}
+
if (uv <= MAX_UTF8_TWO_BYTE) {
- *d++ = UTF8_TWO_BYTE_HI(uv);
- *d++ = UTF8_TWO_BYTE_LO(uv);
+ *d++ = I8_TO_NATIVE_UTF8(( uv >> SHIFT) | UTF_START_MARK(2));
+ *d++ = I8_TO_NATIVE_UTF8(( uv & MASK) | MARK);
return d;
}
*/
U8 *
-Perl_utf8_hop(const U8 *s, I32 off)
+Perl_utf8_hop(const U8 *s, SSize_t off)
{
PERL_ARGS_ASSERT_UTF8_HOP;
}
/* change namve uv1 to 'from' */
-UV
+STATIC UV
S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
SV **swashp, const char *normal, const char *special)
{
PERL_ARGS_ASSERT__TO_UTF8_CASE;
- /* Note that swash_fetch() doesn't output warnings for these because it
- * assumes we will */
- if (uv1 >= UNICODE_SURROGATE_FIRST) {
- if (UNLIKELY(uv1 <= UNICODE_SURROGATE_LAST)) {
- 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);
- }
+ /* For code points that don't change case, we already know that the output
+ * of this function is the unchanged input, so we can skip doing look-ups
+ * for them. Unfortunately the case-changing code points are scattered
+ * around. But there are some long consecutive ranges where there are no
+ * case changing code points. By adding tests, we can eliminate the lookup
+ * for all the ones in such ranges. This is currently done here only for
+ * just a few cases where the scripts are in common use in modern commerce
+ * (and scripts adjacent to those which can be included without additional
+ * tests). */
+
+ if (uv1 >= 0x0590) {
+ /* This keeps from needing further processing the code points most
+ * likely to be used in the following non-cased scripts: Hebrew,
+ * Arabic, Syriac, Thaana, NKo, Samaritan, Mandaic, Devanagari,
+ * Bengali, Gurmukhi, Gujarati, Oriya, Tamil, Telugu, Kannada,
+ * Malayalam, Sinhala, Thai, Lao, Tibetan, Myanmar */
+ if (uv1 < 0x10A0) {
goto cases_to_self;
- }
- if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
- if ( UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)
- && ckWARN_d(WARN_DEPRECATED))
- {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP);
+ }
+
+ /* The following largish code point ranges also don't have case
+ * changes, but khw didn't think they warranted extra tests to speed
+ * them up (which would slightly slow down everything else above them):
+ * 1100..139F Hangul Jamo, Ethiopic
+ * 1400..1CFF Unified Canadian Aboriginal Syllabics, Ogham, Runic,
+ * Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Mongolian,
+ * Limbu, Tai Le, New Tai Lue, Buginese, Tai Tham,
+ * Combining Diacritical Marks Extended, Balinese,
+ * Sundanese, Batak, Lepcha, Ol Chiki
+ * 2000..206F General Punctuation
+ */
+
+ if (uv1 >= 0x2D30) {
+
+ /* This keeps the from needing further processing the code points
+ * most likely to be used in the following non-cased major scripts:
+ * CJK, Katakana, Hiragana, plus some less-likely scripts.
+ *
+ * (0x2D30 above might have to be changed to 2F00 in the unlikely
+ * event that Unicode eventually allocates the unused block as of
+ * v8.0 2FE0..2FEF to code points that are cased. khw has verified
+ * that the test suite will start having failures to alert you
+ * should that happen) */
+ if (uv1 < 0xA640) {
+ goto cases_to_self;
}
- 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);
- }
- goto cases_to_self;
- }
+
+ if (uv1 >= 0xAC00) {
+ if (UNLIKELY(UNICODE_IS_SURROGATE(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);
+ }
+ goto cases_to_self;
+ }
+
+ /* AC00..FAFF Catches Hangul syllables and private use, plus
+ * some others */
+ if (uv1 < 0xFB00) {
+ goto cases_to_self;
+
+ }
+
+ if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
+ if ( UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)
+ && ckWARN_d(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP);
+ }
+ 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);
+ }
+ goto cases_to_self;
+ }
+#ifdef HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C
+ if (UNLIKELY(uv1
+ > HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C))
+ {
+
+ /* As of this writing, this means we avoid swash creation
+ * for anything beyond low Plane 1 */
+ goto cases_to_self;
+ }
+#endif
+ }
+ }
/* Note that non-characters are perfectly legal, so no warning should
- * be given */
+ * be given. There are so few of them, that it isn't worth the extra
+ * tests to avoid swash creation */
}
if (!*swashp) /* load on-demand */
CopHINTS_set(PL_curcop, PL_hints);
}
if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
- if (SvPOK(retval))
+ if (SvPOK(retval)) {
/* If caller wants to handle missing properties, let them */
if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
"Can't find Unicode property definition \"%"SVf"\"",
SVfARG(retval));
NOT_REACHED; /* NOTREACHED */
+ }
}
} /* End of calling the module to find the swash */
while ((from_list = (AV *) hv_iternextsv(specials_inverse,
&char_to, &to_len)))
{
- if (av_tindex(from_list) > 0) {
+ if (av_tindex_nomg(from_list) > 0) {
SSize_t i;
/* We iterate over all combinations of i,j to place each code
* point on each list */
- for (i = 0; i <= av_tindex(from_list); i++) {
+ for (i = 0; i <= av_tindex_nomg(from_list); i++) {
SSize_t j;
AV* i_list = newAV();
SV** entryp = av_fetch(from_list, i, FALSE);
}
/* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
- for (j = 0; j <= av_tindex(from_list); j++) {
+ for (j = 0; j <= av_tindex_nomg(from_list); j++) {
entryp = av_fetch(from_list, j, FALSE);
if (entryp == NULL) {
Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
/* Look through list to see if this inverse mapping already is
* listed, or if there is a mapping to itself already */
- for (i = 0; i <= av_tindex(list); i++) {
+ for (i = 0; i <= av_tindex_nomg(list); i++) {
SV** entryp = av_fetch(list, i, FALSE);
SV* entry;
UV uv;
https://perl5.git.perl.org / perl5.git / blobdiff