X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=84d55535244d29787151af6d0238128f8ccf3be6;hb=ca563b4e7524b82fcbffcbe3344a4a9d20a7ab64;hp=905ff85c2d0b06adf8050c34df0c007092f87da6;hpb=7fc634935189abec1d574a9733c7093e5c9f2781;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index 905ff85..84d5553 100644 --- a/utf8.c +++ b/utf8.c @@ -25,7 +25,8 @@ #define PERL_IN_UTF8_C #include "perl.h" -static char unees[] = "Malformed UTF-8 character (unexpected end of string)"; +static const char unees[] = + "Malformed UTF-8 character (unexpected end of string)"; /* =head1 Unicode Support @@ -165,28 +166,30 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) #endif #endif /* Loop style */ } - -U8 * -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) { U8 u = *s; - STRLEN slen, len; + STRLEN slen; UV uv, ouv; if (UTF8_IS_INVARIANT(u)) @@ -195,13 +198,14 @@ Perl_is_utf8_char(pTHX_ const U8 *s) if (!UTF8_IS_START(u)) return 0; - len = UTF8SKIP(s); - 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; @@ -222,6 +226,26 @@ Perl_is_utf8_char(pTHX_ const U8 *s) } /* +=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); +} + +/* =for apidoc A|bool|is_utf8_string|const U8 *s|STRLEN len Returns true if first C bytes of the given string form a valid @@ -229,6 +253,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 */ @@ -237,26 +263,37 @@ Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) { const U8* x = s; const U8* send; - STRLEN c; - if (!len && s) - len = strlen((char *)s); + if (!len) + len = strlen((const char *)s); send = s + len; while (x < send) { + STRLEN c; /* Inline the easy bits of is_utf8_char() here for speed... */ 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; @@ -264,55 +301,78 @@ 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 +Implemented as a macro in utf8.h + +=for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **ep -Like is_ut8_string but store the location of the failure in -the last argument. +Like is_utf8_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(). + +=for apidoc A|bool|is_utf8_string_loclen|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el + +Like is_utf8_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) - len = strlen((char *)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|UV|utf8n_to_uvuni|const U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags Bottom level UTF-8 decode routine. @@ -473,7 +533,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; @@ -487,17 +547,19 @@ 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, 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); break; case UTF8_WARN_SHORT: Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")", - curlen, curlen == 1 ? "" : "s", expectlen, startbyte); + (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte); expectlen = curlen; /* distance for caller to skip */ break; case UTF8_WARN_OVERFLOW: @@ -509,7 +571,7 @@ malformed: break; case UTF8_WARN_LONG: Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")", - expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte); + (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte); break; case UTF8_WARN_FFFF: Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv); @@ -520,7 +582,7 @@ malformed: } if (warning) { - char *s = SvPVX(sv); + const char * const s = SvPVX_const(sv); if (PL_op) Perl_warner(aTHX_ packWARN(WARN_UTF8), @@ -552,8 +614,8 @@ returned and retlen is set, if possible, to -1. UV Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen) { - return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXBYTES, retlen, - ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); } /* @@ -599,24 +661,16 @@ Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) * the bitops (especially ~) can create illegal UTF-8. * In other words: in Perl UTF-8 is not just for Unicode. */ - if (e < s) { - if (ckWARN_d(WARN_UTF8)) { - if (PL_op) - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "%s in %s", unees, OP_DESC(PL_op)); - else - Perl_warner(aTHX_ packWARN(WARN_UTF8), unees); - } - return 0; - } + if (e < s) + goto warn_and_return; while (s < e) { - U8 t = UTF8SKIP(s); - + const U8 t = UTF8SKIP(s); if (e - s < t) { + warn_and_return: if (ckWARN_d(WARN_UTF8)) { if (PL_op) Perl_warner(aTHX_ packWARN(WARN_UTF8), - unees, OP_DESC(PL_op)); + "%s in %s", unees, OP_DESC(PL_op)); else Perl_warner(aTHX_ packWARN(WARN_UTF8), unees); } @@ -653,26 +707,18 @@ Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b) if (a < b) { while (a < b) { const U8 c = UTF8SKIP(a); - - if (b - a < c) { - if (ckWARN_d(WARN_UTF8)) { - if (PL_op) - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "%s in %s", unees, OP_DESC(PL_op)); - else - Perl_warner(aTHX_ packWARN(WARN_UTF8), unees); - } - return off; - } + if (b - a < c) + goto warn_and_return; a += c; off--; } } else { while (b < a) { - U8 c = UTF8SKIP(b); + const U8 c = UTF8SKIP(b); if (a - b < c) { + warn_and_return: if (ckWARN_d(WARN_UTF8)) { if (PL_op) Perl_warner(aTHX_ packWARN(WARN_UTF8), @@ -704,7 +750,7 @@ on the first byte of character or just after the last byte of a character. */ U8 * -Perl_utf8_hop(pTHX_ U8 *s, I32 off) +Perl_utf8_hop(pTHX_ const U8 *s, I32 off) { /* Note: cannot use UTF8_IS_...() too eagerly here since e.g * the bitops (especially ~) can create illegal UTF-8. @@ -721,7 +767,7 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off) s--; } } - return s; + return (U8 *)s; } /* @@ -766,7 +812,7 @@ Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) } /* -=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 +=for apidoc A|U8 *|bytes_from_utf8|const U8 *s|STRLEN *len|bool *is_utf8 Converts a string C of length C from UTF-8 into byte encoding. Unlike C but like C, returns a pointer to @@ -779,31 +825,31 @@ is unchanged. Do nothing if C points to 0. Sets C to */ U8 * -Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8) +Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) { U8 *d; - U8 *start = s; - U8 *send; + const U8 *start = s; + const U8 *send; I32 count = 0; if (!*is_utf8) - return start; + return (U8 *)start; /* ensure valid UTF-8 and chars < 256 before converting string */ for (send = s + *len; s < send;) { - U8 c = *s++; + U8 c = *s++; if (!UTF8_IS_INVARIANT(c)) { if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send && (c = *s++) && UTF8_IS_CONTINUATION(c)) count++; else - return start; + return (U8 *)start; } } *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++; @@ -816,7 +862,7 @@ Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8) } *d = '\0'; *len = d - start; - return start; + return (U8 *)start; } /* @@ -839,7 +885,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) { @@ -1191,40 +1237,29 @@ Perl_to_uni_lower_lc(pTHX_ U32 c) } bool -Perl_is_utf8_alnum(pTHX_ const U8 *p) +S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, + const char *const swashname) { if (!is_utf8_char(p)) return FALSE; - if (!PL_utf8_alnum) - /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true - * descendant of isalnum(3), in other words, it doesn't - * contain the '_'. --jhi */ - PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_alnum, p, TRUE) != 0; -/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */ -#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */ - if (!PL_utf8_alnum) - PL_utf8_alnum = swash_init("utf8", "", - sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0); - return swash_fetch(PL_utf8_alnum, p, TRUE) != 0; -#endif + if (!*swash) + *swash = swash_init("utf8", swashname, &PL_sv_undef, 0, 0); + return swash_fetch(*swash, p, TRUE) != 0; +} + +bool +Perl_is_utf8_alnum(pTHX_ const U8 *p) +{ + /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true + * descendant of isalnum(3), in other words, it doesn't + * contain the '_'. --jhi */ + return S_is_utf8_common(aTHX_ p, &PL_utf8_alnum, "IsWord"); } bool Perl_is_utf8_alnumc(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_alnum) - PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_alnum, p, TRUE) != 0; -/* return is_utf8_alpha(p) || is_utf8_digit(p); */ -#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */ - if (!PL_utf8_alnum) - PL_utf8_alnum = swash_init("utf8", "", - sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0); - return swash_fetch(PL_utf8_alnum, p, TRUE) != 0; -#endif + return S_is_utf8_common(aTHX_ p, &PL_utf8_alnumc, "IsAlnumC"); } bool @@ -1232,11 +1267,8 @@ Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */ { if (*p == '_') return TRUE; - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */ - PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_idstart, p, TRUE) != 0; + /* is_utf8_idstart would be more logical. */ + return S_is_utf8_common(aTHX_ p, &PL_utf8_idstart, "IdStart"); } bool @@ -1244,131 +1276,79 @@ Perl_is_utf8_idcont(pTHX_ const U8 *p) { if (*p == '_') return TRUE; - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_idcont) - PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_idcont, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_idcont, "IdContinue"); } bool Perl_is_utf8_alpha(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_alpha) - PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_alpha, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_alpha, "IsAlpha"); } bool Perl_is_utf8_ascii(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_ascii) - PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_ascii, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_ascii, "IsAscii"); } bool Perl_is_utf8_space(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_space) - PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_space, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_space, "IsSpacePerl"); } bool Perl_is_utf8_digit(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_digit) - PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_digit, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_digit, "IsDigit"); } bool Perl_is_utf8_upper(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_upper) - PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_upper, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_upper, "IsUppercase"); } bool Perl_is_utf8_lower(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_lower) - PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_lower, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_lower, "IsLowercase"); } bool Perl_is_utf8_cntrl(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_cntrl) - PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_cntrl, "IsCntrl"); } bool Perl_is_utf8_graph(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_graph) - PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_graph, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_graph, "IsGraph"); } bool Perl_is_utf8_print(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_print) - PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_print, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_print, "IsPrint"); } bool Perl_is_utf8_punct(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_punct) - PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_punct, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_punct, "IsPunct"); } bool Perl_is_utf8_xdigit(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_xdigit) - PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_xdigit, "Isxdigit"); } bool Perl_is_utf8_mark(pTHX_ const U8 *p) { - if (!is_utf8_char(p)) - return FALSE; - if (!PL_utf8_mark) - PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0); - return swash_fetch(PL_utf8_mark, p, TRUE) != 0; + return S_is_utf8_common(aTHX_ p, &PL_utf8_mark, "IsM"); } /* @@ -1397,17 +1377,17 @@ 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, char *normal, char *special) +Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, + SV **swashp, const char *normal, const char *special) { - UV uv1; 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. */ - uv1 = NATIVE_TO_UNI(uv0); + const UV uv1 = NATIVE_TO_UNI(uv0); uvuni_to_utf8(tmpbuf, uv1); if (!*swashp) /* load on-demand */ @@ -1423,9 +1403,9 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char 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 { @@ -1570,14 +1550,20 @@ Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none) { + 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); + ENTER; + SAVEI32(PL_hints); + PL_hints = 0; + save_re_context(); if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */ ENTER; errsv_save = newSVsv(ERRSV); @@ -1589,7 +1575,6 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits LEAVE; } SPAGAIN; - PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,5); PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len))); @@ -1598,10 +1583,6 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits PUSHs(sv_2mortal(newSViv(minbits))); PUSHs(sv_2mortal(newSViv(none))); PUTBACK; - ENTER; - SAVEI32(PL_hints); - PL_hints = 0; - save_re_context(); if (IN_PERL_COMPILETIME) { /* XXX ought to be handled by lex_start */ SAVEI32(PL_in_my); @@ -1620,7 +1601,7 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits POPSTACK; if (IN_PERL_COMPILETIME) { STRLEN len; - 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); @@ -1643,12 +1624,13 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits UV Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) { - HV* hv = (HV*)SvRV(sv); + dVAR; + 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]; @@ -1700,15 +1682,15 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) } else { /* Try our second-level swatch cache, kept in a hash. */ - SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE); + 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; @@ -1738,7 +1720,7 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) if (IN_PERL_COMPILETIME) PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); - svp = hv_store(hv, (char*)ptr, klen, retval, 0); + svp = hv_store(hv, (const char *)ptr, klen, retval, 0); if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents) Perl_croak(aTHX_ "SWASHGET didn't return result of proper length"); @@ -1746,7 +1728,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); @@ -1770,7 +1753,6 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) return 0; } - /* =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv @@ -1791,7 +1773,6 @@ is the recommended wide native character-aware way of saying /* On ASCII machines this is normally a macro but we want a real function in case XS code wants it */ -#undef Perl_uvchr_to_utf8 U8 * Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) { @@ -1805,9 +1786,11 @@ Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) } /* -=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags +=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 +flags -Returns the native character value of the first character in the string C +Returns the native character value of the first character in the string +C which is assumed to be in UTF-8 encoding; C will be set to the length, in bytes, of that character. @@ -1818,11 +1801,11 @@ Allows length and flags to be passed to low level routine. /* On ASCII machines this is normally a macro but we want a real function in case XS code wants it */ -#undef Perl_utf8n_to_uvchr UV -Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) +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); } @@ -1844,13 +1827,13 @@ 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) +Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags) { int truncated = 0; - char *s, *e; + const char *s, *e; sv_setpvn(dsv, "", 0); - for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) { + for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) { UV u; /* This serves double duty as a flag and a character to print after a \ when flags & UNI_DISPLAY_BACKSLASH is true. @@ -1863,7 +1846,7 @@ Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags) } u = utf8_to_uvchr((U8*)s, 0); if (u < 256) { - unsigned char c = u & 0xFF; + const unsigned char c = (unsigned char)u & 0xFF; if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) { switch (c) { case '\n': @@ -1914,8 +1897,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); } /* @@ -1946,10 +1929,11 @@ http://www.unicode.org/unicode/reports/tr21/ (Case Mappings). I32 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2) { - register U8 *p1 = (U8*)s1; - register U8 *p2 = (U8*)s2; - register U8 *e1 = 0, *f1 = 0, *q1 = 0; - register U8 *e2 = 0, *f2 = 0, *q2 = 0; + register const U8 *p1 = (const U8*)s1; + register const U8 *p2 = (const U8*)s2; + register const U8 *f1 = 0, *f2 = 0; + register U8 *e1 = 0, *q1 = 0; + register U8 *e2 = 0, *q2 = 0; STRLEN n1 = 0, n2 = 0; U8 foldbuf1[UTF8_MAXBYTES_CASE+1]; U8 foldbuf2[UTF8_MAXBYTES_CASE+1]; @@ -1959,12 +1943,12 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const if (pe1) e1 = *(U8**)pe1; - if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1))) - f1 = (U8*)s1 + l1; + if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1))) + f1 = (const U8*)s1 + l1; if (pe2) e2 = *(U8**)pe2; - if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2))) - f2 = (U8*)s2 + l2; + if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2))) + f2 = (const U8*)s2 + l2; if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)) return 1; /* mismatch; possible infinite loop or false positive */ @@ -1980,7 +1964,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; @@ -1990,7 +1974,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; @@ -2034,5 +2018,5 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const * indent-tabs-mode: t * End: * - * vim: shiftwidth=4: -*/ + * ex: set ts=8 sts=4 sw=4 noet: + */