/* Unicode support */
/*
-=for apidoc A|U8 *|uvuni_to_utf8|U8 *d|UV uv
+=for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
+ d = uvuni_to_utf8_flags(d, uv, flags);
+
+or, in most cases,
+
d = uvuni_to_utf8(d, uv);
+(which is equivalent to)
+
+ d = uvuni_to_utf8_flags(d, uv, 0);
+
is the recommended Unicode-aware way of saying
*(d++) = uv;
*/
U8 *
-Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
-{
+Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+{
+ if (ckWARN_d(WARN_UTF8)) {
+ if (UNICODE_IS_SURROGATE(uv) &&
+ !(flags & UNICODE_ALLOW_SURROGATE))
+ Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv);
+ else if (
+ ((uv >= 0xFDD0 && uv <= 0xFDEF &&
+ !(flags & UNICODE_ALLOW_FDD0))
+ ||
+ ((uv & 0xFFFF) == 0xFFFE &&
+ !(flags & UNICODE_ALLOW_FFFE))
+ ||
+ ((uv & 0xFFFF) == 0xFFFF &&
+ !(flags & UNICODE_ALLOW_FFFF))) &&
+ /* UNICODE_ALLOW_SUPER includes
+ * FFFEs and FFFFs beyond 0x10FFFF. */
+ ((uv <= PERL_UNICODE_MAX) ||
+ !(flags & UNICODE_ALLOW_SUPER))
+ )
+ Perl_warner(aTHX_ WARN_UTF8,
+ "Unicode character 0x%04"UVxf" is illegal", uv);
+ }
if (UNI_IS_INVARIANT(uv)) {
*d++ = UTF_TO_NATIVE(uv);
return d;
#endif
#endif /* Loop style */
}
-
+
+U8 *
+Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
+{
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
+}
/*
UV
Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
+ U8 *s0 = s;
UV uv = *s, ouv = 0;
STRLEN len = 1;
bool dowarn = ckWARN_d(WARN_UTF8);
+ UV startbyte = *s;
STRLEN expectlen = 0;
U32 warning = 0;
Perl_sv_catpvf(aTHX_ sv, "(empty string)");
break;
case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
break;
case UTF8_WARN_NON_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
- (UV)s[1], uv);
+ if (s == s0)
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
+ (UV)s[1], startbyte);
+ else
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
+ (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
+
break;
case UTF8_WARN_FE_FF:
Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
break;
case UTF8_WARN_SHORT:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
- curlen, curlen == 1 ? "" : "s", expectlen);
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
expectlen = curlen; /* distance for caller to skip */
break;
case UTF8_WARN_OVERFLOW:
- Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
- ouv, *s);
+ Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
+ ouv, *s, startbyte);
break;
case UTF8_WARN_SURROGATE:
Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
break;
case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
- expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
break;
case UTF8_WARN_FFFF:
Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
bool
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);
}
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);
}
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);
}
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+1];
+ U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
uvchr_to_utf8(tmpbuf, (UV)c);
return to_utf8_fold(tmpbuf, p, lenp);
}
return is_uni_xdigit(c); /* XXX no locale support yet */
}
+U32
+Perl_to_uni_upper_lc(pTHX_ U32 c)
+{
+ /* XXX returns only the first character -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_upper(c, tmpbuf, &len);
+}
+
+U32
+Perl_to_uni_title_lc(pTHX_ U32 c)
+{
+ /* XXX returns only the first character XXX -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_title(c, tmpbuf, &len);
+}
+
+U32
+Perl_to_uni_lower_lc(pTHX_ U32 c)
+{
+ /* XXX returns only the first character -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_lower(c, tmpbuf, &len);
+}
+
bool
Perl_is_utf8_alnum(pTHX_ U8 *p)
{
return 0;
}
}
- *lenp = UNISKIP(uv);
+ if (lenp)
+ *lenp = UNISKIP(uv);
uvuni_to_utf8(ustrp, uv);
return uv;
}
U8 *
Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
{
- return Perl_uvuni_to_utf8(aTHX_ d, NATIVE_TO_UNI(uv));
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
}
+U8 *
+Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+{
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
+}
/*
=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
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)
{
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)
{
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, const char *s2, bool u2, register I32 len)
+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 *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*3+1];
- U8 tmpbuf2[UTF8_MAXLEN*3+1];
-
- while (len) {
- if (u1)
+ 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 {
+ } else {
ca = *a;
la = 1;
}
- if (u2)
+ if (u2) {
+ if (b + UTF8SKIP(b) > be)
+ break;
cb = utf8_to_uvchr((U8*)b, &lb);
- else {
+ } else {
cb = *b;
lb = 1;
}
if (ulen1 != ulen2
|| (ulen1 == 1 && PL_fold[ca] != PL_fold[cb])
|| memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
- return 1;
+ return 1; /* mismatch */
}
a += la;
b += lb;
- }
- return 0;
+ }
+ return a == ae && b == be ? 0 : 1; /* 0 match, 1 mismatch */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff