X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d4c19fe8d8a6e04364af0548bf783e83ab5987d2..b640a14ad99660810209db046b8d70831781c646:/utf8.c diff --git a/utf8.c b/utf8.c index 1e39edc..e21cb4f 100644 --- a/utf8.c +++ b/utf8.c @@ -1,6 +1,6 @@ /* utf8.c * - * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, + * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public @@ -25,6 +25,13 @@ #define PERL_IN_UTF8_C #include "perl.h" +#ifndef EBCDIC +/* Separate prototypes needed because in ASCII systems these + * usually macros but they still are compiled as code, too. */ +PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags); +PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv); +#endif + static const char unees[] = "Malformed UTF-8 character (unexpected end of string)"; @@ -262,13 +269,10 @@ See also is_utf8_string_loclen() and is_utf8_string_loc(). bool Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) { + const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; - const U8* send; PERL_UNUSED_CONTEXT; - if (!len) - len = strlen((const char *)s); - send = s + len; while (x < send) { STRLEN c; @@ -283,9 +287,10 @@ Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len) 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; + c = 0; + } + else + c = is_utf8_char_slow(x, c); #else c = is_utf8_char(x); #endif /* #ifdef IS_UTF8_CHAR */ @@ -328,17 +333,12 @@ See also is_utf8_string_loc() and is_utf8_string(). bool Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) { + const U8* const send = s + (len ? len : strlen((const char *)s)); const U8* x = s; - const U8* send; STRLEN c; + STRLEN outlen = 0; PERL_UNUSED_CONTEXT; - 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)) @@ -361,17 +361,16 @@ Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN goto out; } x += c; - if (el) - (*el)++; + outlen++; } out: + if (el) + *el = outlen; + if (ep) *ep = x; - if (x != send) - return FALSE; - - return TRUE; + return (x == send); } /* @@ -379,7 +378,7 @@ Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN =for apidoc A|UV|utf8n_to_uvuni|const U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags Bottom level UTF-8 decode routine. -Returns the unicode code point value of the first character in the string C +Returns the Unicode code point value of the first character in the string C which is assumed to be in UTF-8 encoding and no longer than C; C will be set to the length, in bytes, of that character. @@ -532,7 +531,7 @@ malformed: if (flags & UTF8_CHECK_ONLY) { if (retlen) - *retlen = -1; + *retlen = ((STRLEN) -1); return 0; } @@ -661,6 +660,7 @@ Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) { dVAR; STRLEN len = 0; + U8 t = 0; /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. * the bitops (especially ~) can create illegal UTF-8. @@ -669,7 +669,7 @@ Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) if (e < s) goto warn_and_return; while (s < e) { - const U8 t = UTF8SKIP(s); + t = UTF8SKIP(s); if (e - s < t) { warn_and_return: if (ckWARN_d(WARN_UTF8)) { @@ -749,6 +749,8 @@ Unlike C, this over-writes the original string, and updates len to contain the new length. Returns zero on failure, setting C to -1. +If you need a copy of the string, see C. + =cut */ @@ -766,7 +768,7 @@ Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len) if (!UTF8_IS_INVARIANT(c) && (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send) || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) { - *len = -1; + *len = ((STRLEN) -1); return 0; } } @@ -819,7 +821,7 @@ Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8) } } - *is_utf8 = 0; + *is_utf8 = FALSE; Newx(d, (*len) - count + 1, U8); s = start; start = d; @@ -894,7 +896,7 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) } if (bytelen & 1) - Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVf, (UV)bytelen); + Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen); pend = p + bytelen; @@ -902,7 +904,11 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */ p += 2; if (uv < 0x80) { +#ifdef EBCDIC + *d++ = UNI_TO_NATIVE(uv); +#else *d++ = (U8)uv; +#endif continue; } if (uv < 0x800) { @@ -1388,10 +1394,10 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, if (special && (uv1 == 0xDF || uv1 > 0xFF)) { /* It might be "special" (sometimes, but not always, * a multicharacter mapping) */ - HV *hv; + HV * const hv = get_hv(special, FALSE); SV **svp; - if ((hv = get_hv(special, FALSE)) && + if (hv && (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) && (*svp)) { const char *s; @@ -1550,11 +1556,10 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits { dVAR; SV* retval; - SV* const tokenbufsv = sv_newmortal(); dSP; const size_t pkg_len = strlen(pkg); const size_t name_len = strlen(name); - HV * const stash = gv_stashpvn(pkg, pkg_len, FALSE); + HV * const stash = gv_stashpvn(pkg, pkg_len, 0); SV* errsv_save; PUSHSTACKi(PERLSI_MAGIC); @@ -1588,12 +1593,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; - if (IN_PERL_COMPILETIME) { - /* XXX ought to be handled by lex_start */ - SAVEI32(PL_in_my); - PL_in_my = 0; - sv_setpv(tokenbufsv, PL_tokenbuf); - } errsv_save = newSVsv(ERRSV); if (call_method("SWASHNEW", G_SCALAR)) retval = newSVsv(*PL_stack_sp--); @@ -1605,16 +1604,12 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits LEAVE; POPSTACK; if (IN_PERL_COMPILETIME) { - STRLEN 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); + CopHINTS_set(PL_curcop, PL_hints); } if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) { if (SvPOK(retval)) Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"", - retval); + SVfARG(retval)); Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref"); } return retval; @@ -1647,7 +1642,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) U32 bit; SV *swatch; U8 tmputf8[2]; - UV c = NATIVE_TO_ASCII(*ptr); + const UV c = NATIVE_TO_ASCII(*ptr); if (!do_utf8 && !UNI_IS_INVARIANT(c)) { tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c); @@ -1710,7 +1705,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) needents); if (IN_PERL_COMPILETIME) - PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(PL_curcop, PL_hints); svp = hv_store(hv, (const char *)ptr, klen, swatch, 0); @@ -1720,7 +1715,8 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) } PL_last_swash_hv = hv; - PL_last_swash_klen = klen; + assert(klen <= sizeof(PL_last_swash_key)); + PL_last_swash_klen = (U8)klen; /* FIXME change interpvar.h? */ PL_last_swash_tmps = (U8 *) tmps; PL_last_swash_slen = slen; @@ -1743,6 +1739,7 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ; } Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width"); + NORETURN_FUNCTION_END; } /* Note: @@ -1777,9 +1774,9 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) } /* create and initialize $swatch */ - swatch = newSVpvs(""); scur = octets ? (span * octets) : (span + 7) / 8; - SvGROW(swatch, scur + 1); + swatch = newSV(scur); + SvPOK_on(swatch); s = (U8*)SvPVX(swatch); if (octets && none) { const U8* const e = s + scur; @@ -1809,7 +1806,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) l = (U8*)SvPV(*listsvp, lcur); lend = l + lcur; while (l < lend) { - UV min, max, val, key; + UV min, max, val; STRLEN numlen; I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX; @@ -1882,6 +1879,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) continue; if (octets) { + UV key; if (min < start) { if (!none || val < none) { val += start - min; @@ -1912,6 +1910,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) } } else { /* bits == 1, then val should be ignored */ + UV key; if (min < start) min = start; for (key = min; key <= max; key++) { @@ -1937,7 +1936,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) U8 *s, *o, *nl; STRLEN slen, olen; - U8 opc = *x++; + const U8 opc = *x++; if (opc == '\n') continue; @@ -2007,7 +2006,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) else { STRLEN otheroctets = otherbits >> 3; STRLEN offset = 0; - U8* send = s + slen; + U8* const send = s + slen; while (s < send) { UV otherval = 0; @@ -2026,7 +2025,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span) } if (opc == '+' && otherval) - /*EMPTY*/; /* replace with otherval */ + NOOP; /* replace with otherval */ else if (opc == '!' && !otherval) otherval = 1; else if (opc == '-' && otherval) @@ -2137,6 +2136,7 @@ Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV f const char *s, *e; sv_setpvn(dsv, "", 0); + SvUTF8_off(dsv); 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 @@ -2168,12 +2168,14 @@ Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV f default: break; } if (ok) { - Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok); + const char string = ok; + sv_catpvn(dsv, &string, 1); } } /* isPRINT() is the locale-blind version. */ if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) { - Perl_sv_catpvf(aTHX_ dsv, "%c", c); + const char string = c; + sv_catpvn(dsv, &string, 1); ok = 1; } }