X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=f00659a98663f0317639cd6001fd491fd0096ecd;hb=917b24923c0362e8f2d8d1f3f612150902a8f3eb;hp=5e018260fa855b3cdf0ba54ac770f7718f6ccf2e;hpb=411caa507cab4ba311ec4000c486ad2592d51146;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index 5e01826..f00659a 100644 --- a/utf8.c +++ b/utf8.c @@ -1,6 +1,6 @@ /* utf8.c * - * Copyright (c) 1998-2000, Larry Wall + * Copyright (c) 1998-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -26,25 +26,39 @@ /* Unicode support */ +/* +=for apidoc A|U8*|uv_to_utf8|U8 *d|UV uv + +Adds the UTF8 representation of the Unicode codepoint C to the end +of the string C; C should be have at least C free +bytes available. The return value is the pointer to the byte after the +end of the new character. In other words, + + d = uv_to_utf8(d, uv); + +is the recommended Unicode-aware way of saying + + *(d++) = uv; + +=cut +*/ + U8 * -Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ +Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) { if (uv < 0x80) { *d++ = uv; - *d = 0; return d; } if (uv < 0x800) { *d++ = (( uv >> 6) | 0xc0); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } if (uv < 0x10000) { *d++ = (( uv >> 12) | 0xe0); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } if (uv < 0x200000) { @@ -52,7 +66,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } if (uv < 0x4000000) { @@ -61,7 +74,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } if (uv < 0x80000000) { @@ -71,7 +83,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } #ifdef HAS_QUAD @@ -85,7 +96,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } #ifdef HAS_QUAD @@ -103,15 +113,20 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */ *d++ = (((uv >> 12) & 0x3f) | 0x80); *d++ = (((uv >> 6) & 0x3f) | 0x80); *d++ = (( uv & 0x3f) | 0x80); - *d = 0; return d; } #endif } -/* Tests if some arbitrary number of bytes begins in a valid UTF-8 character. - * The actual number of bytes in the UTF-8 character will be returned if it - * is valid, otherwise 0. */ +/* +=for apidoc A|STRLEN|is_utf8_char|U8 *s + +Tests if some arbitrary number of bytes begins in a valid UTF-8 +character. Note that an 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_ U8 *s) { @@ -119,15 +134,15 @@ Perl_is_utf8_char(pTHX_ U8 *s) STRLEN slen, len; UV uv, ouv; - if (u <= 0x7f) + if (UTF8_IS_ASCII(u)) return 1; - if (u >= 0x80 && u <= 0xbf) + if (!UTF8_IS_START(u)) return 0; len = UTF8SKIP(s); - if (len < 2 || (u >= 0xc0 && u <= 0xfd && s[1] < 0x80)) + if (len < 2 || !UTF8_IS_CONTINUATION(s[1])) return 0; slen = len - 1; @@ -135,9 +150,9 @@ Perl_is_utf8_char(pTHX_ U8 *s) uv = u; ouv = uv; while (slen--) { - if ((*s & 0xc0) != 0x80) + if (!UTF8_IS_CONTINUATION(*s)) return 0; - uv = (uv << 6) | (*s & 0x3f); + uv = UTF8_ACCUMULATE(uv, *s); if (uv < ouv) return 0; ouv = uv; @@ -151,10 +166,12 @@ Perl_is_utf8_char(pTHX_ U8 *s) } /* -=for apidoc Am|is_utf8_string|U8 *s|STRLEN len +=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len -Returns true if first C bytes of the given string form valid a UTF8 -string, false otherwise. +Returns true if first C bytes of the given string form a valid UTF8 +string, false otherwise. Note that 'a valid UTF8 string' does not mean +'a string that contains UTF8' because a valid ASCII string is a valid +UTF8 string. =cut */ @@ -163,35 +180,42 @@ bool Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len) { U8* x = s; - U8* send = s + len; + U8* send; STRLEN c; + if (!len) + len = strlen((char *)s); + send = s + len; + while (x < send) { c = is_utf8_char(x); if (!c) return FALSE; x += c; - if (x > send) - return FALSE; } + if (x != send) + return FALSE; return TRUE; } /* -=for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags +=for apidoc A|UV|utf8_to_uv|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags Returns the character value of the first character in the string C which is assumed to be in UTF8 encoding and no longer than C; -C will be set to the length, in bytes, of that character, -and the pointer C will be advanced to the end of the character. +C will be set to the length, in bytes, of that character. If C does not point to a well-formed UTF8 character, the behaviour is dependent on the value of C: if it contains UTF8_CHECK_ONLY, it is assumed that the caller will raise a warning, and this function -will set C to C<-1> and return. The C can also contain -various flags to allow deviations from the strict UTF-8 encoding -(see F). +will silently just set C to C<-1> and return zero. If the +C does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. + +The C can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F). =cut */ @@ -206,44 +230,48 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) bool dowarn = ckWARN_d(WARN_UTF8); #endif STRLEN expectlen = 0; - - if (curlen == 0) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (an empty string)"); + U32 warning = 0; + +/* This list is a superset of the UTF8_ALLOW_XXX. */ + +#define UTF8_WARN_EMPTY 1 +#define UTF8_WARN_CONTINUATION 2 +#define UTF8_WARN_NON_CONTINUATION 3 +#define UTF8_WARN_FE_FF 4 +#define UTF8_WARN_SHORT 5 +#define UTF8_WARN_OVERFLOW 6 +#define UTF8_WARN_SURROGATE 7 +#define UTF8_WARN_BOM 8 +#define UTF8_WARN_LONG 9 +#define UTF8_WARN_FFFF 10 + + if (curlen == 0 && + !(flags & UTF8_ALLOW_EMPTY)) { + warning = UTF8_WARN_EMPTY; goto malformed; } - if (uv <= 0x7f) { /* Pure ASCII. */ + if (UTF8_IS_ASCII(uv)) { if (retlen) *retlen = 1; return *s; } - if ((uv >= 0x80 && uv <= 0xbf) && + if (UTF8_IS_CONTINUATION(uv) && !(flags & UTF8_ALLOW_CONTINUATION)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (unexpected continuation byte 0x%02"UVxf")", - uv); + warning = UTF8_WARN_CONTINUATION; goto malformed; } - if ((uv >= 0xc0 && uv <= 0xfd && curlen > 1 && s[1] < 0x80) && + if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) && !(flags & UTF8_ALLOW_NON_CONTINUATION)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (unexpected non-continuation byte 0x%02"UVxf" after byte 0x%02"UVxf")", - (UV)s[1], uv); + warning = UTF8_WARN_NON_CONTINUATION; goto malformed; } if ((uv == 0xfe || uv == 0xff) && !(flags & UTF8_ALLOW_FE_FF)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (byte 0x%02"UVxf")", - uv); + warning = UTF8_WARN_FE_FF; goto malformed; } @@ -262,10 +290,7 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) if ((curlen < expectlen) && !(flags & UTF8_ALLOW_SHORT)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (%d byte%s, need %d)", - curlen, curlen == 1 ? "" : "s", expectlen); + warning = UTF8_WARN_SHORT; goto malformed; } @@ -274,54 +299,47 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) ouv = uv; while (len--) { - if ((*s & 0xc0) != 0x80) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (unexpected continuation byte 0x%02x)", - *s); + if (!UTF8_IS_CONTINUATION(*s) && + !(flags & UTF8_ALLOW_NON_CONTINUATION)) { + s--; + warning = UTF8_WARN_NON_CONTINUATION; goto malformed; } else - uv = (uv << 6) | (*s & 0x3f); - if (uv < ouv) { - /* This cannot be allowed. */ - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (overflow at 0x%"UVxf", byte 0x%02x)", - ouv, *s); - goto malformed; + uv = UTF8_ACCUMULATE(uv, *s); + if (!(uv > ouv)) { + /* These cannot be allowed. */ + if (uv == ouv) { + if (!(flags & UTF8_ALLOW_LONG)) { + warning = UTF8_WARN_LONG; + goto malformed; + } + } + else { /* uv < ouv */ + /* This cannot be allowed. */ + warning = UTF8_WARN_OVERFLOW; + goto malformed; + } } s++; ouv = uv; } - if ((uv >= 0xd800 && uv <= 0xdfff) && + if (UNICODE_IS_SURROGATE(uv) && !(flags & UTF8_ALLOW_SURROGATE)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (UTF-16 surrogate 0x%04"UVxf")", - uv); + warning = UTF8_WARN_SURROGATE; goto malformed; - } else if ((uv == 0xfffe) && + } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) && !(flags & UTF8_ALLOW_BOM)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (byte order mark 0x%04"UVxf")", - uv); - goto malformed; - } else if ((uv == 0xffff) && - !(flags & UTF8_ALLOW_FFFF)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (character 0x%04"UVxf")", - uv); + warning = UTF8_WARN_BOM; goto malformed; } else if ((expectlen > UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) { - if (dowarn) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character (%d byte%s, need %d)", - expectlen, expectlen == 1 ? "": "s", UNISKIP(uv)); + warning = UTF8_WARN_LONG; + goto malformed; + } else if (UNICODE_IS_ILLEGAL(uv) && + !(flags & UTF8_ALLOW_FFFF)) { + warning = UTF8_WARN_FFFF; goto malformed; } @@ -335,19 +353,73 @@ malformed: return 0; } + if (dowarn) { + SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0)); + + switch (warning) { + case 0: /* Intentionally empty. */ break; + case UTF8_WARN_EMPTY: + Perl_sv_catpvf(aTHX_ sv, "(empty string)"); + break; + case UTF8_WARN_CONTINUATION: + Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv); + break; + case UTF8_WARN_NON_CONTINUATION: + Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")", + (UV)s[1], uv); + 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)", + curlen, curlen == 1 ? "" : "s", expectlen); + break; + case UTF8_WARN_OVERFLOW: + Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)", + ouv, *s); + break; + case UTF8_WARN_SURROGATE: + Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv); + break; + case UTF8_WARN_BOM: + Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv); + break; + case UTF8_WARN_LONG: + Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)", + expectlen, expectlen == 1 ? "": "s", UNISKIP(uv)); + break; + case UTF8_WARN_FFFF: + Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv); + break; + default: + Perl_sv_catpvf(aTHX_ sv, "(unknown reason)"); + break; + } + + if (warning) { + char *s = SvPVX(sv); + + if (PL_op) + Perl_warner(aTHX_ WARN_UTF8, + "%s in %s", s, PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UTF8, "%s", s); + } + } + if (retlen) *retlen = expectlen ? expectlen : len; - return UNICODE_REPLACEMENT_CHARACTER; + return 0; } /* -=for apidoc Am|U8* s|utf8_to_uv_simple|STRLEN *retlen +=for apidoc A|U8* s|utf8_to_uv_simple|STRLEN *retlen Returns the character value of the first character in the string C which is assumed to be in UTF8 encoding; C will be set to the -length, in bytes, of that character, and the pointer C will be -advanced to the end of the character. +length, in bytes, of that character. If C does not point to a well-formed UTF8 character, zero is returned and retlen is set, if possible, to -1. @@ -362,7 +434,7 @@ Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen) } /* -=for apidoc|utf8_length|U8 *s|U8 *e +=for apidoc A|STRLEN|utf8_length|U8* s|U8 *e Return the length of the UTF-8 char encoded string C in characters. Stops at C (inclusive). If C s> or if the scan would end @@ -376,6 +448,10 @@ Perl_utf8_length(pTHX_ U8* s, U8* e) { STRLEN len = 0; + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + if (e < s) Perl_croak(aTHX_ "panic: utf8_length: unexpected end"); while (s < e) { @@ -390,14 +466,26 @@ Perl_utf8_length(pTHX_ U8* s, U8* e) return len; } -/* utf8_distance(a,b) returns the number of UTF8 characters between - the pointers a and b */ +/* +=for apidoc A|IV|utf8_distance|U8 *a|U8 *b + +Returns the number of UTF8 characters between the UTF-8 pointers C +and C. + +WARNING: use only if you *know* that the pointers point inside the +same UTF-8 buffer. + +=cut */ IV Perl_utf8_distance(pTHX_ U8 *a, U8 *b) { IV off = 0; + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g. + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + if (a < b) { while (a < b) { U8 c = UTF8SKIP(a); @@ -422,11 +510,25 @@ Perl_utf8_distance(pTHX_ U8 *a, U8 *b) return off; } -/* WARNING: do not use the following unless you *know* off is within bounds */ +/* +=for apidoc A|U8*|utf8_hop|U8 *s|I32 off + +Return the UTF-8 pointer C displaced by C characters, either +forward or backward. + +WARNING: do not use the following unless you *know* C is within +the UTF-8 data pointed to by C *and* that on entry C is aligned +on the first byte of character or just after the last byte of a character. + +=cut */ U8 * Perl_utf8_hop(pTHX_ U8 *s, I32 off) { + /* Note: cannot use UTF8_IS_...() too eagerly here since e.g + * the bitops (especially ~) can create illegal UTF-8. + * In other words: in Perl UTF-8 is not just for Unicode. */ + if (off >= 0) { while (off--) s += UTF8SKIP(s); @@ -434,17 +536,15 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off) else { while (off++) { s--; - if (*s & 0x80) { - while ((*s & 0xc0) == 0x80) - s--; - } + while (UTF8_IS_CONTINUATION(*s)) + s--; } } return s; } /* -=for apidoc Am|U8 *|utf8_to_bytes|U8 *s|STRLEN *len +=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len Converts a string C of length C from UTF8 into byte encoding. Unlike C, this over-writes the original string, and @@ -475,14 +575,9 @@ Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) d = s = save; while (s < send) { - if (*s < 0x80) { - *d++ = *s++; - } - else { - STRLEN ulen; - *d++ = (U8)utf8_to_uv_simple(s, &ulen); - s += ulen; - } + STRLEN ulen; + *d++ = (U8)utf8_to_uv_simple(s, &ulen); + s += ulen; } *d = '\0'; *len = d - save; @@ -490,7 +585,61 @@ Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) } /* -=for apidoc Am|U8 *|bytes_to_utf8|U8 *s|STRLEN *len +=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8 + +Converts a string C of length C from UTF8 into byte encoding. +Unlike but like C, returns a pointer to +the newly-created string, and updates C to contain the new +length. Returns the original string if no conversion occurs, C +is unchanged. Do nothing if C points to 0. Sets C to +0 if C is converted or contains all 7bit characters. + +=cut */ + +U8 * +Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8) +{ + U8 *send; + U8 *d; + U8 *start = s; + I32 count = 0; + + if (!*is_utf8) + return start; + + /* ensure valid UTF8 and chars < 256 before converting string */ + for (send = s + *len; s < send;) { + U8 c = *s++; + if (!UTF8_IS_ASCII(c)) { + if (UTF8_IS_CONTINUATION(c) || s >= send || + !UTF8_IS_CONTINUATION(*s) || UTF8_IS_DOWNGRADEABLE_START(c)) + return start; + s++, count++; + } + } + + *is_utf8 = 0; + + if (!count) + return start; + + Newz(801, d, (*len) - count + 1, U8); + s = start; start = d; + while (s < send) { + U8 c = *s++; + + if (UTF8_IS_ASCII(c)) + *d++ = c; + else + *d++ = UTF8_ACCUMULATE(c, *s++); + } + *d = '\0'; + *len = d - start; + return start; +} + +/* +=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len Converts a string C of length C from ASCII into UTF8 encoding. Returns a pointer to the newly-created string, and sets C to @@ -511,12 +660,13 @@ Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len) dst = d; while (s < send) { - if (*s < 0x80) + if (UTF8_IS_ASCII(*s)) *d++ = *s++; else { UV uv = *s++; - *d++ = (( uv >> 6) | 0xc0); - *d++ = (( uv & 0x3f) | 0x80); + + *d++ = UTF8_EIGHT_BIT_HI(uv); + *d++ = UTF8_EIGHT_BIT_LO(uv); } } *d = '\0'; @@ -1037,7 +1187,7 @@ SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) { SV* retval; - char tmpbuf[256]; + SV* tokenbufsv = sv_2mortal(NEWSV(0,0)); dSP; if (!gv_stashpv(pkg, 0)) { /* demand load utf8 */ @@ -1059,8 +1209,9 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) SAVEI32(PL_hints); PL_hints = 0; save_re_context(); - if (PL_curcop == &PL_compiling) /* XXX ought to be handled by lex_start */ - strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf); + if (PL_curcop == &PL_compiling) + /* XXX ought to be handled by lex_start */ + sv_setpv(tokenbufsv, PL_tokenbuf); if (call_method("SWASHNEW", G_SCALAR)) retval = newSVsv(*PL_stack_sp--); else @@ -1068,7 +1219,10 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) LEAVE; POPSTACK; if (PL_curcop == &PL_compiling) { - strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf); + STRLEN len; + char* pv = SvPV(tokenbufsv, len); + + Copy(pv, PL_tokenbuf, len+1, char); PL_curcop->op_private = PL_hints; } if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)