X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=f16cb66be4afb43946d68d6876c5372161454c85;hb=85ca448a836bf0ba175d8874ee540094ff909f93;hp=0cdaf5f3cb68a84843122552988983638772d891;hpb=a241e37b95d268204ef242fe02597dc4dcdf9519;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index 0cdaf5f..f16cb66 100644 --- a/utf8.c +++ b/utf8.c @@ -54,10 +54,10 @@ is the recommended Unicode-aware way of saying U8 * Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) { - if (ckWARN_d(WARN_UTF8)) { + if (ckWARN(WARN_UTF8)) { if (UNICODE_IS_SURROGATE(uv) && !(flags & UNICODE_ALLOW_SURROGATE)) - Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv); + Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv); else if ( ((uv >= 0xFDD0 && uv <= 0xFDEF && !(flags & UNICODE_ALLOW_FDD0)) @@ -72,7 +72,7 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) ((uv <= PERL_UNICODE_MAX) || !(flags & UNICODE_ALLOW_SUPER)) ) - Perl_warner(aTHX_ WARN_UTF8, + Perl_warner(aTHX_ packWARN(WARN_UTF8), "Unicode character 0x%04"UVxf" is illegal", uv); } if (UNI_IS_INVARIANT(uv)) { @@ -469,10 +469,10 @@ malformed: char *s = SvPVX(sv); if (PL_op) - Perl_warner(aTHX_ WARN_UTF8, + Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s in %s", s, OP_DESC(PL_op)); else - Perl_warner(aTHX_ WARN_UTF8, "%s", s); + Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s); } } @@ -841,7 +841,7 @@ bool Perl_is_uni_alnum(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_alnum(tmpbuf); } @@ -849,7 +849,7 @@ bool Perl_is_uni_alnumc(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_alnumc(tmpbuf); } @@ -857,7 +857,7 @@ bool Perl_is_uni_idfirst(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_idfirst(tmpbuf); } @@ -865,7 +865,7 @@ bool Perl_is_uni_alpha(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_alpha(tmpbuf); } @@ -873,7 +873,7 @@ bool Perl_is_uni_ascii(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_ascii(tmpbuf); } @@ -881,7 +881,7 @@ bool Perl_is_uni_space(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_space(tmpbuf); } @@ -889,7 +889,7 @@ bool Perl_is_uni_digit(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_digit(tmpbuf); } @@ -897,7 +897,7 @@ bool Perl_is_uni_upper(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_upper(tmpbuf); } @@ -905,7 +905,7 @@ bool Perl_is_uni_lower(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_lower(tmpbuf); } @@ -913,7 +913,7 @@ bool Perl_is_uni_cntrl(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_cntrl(tmpbuf); } @@ -921,7 +921,7 @@ bool Perl_is_uni_graph(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_graph(tmpbuf); } @@ -929,7 +929,7 @@ bool Perl_is_uni_print(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_print(tmpbuf); } @@ -937,7 +937,7 @@ bool Perl_is_uni_punct(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_punct(tmpbuf); } @@ -945,40 +945,36 @@ bool Perl_is_uni_xdigit(pTHX_ UV c) { U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - uvchr_to_utf8(tmpbuf, (UV)c); + uvchr_to_utf8(tmpbuf, c); return is_utf8_xdigit(tmpbuf); } UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - uvchr_to_utf8(tmpbuf, (UV)c); - return to_utf8_upper(tmpbuf, p, lenp); + uvchr_to_utf8(p, c); + return to_utf8_upper(p, p, lenp); } UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - uvchr_to_utf8(tmpbuf, (UV)c); - return to_utf8_title(tmpbuf, p, lenp); + uvchr_to_utf8(p, c); + return to_utf8_title(p, p, lenp); } UV Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) { - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - uvchr_to_utf8(tmpbuf, (UV)c); - return to_utf8_lower(tmpbuf, p, lenp); + uvchr_to_utf8(p, c); + return to_utf8_lower(p, 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); + uvchr_to_utf8(p, c); + return to_utf8_fold(p, p, lenp); } /* for now these all assume no locale info available for Unicode > 255 */ @@ -1270,71 +1266,109 @@ 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 "swashp" 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. +Both the special and normal mappings are stored lib/unicore/To/Foo.pl, +and loaded by SWASHGET, using lib/utf8_heavy.pl. The special (usually, +but not always, a multicharacter mapping), is tried first. -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(). +The "special" is a string like "utf8::ToSpecLower", which means the +hash %utf8::ToSpecLower. The access to the hash is through +Perl_to_utf8_case(). -=cut - */ +The "normal" is a string like "ToLower" which means the swash +%utf8::ToLower. + +=cut */ UV -Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special) +Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special) { - UV uv; + UV uv0, uv1; + U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; + STRLEN len = 0; - if (!*swashp) - *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0); - uv = swash_fetch(*swashp, p, TRUE); - if (!uv) { + uv0 = utf8_to_uvchr(p, 0); + /* 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. */ + uv1 = NATIVE_TO_UNI(uv0); + uvuni_to_utf8(tmpbuf, uv1); + + if (!*swashp) /* load on-demand */ + *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0); + + if (special) { + /* It might be "special" (sometimes, but not always, + * a multicharacter mapping) */ HV *hv; SV *keysv; HE *he; - - uv = utf8_to_uvchr(p, 0); - + SV *val; + 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); + (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv1))) && + (he = hv_fetch_ent(hv, keysv, FALSE, 0)) && + (val = HeVAL(he))) { + char *s; + + s = SvPV(val, len); + if (len == 1) + len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp; else { - /* something in the 0x80..0xFF range */ - ustrp[0] = UTF8_EIGHT_BIT_HI(c); - ustrp[1] = UTF8_EIGHT_BIT_LO(c); - *lenp = 2; - } #ifdef EBCDIC - { - U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; - U8 *d = tmpbuf; - U8 *t, *tend; - STRLEN tlen; - - for (t = ustrp, tend = t + *lenp; t < tend; t += tlen) { - UV c = utf8_to_uvchr(t, &tlen); - d = uvchr_to_utf8(d, UNI_TO_NATIVE(c)); + /* If we have EBCDIC we need to remap the characters + * since any characters in the low 256 are Unicode + * code points, not EBCDIC. */ + U8 *t = (U8*)s, *tend = t + len, *d; + + d = tmpbuf; + if (SvUTF8(val)) { + STRLEN tlen = 0; + + while (t < tend) { + UV c = utf8_to_uvchr(t, &tlen); + if (tlen > 0) { + d = uvchr_to_utf8(d, UNI_TO_NATIVE(c)); + t += tlen; + } + else + break; + } } - *lenp = d - tmpbuf; - Copy(tmpbuf, ustrp, *lenp, U8); - } + else { + while (t < tend) { + d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t)); + t++; + } + } + len = d - tmpbuf; + Copy(tmpbuf, ustrp, len, U8); +#else + Copy(s, ustrp, len, U8); #endif - return utf8_to_uvchr(ustrp, 0); + } } } + + if (!len && *swashp) { + UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE); + + if (uv2) { + /* It was "normal" (a single character mapping). */ + UV uv3 = UNI_TO_NATIVE(uv2); + + len = uvchr_to_utf8(ustrp, uv3) - ustrp; + } + } + + if (!len) /* Neither: just copy. */ + len = uvchr_to_utf8(ustrp, uv0) - ustrp; + if (lenp) - *lenp = UNISKIP(uv); - uvuni_to_utf8(ustrp, uv); - return uv; + *lenp = len; + + return len ? utf8_to_uvchr(ustrp, 0) : 0; } /* @@ -1717,13 +1751,13 @@ Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags) case '\a': Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break; case '\\': - Perl_sv_catpvf(aTHX_ dsv, "\\" ); ok = TRUE; break; + Perl_sv_catpvf(aTHX_ dsv, "\\\\" ); ok = TRUE; break; default: break; } } /* isPRINT() is the locale-blind version. */ if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) { - Perl_sv_catpvf(aTHX_ dsv, "%c", u); + Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF)); ok = TRUE; } } @@ -1806,6 +1840,9 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)) return 1; /* mismatch; possible infinite loop or false positive */ + if (!u1 || !u2) + natbuf[1] = 0; /* Need to terminate the buffer. */ + while ((e1 == 0 || p1 < e1) && (f1 == 0 || p1 < f1) && (e2 == 0 || p2 < e2) && @@ -1814,7 +1851,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] = NATIVE_TO_UNI(*p1); + natbuf[0] = *p1; to_utf8_fold(natbuf, foldbuf1, &foldlen1); } q1 = foldbuf1; @@ -1824,7 +1861,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] = NATIVE_TO_UNI(*p2); + natbuf[0] = *p2; to_utf8_fold(natbuf, foldbuf2, &foldlen2); } q2 = foldbuf2;