X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=f16cb66be4afb43946d68d6876c5372161454c85;hb=bbf171aee9b891c8674684cecebc91b4019f5d4f;hp=fa562fe0ca7cfa72fccba114d9b40d61861e1b60;hpb=2f9475adf7d7a036b9b8c1a129175e296141ec5c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index fa562fe..f16cb66 100644 --- a/utf8.c +++ b/utf8.c @@ -57,7 +57,7 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) 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); } } @@ -952,33 +952,29 @@ Perl_is_uni_xdigit(pTHX_ UV c) UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - uvchr_to_utf8(tmpbuf, 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, 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, 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, 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,45 +1266,40 @@ 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) { - UV uv0, uv1, uv2; + UV uv0, uv1; U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; - char *s = NULL; - STRLEN len; + STRLEN len = 0; - if (!*swashp) - *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0); 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); - uv2 = swash_fetch(*swashp, tmpbuf, TRUE); - if (uv2) { - /* It was "normal" (a single character mapping). */ - UV uv3 = UNI_TO_NATIVE(uv2); - - len = uvuni_to_utf8(ustrp, uv2) - ustrp; - } - else { - /* It might be "special" (sometimes, but not always, + + 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; @@ -1319,19 +1310,17 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *norma (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv1))) && (he = hv_fetch_ent(hv, keysv, FALSE, 0)) && (val = HeVAL(he))) { - U8* d; - + char *s; + s = SvPV(val, len); - if (len == 1) { - d = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)); - len = d - ustrp; - } + if (len == 1) + len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp; else { #ifdef EBCDIC /* 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; + U8 *t = (U8*)s, *tend = t + len, *d; d = tmpbuf; if (SvUTF8(val)) { @@ -1357,19 +1346,29 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *norma Copy(tmpbuf, ustrp, len, U8); #else Copy(s, ustrp, len, U8); - } #endif + } } - else { - /* It was not "special", either. */ - len = uvchr_to_utf8(ustrp, uv0) - ustrp; + } + + 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 = len; - return utf8_to_uvchr(ustrp, 0); + return len ? utf8_to_uvchr(ustrp, 0) : 0; } /* @@ -1752,7 +1751,7 @@ 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; } }