X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=743dea4b5c6f8fa4e1cd6f36b81047f419b4e6ec;hb=360321b398f5e797c408b6d6c60b7da3cca5e324;hp=ecc77c009e82da1864badfcb0920a6e56463ae7c;hpb=3b0fc154d4e77cfb1d426144cb362eb2fa6018f1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index ecc77c0..743dea4 100644 --- a/utf8.c +++ b/utf8.c @@ -173,61 +173,82 @@ Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv) return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0); } - /* -=for apidoc A|STRLEN|is_utf8_char|const U8 *s Tests if some arbitrary number of bytes begins in a valid UTF-8 character. Note that an INVARIANT (i.e. ASCII) character is a valid UTF-8 character. The actual number of bytes in the UTF-8 character will be returned if it is valid, otherwise 0. +This is the "slow" version as opposed to the "fast" version which is +the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed +difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four +or less you should use the IS_UTF8_CHAR(), for lengths of five or more +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 +five bytes or more. + =cut */ -STRLEN -Perl_is_utf8_char(pTHX_ const U8 *s) +STATIC STRLEN +S_is_utf8_char_slow(pTHX_ const U8 *s, const STRLEN len) { - STRLEN len; -#ifdef IS_UTF8_CHAR - len = UTF8SKIP(s); - if (len <= 4) - return IS_UTF8_CHAR(s, len) ? len : 0; -#endif /* #ifdef IS_UTF8_CHAR */ - { - U8 u = *s; - STRLEN slen; - UV uv, ouv; + U8 u = *s; + STRLEN slen; + UV uv, ouv; - if (UTF8_IS_INVARIANT(u)) - return 1; + if (UTF8_IS_INVARIANT(u)) + return 1; - if (!UTF8_IS_START(u)) - return 0; + if (!UTF8_IS_START(u)) + return 0; - len = UTF8SKIP(s); + if (len < 2 || !UTF8_IS_CONTINUATION(s[1])) + return 0; - if (len < 2 || !UTF8_IS_CONTINUATION(s[1])) - return 0; + slen = len - 1; + s++; +#ifdef EBCDIC + u = NATIVE_TO_UTF(u); +#endif + u &= UTF_START_MASK(len); + uv = u; + ouv = uv; + while (slen--) { + if (!UTF8_IS_CONTINUATION(*s)) + return 0; + uv = UTF8_ACCUMULATE(uv, *s); + if (uv < ouv) + return 0; + ouv = uv; + s++; + } - slen = len - 1; - s++; - u &= UTF_START_MASK(len); - uv = u; - ouv = uv; - while (slen--) { - if (!UTF8_IS_CONTINUATION(*s)) - return 0; - uv = UTF8_ACCUMULATE(uv, *s); - if (uv < ouv) - return 0; - ouv = uv; - s++; - } + if ((STRLEN)UNISKIP(uv) < len) + return 0; - if ((STRLEN)UNISKIP(uv) < len) - return 0; + return len; +} - return len; - } +/* +=for apidoc A|STRLEN|is_utf8_char|const U8 *s + +Tests if some arbitrary number of bytes begins in a valid UTF-8 +character. Note that an INVARIANT (i.e. ASCII) character is a valid +UTF-8 character. The actual number of bytes in the UTF-8 character +will be returned if it is valid, otherwise 0. + +=cut */ +STRLEN +Perl_is_utf8_char(pTHX_ const U8 *s) +{ + const STRLEN len = UTF8SKIP(s); +#ifdef IS_UTF8_CHAR + if (IS_UTF8_CHAR_FAST(len)) + return IS_UTF8_CHAR(s, len) ? len : 0; +#endif /* #ifdef IS_UTF8_CHAR */ + return is_utf8_char_slow(s, len); } /* @@ -238,6 +259,8 @@ UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does not mean 'a string that contains code points above 0x7F encoded in UTF-8' because a valid ASCII string is a valid UTF-8 string. +See also is_utf8_string_loclen() and is_utf8_string_loc(). + =cut */ @@ -247,7 +270,7 @@ Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) const U8* x = s; const U8* send; - if (!len && s) + if (!len) len = strlen((const char *)s); send = s + len; @@ -257,15 +280,26 @@ Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) if (UTF8_IS_INVARIANT(*x)) c = 1; else if (!UTF8_IS_START(*x)) - return FALSE; + goto out; else { /* ... and call is_utf8_char() only if really needed. */ - c = is_utf8_char(x); +#ifdef IS_UTF8_CHAR + c = UTF8SKIP(x); + if (IS_UTF8_CHAR_FAST(c)) { + if (!IS_UTF8_CHAR(x, c)) + goto out; + } else if (!is_utf8_char_slow(x, c)) + goto out; +#else + c = is_utf8_char(x); +#endif /* #ifdef IS_UTF8_CHAR */ if (!c) - return FALSE; + goto out; } x += c; } + + out: if (x != send) return FALSE; @@ -273,55 +307,85 @@ Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) } /* -=for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **p +=for apidoc A|bool|is_utf8_string_loclen|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el -Like is_ut8_string but store the location of the failure in -the last argument. +Like is_ut8_string() but stores the location of the failure (in the +case of "utf8ness failure") or the location s+len (in the case of +"utf8ness success") in the C, and the number of UTF-8 +encoded characters in the C. + +See also is_utf8_string_loc() and is_utf8_string(). =cut */ bool -Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **p) +Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) { const U8* x = s; const U8* send; STRLEN c; - if (!len && s) + if (!len) len = strlen((const char *)s); send = s + len; + if (el) + *el = 0; while (x < send) { /* Inline the easy bits of is_utf8_char() here for speed... */ if (UTF8_IS_INVARIANT(*x)) - c = 1; - else if (!UTF8_IS_START(*x)) { - if (p) - *p = x; - return FALSE; - } + c = 1; + else if (!UTF8_IS_START(*x)) + goto out; else { - /* ... and call is_utf8_char() only if really needed. */ - c = is_utf8_char(x); - if (!c) { - if (p) - *p = x; - return FALSE; - } + /* ... and call is_utf8_char() only if really needed. */ +#ifdef IS_UTF8_CHAR + c = UTF8SKIP(x); + if (IS_UTF8_CHAR_FAST(c)) { + if (!IS_UTF8_CHAR(x, c)) + c = 0; + } else + c = is_utf8_char_slow(x, c); +#else + c = is_utf8_char(x); +#endif /* #ifdef IS_UTF8_CHAR */ + if (!c) + goto out; } - x += c; + x += c; + if (el) + (*el)++; } - if (x != send) { - if (p) - *p = x; + + out: + if (ep) + *ep = x; + if (x != send) return FALSE; - } return TRUE; } /* +=for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el + +Like is_ut8_string() but stores the location of the failure (in the +case of "utf8ness failure") or the location s+len (in the case of +"utf8ness success") in the C. + +See also is_utf8_string_loclen() and is_utf8_string(). + +=cut +*/ + +bool +Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep) +{ + return is_utf8_string_loclen(s, len, ep, 0); +} + +/* =for apidoc A|UV|utf8n_to_uvuni|const U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags Bottom level UTF-8 decode routine. @@ -482,7 +546,7 @@ malformed: } if (dowarn) { - SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0)); + SV* const sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0)); switch (warning) { case 0: /* Intentionally empty. */ break; @@ -496,10 +560,12 @@ malformed: 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 + else { + const int len = (int)(s-s0); 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, (int)expectlen); - + (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen); + } + break; case UTF8_WARN_FE_FF: Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv); @@ -529,7 +595,7 @@ malformed: } if (warning) { - const char *s = SvPVX_const(sv); + const char * const s = SvPVX_const(sv); if (PL_op) Perl_warner(aTHX_ packWARN(WARN_UTF8), @@ -796,7 +862,7 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) *is_utf8 = 0; - Newz(801, d, (*len) - count + 1, U8); + Newxz(d, (*len) - count + 1, U8); s = start; start = d; while (s < send) { U8 c = *s++; @@ -832,7 +898,7 @@ Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len) U8 *d; U8 *dst; - Newz(801, d, (*len) * 2 + 1, U8); + Newxz(d, (*len) * 2 + 1, U8); dst = d; while (s < send) { @@ -1390,12 +1456,13 @@ The "normal" is a string like "ToLower" which means the swash =cut */ UV -Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) +Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, + SV **swashp, const char *normal, const char *special) { U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN len = 0; - const UV uv0 = utf8_to_uvchr(p, 0); + const UV uv0 = utf8_to_uvchr(p, NULL); /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings * are necessary in EBCDIC, they are redundant no-ops * in ASCII-ish platforms, and hopefully optimized away. */ @@ -1415,9 +1482,9 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const if ((hv = get_hv(special, FALSE)) && (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) && (*svp)) { - char *s; + const char *s; - s = SvPV(*svp, len); + s = SvPV_const(*svp, len); if (len == 1) len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp; else { @@ -1564,11 +1631,11 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits { dVAR; SV* retval; - SV* tokenbufsv = sv_newmortal(); + SV* const tokenbufsv = sv_newmortal(); dSP; const size_t pkg_len = strlen(pkg); const size_t name_len = strlen(name); - HV *stash = gv_stashpvn(pkg, pkg_len, FALSE); + HV * const stash = gv_stashpvn(pkg, pkg_len, FALSE); SV* errsv_save; PUSHSTACKi(PERLSI_MAGIC); @@ -1613,7 +1680,7 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits POPSTACK; if (IN_PERL_COMPILETIME) { STRLEN len; - const char* pv = SvPV(tokenbufsv, len); + const char* const pv = SvPV_const(tokenbufsv, len); Copy(pv, PL_tokenbuf, len+1, char); PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); @@ -1637,12 +1704,12 @@ UV Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) { dVAR; - HV* hv = (HV*)SvRV(sv); + HV* const hv = (HV*)SvRV(sv); U32 klen; U32 off; STRLEN slen; STRLEN needents; - U8 *tmps = NULL; + const U8 *tmps = NULL; U32 bit; SV *retval; U8 tmputf8[2]; @@ -1697,12 +1764,12 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE); /* If not cached, generate it via utf8::SWASHGET */ - if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) { + if (!svp || !SvPOK(*svp) || !(tmps = (const U8*)SvPV_const(*svp, slen))) { dSP; /* We use utf8n_to_uvuni() as we want an index into Unicode tables, not a native character number. */ - UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, + const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); SV *errsv_save; @@ -1740,7 +1807,8 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) PL_last_swash_hv = hv; PL_last_swash_klen = klen; - PL_last_swash_tmps = tmps; + /* FIXME change interpvar.h? */ + PL_last_swash_tmps = (U8 *) tmps; PL_last_swash_slen = slen; if (klen) Copy(ptr, PL_last_swash_key, klen, U8); @@ -1816,7 +1884,7 @@ Allows length and flags to be passed to low level routine. UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { - UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); + const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); return UNI_TO_NATIVE(uv); } @@ -1908,8 +1976,8 @@ The pointer to the PV of the dsv is returned. 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); + return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv), + SvCUR(ssv), pvlim, flags); } /* @@ -1975,7 +2043,7 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const if (u1) to_utf8_fold(p1, foldbuf1, &foldlen1); else { - natbuf[0] = *p1; + uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1))); to_utf8_fold(natbuf, foldbuf1, &foldlen1); } q1 = foldbuf1; @@ -1985,7 +2053,7 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const if (u2) to_utf8_fold(p2, foldbuf2, &foldlen2); else { - natbuf[0] = *p2; + uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2))); to_utf8_fold(natbuf, foldbuf2, &foldlen2); } q2 = foldbuf2;