*d++ = UTF_TO_NATIVE(uv);
return d;
}
-#if defined(EBCDIC) || 1 /* always for testing */
+#if defined(EBCDIC)
else {
STRLEN len = UNISKIP(uv);
U8 *p = d+len-1;
case UTF8_WARN_SHORT:
Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
curlen, curlen == 1 ? "" : "s", expectlen);
+ expectlen = curlen; /* distance for caller to skip */
break;
case UTF8_WARN_OVERFLOW:
Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
/* for now these are all defined (inefficiently) in terms of the utf8 versions */
bool
-Perl_is_uni_alnum(pTHX_ U32 c)
+Perl_is_uni_alnum(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_alnumc(pTHX_ U32 c)
+Perl_is_uni_alnumc(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_idfirst(pTHX_ U32 c)
+Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_alpha(pTHX_ U32 c)
+Perl_is_uni_alpha(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_ascii(pTHX_ U32 c)
+Perl_is_uni_ascii(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_space(pTHX_ U32 c)
+Perl_is_uni_space(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_digit(pTHX_ U32 c)
+Perl_is_uni_digit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_upper(pTHX_ U32 c)
+Perl_is_uni_upper(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_lower(pTHX_ U32 c)
+Perl_is_uni_lower(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_cntrl(pTHX_ U32 c)
+Perl_is_uni_cntrl(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_graph(pTHX_ U32 c)
+Perl_is_uni_graph(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_print(pTHX_ U32 c)
+Perl_is_uni_print(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_punct(pTHX_ U32 c)
+Perl_is_uni_punct(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
uvchr_to_utf8(tmpbuf, (UV)c);
}
bool
-Perl_is_uni_xdigit(pTHX_ U32 c)
+Perl_is_uni_xdigit(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
uvchr_to_utf8(tmpbuf, (UV)c);
return is_utf8_xdigit(tmpbuf);
}
-U32
-Perl_to_uni_upper(pTHX_ U32 c, U8* p, STRLEN *lenp)
+UV
+Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
uvchr_to_utf8(tmpbuf, (UV)c);
return to_utf8_upper(tmpbuf, p, lenp);
}
-U32
-Perl_to_uni_title(pTHX_ U32 c, U8* p, STRLEN *lenp)
+UV
+Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
uvchr_to_utf8(tmpbuf, (UV)c);
return to_utf8_title(tmpbuf, p, lenp);
}
-U32
-Perl_to_uni_lower(pTHX_ U32 c, U8* p, STRLEN *lenp)
+UV
+Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
uvchr_to_utf8(tmpbuf, (UV)c);
return to_utf8_lower(tmpbuf, p, lenp);
}
+UV
+Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
+{
+ U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
+ uvchr_to_utf8(tmpbuf, (UV)c);
+ return to_utf8_fold(tmpbuf, p, lenp);
+}
+
/* for now these all assume no locale info available for Unicode > 255 */
bool
-Perl_is_uni_alnum_lc(pTHX_ U32 c)
+Perl_is_uni_alnum_lc(pTHX_ UV c)
{
return is_uni_alnum(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_alnumc_lc(pTHX_ U32 c)
+Perl_is_uni_alnumc_lc(pTHX_ UV c)
{
return is_uni_alnumc(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_idfirst_lc(pTHX_ U32 c)
+Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
return is_uni_idfirst(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_alpha_lc(pTHX_ U32 c)
+Perl_is_uni_alpha_lc(pTHX_ UV c)
{
return is_uni_alpha(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_ascii_lc(pTHX_ U32 c)
+Perl_is_uni_ascii_lc(pTHX_ UV c)
{
return is_uni_ascii(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_space_lc(pTHX_ U32 c)
+Perl_is_uni_space_lc(pTHX_ UV c)
{
return is_uni_space(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_digit_lc(pTHX_ U32 c)
+Perl_is_uni_digit_lc(pTHX_ UV c)
{
return is_uni_digit(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_upper_lc(pTHX_ U32 c)
+Perl_is_uni_upper_lc(pTHX_ UV c)
{
return is_uni_upper(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_lower_lc(pTHX_ U32 c)
+Perl_is_uni_lower_lc(pTHX_ UV c)
{
return is_uni_lower(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_cntrl_lc(pTHX_ U32 c)
+Perl_is_uni_cntrl_lc(pTHX_ UV c)
{
return is_uni_cntrl(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_graph_lc(pTHX_ U32 c)
+Perl_is_uni_graph_lc(pTHX_ UV c)
{
return is_uni_graph(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_print_lc(pTHX_ U32 c)
+Perl_is_uni_print_lc(pTHX_ UV c)
{
return is_uni_print(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_punct_lc(pTHX_ U32 c)
+Perl_is_uni_punct_lc(pTHX_ UV c)
{
return is_uni_punct(c); /* XXX no locale support yet */
}
bool
-Perl_is_uni_xdigit_lc(pTHX_ U32 c)
+Perl_is_uni_xdigit_lc(pTHX_ UV c)
{
return is_uni_xdigit(c); /* XXX no locale support yet */
}
return swash_fetch(PL_utf8_mark, p, TRUE);
}
+/*
+=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
+
+The "p" contains the pointer to the UTF-8 string encoding
+the character that is being converted.
+
+The "ustrp" is a pointer to the character buffer to put the
+conversion result to. The "lenp" is a pointer to the length
+of the result.
+
+The "swash" is a pointer to the swash to use.
+
+The "normal" is a string like "ToLower" which means the swash
+$utf8::ToLower, which is stored in lib/unicore/To/Lower.pl,
+and loaded by SWASHGET, using lib/utf8_heavy.pl.
+
+The "special" is a string like "utf8::ToSpecLower", which means
+the hash %utf8::ToSpecLower, which is stored in the same file,
+lib/unicore/To/Lower.pl, and also loaded by SWASHGET. The access
+to the hash is by Perl_to_utf8_case().
+
+=cut
+ */
+
UV
-Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
{
UV uv;
- if (!PL_utf8_toupper)
- PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
- uv = swash_fetch(PL_utf8_toupper, p, TRUE);
- uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
- *lenp = UNISKIP(uv);
+ if (!*swashp)
+ *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
+ uv = swash_fetch(*swashp, p, TRUE);
+ if (uv)
+ uv = UNI_TO_NATIVE(uv);
+ else {
+ HV *hv;
+ SV *keysv;
+ HE *he;
+
+ uv = utf8_to_uvchr(p, 0);
+
+ if ((hv = get_hv(special, FALSE)) &&
+ (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv))) &&
+ (he = hv_fetch_ent(hv, keysv, FALSE, 0))) {
+ SV *val = HeVAL(he);
+ char *s = SvPV(val, *lenp);
+ U8 c = *(U8*)s;
+ if (*lenp > 1 || UNI_IS_INVARIANT(c))
+ Copy(s, ustrp, *lenp, U8);
+ else {
+ /* something in the 0x80..0xFF range */
+ ustrp[0] = UTF8_EIGHT_BIT_HI(c);
+ ustrp[1] = UTF8_EIGHT_BIT_LO(c);
+ *lenp = 2;
+ }
+ return 0;
+ }
+ }
+ if (lenp)
+ *lenp = UNISKIP(uv);
uvuni_to_utf8(ustrp, uv);
return uv;
}
UV
-Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
- UV uv;
+ return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+ &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
+}
- if (!PL_utf8_totitle)
- PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
- uv = swash_fetch(PL_utf8_totitle, p, TRUE);
- uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
- *lenp = UNISKIP(uv);
- uvuni_to_utf8(ustrp, uv);
- return uv;
+UV
+Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+ &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
}
UV
Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
- UV uv;
+ return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+ &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
+}
- if (!PL_utf8_tolower)
- PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
- uv = swash_fetch(PL_utf8_tolower, p, TRUE);
- uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
- *lenp = UNISKIP(uv);
- uvuni_to_utf8(ustrp, uv);
- return uv;
+UV
+Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+{
+ return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+ &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
}
/* a "swash" is a swatch hash */
return retval;
}
+
+/* This API is wrong for special case conversions since we may need to
+ * return several Unicode characters for a single Unicode character
+ * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
+ * the lower-level routine, and it is similarly broken for returning
+ * multiple values. --jhi */
UV
Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
{
U32 off;
STRLEN slen;
STRLEN needents;
- U8 *tmps;
+ U8 *tmps = NULL;
U32 bit;
SV *retval;
U8 tmputf8[2];
return UNI_TO_NATIVE(uv);
}
+/*
+=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
+
+Build to the scalar dsv a displayable version of the string spv,
+length len, the displayable version being at most pvlim bytes long
+(if longer, the rest is truncated and "..." will be appended).
+The flags argument is currently unused but available for future extensions.
+The pointer to the PV of the dsv is returned.
+
+=cut */
+char *
+Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+{
+ int truncated = 0;
+ char *s, *e;
+
+ sv_setpvn(dsv, "", 0);
+ for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
+ UV u;
+ if (pvlim && SvCUR(dsv) >= pvlim) {
+ truncated++;
+ break;
+ }
+ u = utf8_to_uvchr((U8*)s, 0);
+ Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
+ }
+ if (truncated)
+ sv_catpvn(dsv, "...", 3);
+
+ return SvPVX(dsv);
+}
+
+/*
+=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
+
+Build to the scalar dsv a displayable version of the scalar sv,
+he displayable version being at most pvlim bytes long
+(if longer, the rest is truncated and "..." will be appended).
+The flags argument is currently unused but available for future extensions.
+The pointer to the PV of the dsv is returned.
+
+=cut */
+char *
+Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
+{
+ return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
+ pvlim, flags);
+}
+
+/*
+=for apidoc A|I32|ibcmp_utf8|const char *s1|bool u1|const char *s2|bool u2|register I32 len
+
+Return true if the strings s1 and s2 differ case-insensitively, false
+if not (if they are equal case-insensitively). If u1 is true, the
+string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
+the string s2 is assumed to be in UTF-8-encoded Unicode.
+
+For case-insensitiveness, the "casefolding" of Unicode is used
+instead of upper/lowercasing both the characters, see
+http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
+
+=cut */
+I32
+Perl_ibcmp_utf8(pTHX_ const char *s1, bool u1, register I32 len1, const char *s2, bool u2, register I32 len2)
+{
+ register U8 *a = (U8*)s1;
+ register U8 *b = (U8*)s2;
+ register U8 *ae = b + len1;
+ register U8 *be = b + len2;
+ STRLEN la, lb;
+ UV ca, cb;
+ STRLEN ulen1, ulen2;
+ U8 tmpbuf1[UTF8_MAXLEN_FOLD+1];
+ U8 tmpbuf2[UTF8_MAXLEN_FOLD+1];
+
+ while (a < ae && b < be) {
+ if (u1) {
+ if (a + UTF8SKIP(a) > ae)
+ break;
+ ca = utf8_to_uvchr((U8*)a, &la);
+ } else {
+ ca = *a;
+ la = 1;
+ }
+ if (u2) {
+ if (b + UTF8SKIP(b) > be)
+ break;
+ cb = utf8_to_uvchr((U8*)b, &lb);
+ } else {
+ cb = *b;
+ lb = 1;
+ }
+ if (ca != cb) {
+ if (u1)
+ to_uni_fold(NATIVE_TO_UNI(ca), tmpbuf1, &ulen1);
+ else
+ ulen1 = 1;
+ if (u2)
+ to_uni_fold(NATIVE_TO_UNI(cb), tmpbuf2, &ulen2);
+ else
+ ulen2 = 1;
+ if (ulen1 != ulen2
+ || (ulen1 == 1 && PL_fold[ca] != PL_fold[cb])
+ || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
+ return 1; /* mismatch */
+ }
+ a += la;
+ b += lb;
+ }
+ return a == ae && b == be ? 0 : 1; /* 0 match, 1 mismatch */
+}