X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=7302bb77e2256f72ca6d2d5b71c0bd06c009ce88;hb=63478870f61d3f4e0428fe761bb835b4cc010aa6;hp=e82725ec72f37a3fdfe8edf1473db1513a12007c;hpb=bf1fed83f9a0d78ad078e497a12a4e988adb9031;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utf8.c b/utf8.c index e82725e..7302bb7 100644 --- a/utf8.c +++ b/utf8.c @@ -26,25 +26,39 @@ /* Unicode support */ +/* +=for apidoc A|U8*|uvuni_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 = uvuni_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_uvuni_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,46 @@ 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|U8*|uvchr_to_utf8|U8 *d|UV uv + +Adds the UTF8 representation of the Native 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 = uvchr_to_utf8(d, uv); + +is the recommended wide native character-aware way of saying + + *(d++) = uv; + +=cut +*/ + +U8 * +Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) +{ + if (uv < 0x100) + uv = NATIVE_TO_ASCII(uv); + return Perl_uvuni_to_utf8(aTHX_ d, uv); +} + + +/* +=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) { @@ -151,10 +192,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 */ @@ -183,9 +226,10 @@ Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len) } /* -=for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags +=for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags -Returns the character value of the first character in the string C +Bottom level UTF-8 decode routine. +Returns the unicode code point 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. @@ -200,18 +244,16 @@ 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). +Most code should use utf8_to_uvchr() rather than call this directly. + =cut */ UV -Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) +Perl_utf8n_to_uvuni(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) { UV uv = *s, ouv; STRLEN len = 1; -#ifdef EBCDIC - bool dowarn = 0; -#else bool dowarn = ckWARN_d(WARN_UTF8); -#endif STRLEN expectlen = 0; U32 warning = 0; @@ -237,7 +279,7 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) if (UTF8_IS_ASCII(uv)) { if (retlen) *retlen = 1; - return *s; + return (UV) (*s); } if (UTF8_IS_CONTINUATION(uv) && @@ -251,7 +293,7 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) warning = UTF8_WARN_NON_CONTINUATION; goto malformed; } - + if ((uv == 0xfe || uv == 0xff) && !(flags & UTF8_ALLOW_FE_FF)) { warning = UTF8_WARN_FE_FF; @@ -268,7 +310,7 @@ Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) if (retlen) *retlen = len; - + expectlen = len; if ((curlen < expectlen) && @@ -398,9 +440,30 @@ malformed: } /* -=for apidoc Am|U8* s|utf8_to_uv_simple|STRLEN *retlen +=for apidoc A|U8* s|utf8n_to_uvchr|STRLEN curlen, STRLEN *retlen, U32 flags + +Returns the native 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. + +Allows length and flags to be passed to low level routine. + +=cut +*/ + +UV +Perl_utf8n_to_uvchr(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags) +{ + UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); + if (uv < 0x100) + return (UV) ASCII_TO_NATIVE(uv); + return uv; +} + +/* +=for apidoc A|U8* s|utf8_to_uvchr|STRLEN *retlen -Returns the 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 UTF8 encoding; C will be set to the length, in bytes, of that character. @@ -411,13 +474,36 @@ returned and retlen is set, if possible, to -1. */ UV -Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen) +Perl_utf8_to_uvchr(pTHX_ U8* s, STRLEN* retlen) { - return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0); + return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0); } /* -=for apidoc Am|STRLEN|utf8_length|U8* s|U8 *e +=for apidoc A|U8* s|utf8_to_uvuni|STRLEN *retlen + +Returns the Unicode code point 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. + +This function should only be used when returned UV is considered +an index into the Unicode semantic tables (e.g. swashes). + +If C does not point to a well-formed UTF8 character, zero is +returned and retlen is set, if possible, to -1. + +=cut +*/ + +UV +Perl_utf8_to_uvuni(pTHX_ U8* s, STRLEN* retlen) +{ + /* Call the low level routine asking for checks */ + return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0); +} + +/* +=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 @@ -450,7 +536,7 @@ Perl_utf8_length(pTHX_ U8* s, U8* e) } /* -=for apidoc Am|IV|utf8_distance|U8 *a|U8 *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. @@ -494,7 +580,7 @@ Perl_utf8_distance(pTHX_ U8 *a, U8 *b) } /* -=for apidoc Am|U8*|utf8_hop|U8 *s|I32 off +=for apidoc A|U8*|utf8_hop|U8 *s|I32 off Return the UTF-8 pointer C displaced by C characters, either forward or backward. @@ -527,7 +613,7 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off) } /* -=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 @@ -559,7 +645,7 @@ Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len) d = s = save; while (s < send) { STRLEN ulen; - *d++ = (U8)utf8_to_uv_simple(s, &ulen); + *d++ = (U8)utf8_to_uvchr(s, &ulen); s += ulen; } *d = '\0'; @@ -568,7 +654,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 @@ -589,12 +729,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'; @@ -677,7 +818,7 @@ bool Perl_is_uni_alnum(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_alnum(tmpbuf); } @@ -685,7 +826,7 @@ bool Perl_is_uni_alnumc(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_alnumc(tmpbuf); } @@ -693,7 +834,7 @@ bool Perl_is_uni_idfirst(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_idfirst(tmpbuf); } @@ -701,7 +842,7 @@ bool Perl_is_uni_alpha(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_alpha(tmpbuf); } @@ -709,7 +850,7 @@ bool Perl_is_uni_ascii(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_ascii(tmpbuf); } @@ -717,7 +858,7 @@ bool Perl_is_uni_space(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_space(tmpbuf); } @@ -725,7 +866,7 @@ bool Perl_is_uni_digit(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_digit(tmpbuf); } @@ -733,7 +874,7 @@ bool Perl_is_uni_upper(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_upper(tmpbuf); } @@ -741,7 +882,7 @@ bool Perl_is_uni_lower(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_lower(tmpbuf); } @@ -749,7 +890,7 @@ bool Perl_is_uni_cntrl(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_cntrl(tmpbuf); } @@ -757,7 +898,7 @@ bool Perl_is_uni_graph(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_graph(tmpbuf); } @@ -765,7 +906,7 @@ bool Perl_is_uni_print(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_print(tmpbuf); } @@ -773,7 +914,7 @@ bool Perl_is_uni_punct(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_punct(tmpbuf); } @@ -781,7 +922,7 @@ bool Perl_is_uni_xdigit(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return is_utf8_xdigit(tmpbuf); } @@ -789,7 +930,7 @@ U32 Perl_to_uni_upper(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return to_utf8_upper(tmpbuf); } @@ -797,7 +938,7 @@ U32 Perl_to_uni_title(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return to_utf8_title(tmpbuf); } @@ -805,7 +946,7 @@ U32 Perl_to_uni_lower(pTHX_ U32 c) { U8 tmpbuf[UTF8_MAXLEN+1]; - uv_to_utf8(tmpbuf, (UV)c); + uvuni_to_utf8(tmpbuf, (UV)c); return to_utf8_lower(tmpbuf); } @@ -1084,7 +1225,7 @@ Perl_to_utf8_upper(pTHX_ U8 *p) if (!PL_utf8_toupper) PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_toupper, p); - return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); + return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0); } UV @@ -1095,7 +1236,7 @@ Perl_to_utf8_title(pTHX_ U8 *p) if (!PL_utf8_totitle) PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_totitle, p); - return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); + return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0); } UV @@ -1106,7 +1247,7 @@ Perl_to_utf8_lower(pTHX_ U8 *p) if (!PL_utf8_tolower) PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0); uv = swash_fetch(PL_utf8_tolower, p); - return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0); + return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0); } /* a "swash" is a swatch hash */ @@ -1200,7 +1341,10 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr) PUSHMARK(SP); EXTEND(SP,3); PUSHs((SV*)sv); - PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1)))); + /* We call utf8_to_uni as we want and index into Unicode tables, + not a native character number. + */ + PUSHs(sv_2mortal(newSViv(utf8_to_uvuni(ptr, 0) & ~(needents - 1)))); PUSHs(sv_2mortal(newSViv(needents))); PUTBACK; if (call_method("SWASHGET", G_SCALAR))