diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Encode/encode.h')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Encode/encode.h | 1235 |
1 files changed, 1235 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Encode/encode.h b/Master/tlpkg/tlperl/lib/Encode/encode.h index df5554f1cb8..5d7663d5b55 100644 --- a/Master/tlpkg/tlperl/lib/Encode/encode.h +++ b/Master/tlpkg/tlperl/lib/Encode/encode.h @@ -99,6 +99,7 @@ extern void Encode_DefineEncoding(encode_t *enc); #define ENCODE_WARN_ON_ERR 0x0002 /* warn on error; may proceed */ #define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */ #define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */ +#define ENCODE_ONLY_PRAGMA_WARNINGS 0x0010 /* when enabled report only warnings configured by pragma warnings, otherwise report all warnings; no effect without ENCODE_WARN_ON_ERR */ #define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */ #define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */ #define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */ @@ -112,4 +113,1238 @@ extern void Encode_DefineEncoding(encode_t *enc); #define ENCODE_FB_HTMLCREF (ENCODE_HTMLCREF|ENCODE_LEAVE_SRC) #define ENCODE_FB_XMLCREF (ENCODE_XMLCREF|ENCODE_LEAVE_SRC) +#define encode_ckWARN(c, w) ((c & ENCODE_WARN_ON_ERR) \ + && (!(c & ENCODE_ONLY_PRAGMA_WARNINGS) || ckWARN(w))) + +#ifdef UTF8SKIP +# ifdef EBCDIC /* The value on early perls is wrong */ +# undef UTF8_MAXBYTES +# define UTF8_MAXBYTES 14 +# endif +# ifndef UNLIKELY +# define UNLIKELY(x) (x) +# endif +# ifndef LIKELY +# define LIKELY(x) (x) +# endif + +/* EBCDIC requires a later perl to work, so the next two definitions are for + * ASCII machines only */ +# ifndef NATIVE_UTF8_TO_I8 +# define NATIVE_UTF8_TO_I8(x) (x) +# endif +# ifndef I8_TO_NATIVE_UTF8 +# define I8_TO_NATIVE_UTF8(x) (x) +# endif +# ifndef OFFUNISKIP +# define OFFUNISKIP(x) UNISKIP(x) +# endif +# ifndef uvoffuni_to_utf8_flags +# define uvoffuni_to_utf8_flags(a,b,c) uvuni_to_utf8_flags(a,b,c) +# endif +# ifndef WARN_SURROGATE /* Use the overarching category if these + subcategories are missing */ +# define WARN_SURROGATE WARN_UTF8 +# define WARN_NONCHAR WARN_UTF8 +# define WARN_NON_UNICODE WARN_UTF8 + /* If there's only one possible category, then packing is a no-op */ +# define encode_ckWARN_packed(c, w) encode_ckWARN(c, w) +# else +# define encode_ckWARN_packed(c, w) \ + ((c & ENCODE_WARN_ON_ERR) \ + && (!(c & ENCODE_ONLY_PRAGMA_WARNINGS) || Perl_ckwarn(aTHX_ w))) +# endif + +/* All these formats take a single UV code point argument */ +static const char surrogate_cp_format[] = "UTF-16 surrogate U+%04" UVXf; +static const char nonchar_cp_format[] = "Unicode non-character U+%04" UVXf + " is not recommended for open interchange"; +static const char super_cp_format[] = "Code point 0x%" UVXf " is not Unicode," + " may not be portable"; + +/* If the perl doesn't have the 5.28 functions, this file includes + * stripped-down versions of them but containing enough functionality to be + * suitable for Encode's needs. Many of the comments have been removed. But + * you can inspect the 5.28 source if you get stuck. + * + * These could be put in Devel::PPPort, but Encode is likely the only user */ + +#if (defined(IN_ENCODE_XS) || defined(IN_UNICODE_XS)) \ + && (! defined(utf8n_to_uvchr_msgs) && ! defined(uvchr_to_utf8_flags_msgs)) + +# ifndef hv_stores +# define hv_stores(hv, key, val) hv_store((hv), ("" key ""), (sizeof(key)-1), (val), 0) +# endif + +static HV * +S_new_msg_hv(const char * const message, /* The message text */ + U32 categories) /* Packed warning categories */ +{ + /* Creates, populates, and returns an HV* that describes an error message + * for the translators between UTF8 and code point */ + + dTHX; + SV* msg_sv = newSVpv(message, 0); + SV* category_sv = newSVuv(categories); + + HV* msg_hv = newHV(); + + (void) hv_stores(msg_hv, "text", msg_sv); + (void) hv_stores(msg_hv, "warn_categories", category_sv); + + return msg_hv; +} + +#endif + +#if ! defined(utf8n_to_uvchr_msgs) \ + && (defined(IN_ENCODE_XS) || defined(IN_UNICODE_XS)) + +# undef utf8n_to_uvchr /* Don't use an earlier version: use the version + defined in this file */ +# define utf8n_to_uvchr(a,b,c,d) utf8n_to_uvchr_msgs(a, b, c, d, 0, NULL) + +# undef UTF8_IS_START /* Early perls wrongly accepted C0 and C1 */ +# define UTF8_IS_START(c) (((U8)(c)) >= 0xc2) +# ifndef isUTF8_POSSIBLY_PROBLEMATIC +# ifdef EBCDIC +# define isUTF8_POSSIBLY_PROBLEMATIC(c) ((U8) c > ' ') +# else +# define isUTF8_POSSIBLY_PROBLEMATIC(c) ((U8) c >= 0xED) +# endif +# endif +# ifndef UTF8_ALLOW_OVERFLOW +# define UTF8_ALLOW_OVERFLOW (1U<<31) /* Choose highest bit to avoid + potential conflicts */ +# define UTF8_GOT_OVERFLOW UTF8_ALLOW_OVERFLOW +# endif +# undef UTF8_ALLOW_ANY /* Early perl definitions don't work properly with + the code in this file */ +# define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \ + |UTF8_ALLOW_NON_CONTINUATION \ + |UTF8_ALLOW_SHORT \ + |UTF8_ALLOW_LONG \ + |UTF8_ALLOW_OVERFLOW) + +/* The meanings of these were complemented at some point, but the functions + * bundled in this file use the complemented meanings */ +# ifndef UTF8_DISALLOW_SURROGATE +# define UTF8_DISALLOW_SURROGATE UTF8_ALLOW_SURROGATE +# define UTF8_DISALLOW_NONCHAR UTF8_ALLOW_FFFF +# define UTF8_DISALLOW_SUPER UTF8_ALLOW_FE_FF + + /* In the stripped-down implementation in this file, disallowing is not + * independent of warning */ +# define UTF8_WARN_SURROGATE UTF8_DISALLOW_SURROGATE +# define UTF8_WARN_NONCHAR UTF8_DISALLOW_NONCHAR +# define UTF8_WARN_SUPER UTF8_DISALLOW_SUPER +# endif +# ifndef UTF8_DISALLOW_ILLEGAL_INTERCHANGE +# define UTF8_DISALLOW_ILLEGAL_INTERCHANGE \ + (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_SURROGATE|UTF8_DISALLOW_NONCHAR) +# endif +# ifndef UTF8_WARN_ILLEGAL_INTERCHANGE +# define UTF8_WARN_ILLEGAL_INTERCHANGE \ + (UTF8_WARN_SUPER|UTF8_WARN_SURROGATE|UTF8_WARN_NONCHAR) +# endif +# ifndef FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER +# ifdef EBCDIC /* On EBCDIC, these are actually I8 bytes */ +# define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER 0xFA +# define IS_UTF8_2_BYTE_SUPER(s0, s1) ((s0) == 0xF9 && (s1) >= 0xA2) + +# define IS_UTF8_2_BYTE_SURROGATE(s0, s1) ((s0) == 0xF1 \ + && ((s1) & 0xFE ) == 0xB6) +# else +# define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER 0xF5 +# define IS_UTF8_2_BYTE_SUPER(s0, s1) ((s0) == 0xF4 && (s1) >= 0x90) +# define IS_UTF8_2_BYTE_SURROGATE(s0, s1) ((s0) == 0xED && (s1) >= 0xA0) +# endif +# ifndef HIGHEST_REPRESENTABLE_UTF8 +# if defined(UV_IS_QUAD) /* These assume IV_MAX is 2**63-1 */ +# ifdef EBCDIC /* Actually is I8 */ +# define HIGHEST_REPRESENTABLE_UTF8 \ + "\xFF\xA7\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF" +# else +# define HIGHEST_REPRESENTABLE_UTF8 \ + "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF" +# endif +# endif +# endif +# endif + +# ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +# endif + +# ifndef PERL_UNUSED_ARG +# define PERL_UNUSED_ARG(x) ((void)x) +# endif + +static const char malformed_text[] = "Malformed UTF-8 character"; + +static char * +_byte_dump_string(const U8 * const start, const STRLEN len) +{ + /* Returns a mortalized C string that is a displayable copy of the 'len' */ + + const STRLEN output_len = 4 * len + 1; /* 4 bytes per each input, plus a + trailing NUL */ + const U8 * s = start; + const U8 * const e = start + len; + char * output; + char * d; + dTHX; + + Newx(output, output_len, char); + SAVEFREEPV(output); + + d = output; + for (s = start; s < e; s++) { + const unsigned high_nibble = (*s & 0xF0) >> 4; + const unsigned low_nibble = (*s & 0x0F); + + *d++ = '\\'; + *d++ = 'x'; + + if (high_nibble < 10) { + *d++ = high_nibble + '0'; + } + else { + *d++ = high_nibble - 10 + 'a'; + } + + if (low_nibble < 10) { + *d++ = low_nibble + '0'; + } + else { + *d++ = low_nibble - 10 + 'a'; + } + } + + *d = '\0'; + return output; +} + +static char * +S_unexpected_non_continuation_text(const U8 * const s, + + /* Max number of bytes to print */ + STRLEN print_len, + + /* Which one is the non-continuation */ + const STRLEN non_cont_byte_pos, + + /* How many bytes should there be? */ + const STRLEN expect_len) +{ + /* Return the malformation warning text for an unexpected continuation + * byte. */ + + dTHX; + const char * const where = (non_cont_byte_pos == 1) + ? "immediately" + : Perl_form(aTHX_ "%d bytes", + (int) non_cont_byte_pos); + const U8 * x = s + non_cont_byte_pos; + const U8 * e = s + print_len; + + /* We don't need to pass this parameter, but since it has already been + * calculated, it's likely faster to pass it; verify under DEBUGGING */ + assert(expect_len == UTF8SKIP(s)); + + /* As a defensive coding measure, don't output anything past a NUL. Such + * bytes shouldn't be in the middle of a malformation, and could mark the + * end of the allocated string, and what comes after is undefined */ + for (; x < e; x++) { + if (*x == '\0') { + x++; /* Output this particular NUL */ + break; + } + } + + return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x," + " %s after start byte 0x%02x; need %d bytes, got %d)", + malformed_text, + _byte_dump_string(s, x - s), + *(s + non_cont_byte_pos), + where, + *s, + (int) expect_len, + (int) non_cont_byte_pos); +} + +static int +S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len); + +static int +S_does_utf8_overflow(const U8 * const s, + const U8 * e, + const bool consider_overlongs) +{ + /* Returns an int indicating whether or not the UTF-8 sequence from 's' to + * 'e' - 1 would overflow an IV on this platform. */ + +# if ! defined(UV_IS_QUAD) + + const STRLEN len = e - s; + int is_overlong; + + assert(s <= e && s + UTF8SKIP(s) >= e); + assert(! UTF8_IS_INVARIANT(*s) && e > s); + +# ifdef EBCDIC + + PERL_UNUSED_ARG(consider_overlongs); + + if (*s != 0xFE) { + return 0; + } + + if (len == 1) { + return -1; + } + +# else + + if (LIKELY(*s < 0xFE)) { + return 0; + } + + if (! consider_overlongs) { + return 1; + } + + if (len == 1) { + return -1; + } + + is_overlong = S_is_utf8_overlong_given_start_byte_ok(s, len); + + if (is_overlong == 0) { + return 1; + } + + if (is_overlong < 0) { + return -1; + } + + if (*s == 0xFE) { + return 0; + } + +# endif + + /* Here, ASCII and EBCDIC rejoin: + * On ASCII: We have an overlong sequence starting with FF + * On EBCDIC: We have a sequence starting with FE. */ + + { /* For C89, use a block so the declaration can be close to its use */ + +# ifdef EBCDIC + const U8 conts_for_highest_30_bit[] = "\x41\x41\x41\x41\x41\x41\x42"; +# else + const U8 conts_for_highest_30_bit[] = "\x80\x80\x80\x80\x80\x80\x81"; +# endif + const STRLEN conts_len = sizeof(conts_for_highest_30_bit) - 1; + const STRLEN cmp_len = MIN(conts_len, len - 1); + + if (cmp_len >= conts_len || memNE(s + 1, + conts_for_highest_30_bit, + cmp_len)) + { + return memGT(s + 1, conts_for_highest_30_bit, cmp_len); + } + + return -1; + } + +# else /* Below is 64-bit word */ + + PERL_UNUSED_ARG(consider_overlongs); + + { + const STRLEN len = e - s; + const U8 *x; + const U8 * y = (const U8 *) HIGHEST_REPRESENTABLE_UTF8; + + for (x = s; x < e; x++, y++) { + + if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) == *y)) { + continue; + } + return NATIVE_UTF8_TO_I8(*x) > *y; + } + + if (len < sizeof(HIGHEST_REPRESENTABLE_UTF8) - 1) { + return -1; + } + + return 0; + } + +# endif + +} + +static int +S_isFF_OVERLONG(const U8 * const s, const STRLEN len); + +static int +S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len) +{ + const U8 s0 = NATIVE_UTF8_TO_I8(s[0]); + const U8 s1 = NATIVE_UTF8_TO_I8(s[1]); + + assert(len > 1 && UTF8_IS_START(*s)); + +# ifdef EBCDIC +# define F0_ABOVE_OVERLONG 0xB0 +# define F8_ABOVE_OVERLONG 0xA8 +# define FC_ABOVE_OVERLONG 0xA4 +# define FE_ABOVE_OVERLONG 0xA2 +# define FF_OVERLONG_PREFIX "\xfe\x41\x41\x41\x41\x41\x41\x41" +# else + + if (s0 == 0xE0 && UNLIKELY(s1 < 0xA0)) { + return 1; + } + +# define F0_ABOVE_OVERLONG 0x90 +# define F8_ABOVE_OVERLONG 0x88 +# define FC_ABOVE_OVERLONG 0x84 +# define FE_ABOVE_OVERLONG 0x82 +# define FF_OVERLONG_PREFIX "\xff\x80\x80\x80\x80\x80\x80" +# endif + + if ( (s0 == 0xF0 && UNLIKELY(s1 < F0_ABOVE_OVERLONG)) + || (s0 == 0xF8 && UNLIKELY(s1 < F8_ABOVE_OVERLONG)) + || (s0 == 0xFC && UNLIKELY(s1 < FC_ABOVE_OVERLONG)) + || (s0 == 0xFE && UNLIKELY(s1 < FE_ABOVE_OVERLONG))) + { + return 1; + } + + /* Check for the FF overlong */ + return S_isFF_OVERLONG(s, len); +} + +int +S_isFF_OVERLONG(const U8 * const s, const STRLEN len) +{ + if (LIKELY(memNE(s, FF_OVERLONG_PREFIX, + MIN(len, sizeof(FF_OVERLONG_PREFIX) - 1)))) + { + return 0; + } + + if (len >= sizeof(FF_OVERLONG_PREFIX) - 1) { + return 1; + } + + return -1; +} + +# ifndef UTF8_GOT_CONTINUATION +# define UTF8_GOT_CONTINUATION UTF8_ALLOW_CONTINUATION +# define UTF8_GOT_EMPTY UTF8_ALLOW_EMPTY +# define UTF8_GOT_LONG UTF8_ALLOW_LONG +# define UTF8_GOT_NON_CONTINUATION UTF8_ALLOW_NON_CONTINUATION +# define UTF8_GOT_SHORT UTF8_ALLOW_SHORT +# define UTF8_GOT_SURROGATE UTF8_DISALLOW_SURROGATE +# define UTF8_GOT_NONCHAR UTF8_DISALLOW_NONCHAR +# define UTF8_GOT_SUPER UTF8_DISALLOW_SUPER +# endif + +# ifndef UNICODE_IS_SUPER +# define UNICODE_IS_SUPER(uv) ((UV) (uv) > PERL_UNICODE_MAX) +# endif +# ifndef UNICODE_IS_32_CONTIGUOUS_NONCHARS +# define UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv) ((UV) (uv) >= 0xFDD0 \ + && (UV) (uv) <= 0xFDEF) +# endif +# ifndef UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER +# define UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv) \ + (((UV) (uv) & 0xFFFE) == 0xFFFE) +# endif +# ifndef is_NONCHAR_utf8_safe +# define is_NONCHAR_utf8_safe(s,e) /*** GENERATED CODE ***/ \ +( ( ( LIKELY((e) > (s)) ) && ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ) ? ( ( 0xEF == ((const U8*)s)[0] ) ?\ + ( ( 0xB7 == ((const U8*)s)[1] ) ? \ + ( ( 0x90 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0xAF ) ? 3 : 0 )\ + : ( ( 0xBF == ((const U8*)s)[1] ) && ( ( ((const U8*)s)[2] & 0xFE ) == 0xBE ) ) ? 3 : 0 )\ + : ( 0xF0 == ((const U8*)s)[0] ) ? \ + ( ( ( ( ((const U8*)s)[1] == 0x9F || ( ( ((const U8*)s)[1] & 0xEF ) == 0xAF ) ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 )\ + : ( 0xF1 <= ((const U8*)s)[0] && ((const U8*)s)[0] <= 0xF3 ) ? \ + ( ( ( ( ( ((const U8*)s)[1] & 0xCF ) == 0x8F ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 )\ + : ( ( ( ( 0xF4 == ((const U8*)s)[0] ) && ( 0x8F == ((const U8*)s)[1] ) ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 ) : 0 ) +# endif + +# ifndef UTF8_IS_NONCHAR +# define UTF8_IS_NONCHAR(s, e) (is_NONCHAR_utf8_safe(s,e) > 0) +# endif +# ifndef UNICODE_IS_NONCHAR +# define UNICODE_IS_NONCHAR(uv) \ + ( UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv) \ + || ( LIKELY( ! UNICODE_IS_SUPER(uv)) \ + && UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) +# endif + +# ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +# endif + +static UV +utf8n_to_uvchr_msgs(const U8 *s, + STRLEN curlen, + STRLEN *retlen, + const U32 flags, + U32 * errors, + AV ** msgs) +{ + const U8 * const s0 = s; + const U8 * send = NULL; + U32 possible_problems = 0; + UV uv = *s; + STRLEN expectlen = 0; + U8 * adjusted_s0 = (U8 *) s0; + U8 temp_char_buf[UTF8_MAXBYTES + 1]; + UV uv_so_far = 0; + dTHX; + + assert(errors == NULL); /* This functionality has been stripped */ + + if (UNLIKELY(curlen == 0)) { + possible_problems |= UTF8_GOT_EMPTY; + curlen = 0; + uv = UNICODE_REPLACEMENT; + goto ready_to_handle_errors; + } + + expectlen = UTF8SKIP(s); + + if (retlen) { + *retlen = expectlen; + } + + if (UTF8_IS_INVARIANT(uv)) { + return uv; + } + + if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) { + possible_problems |= UTF8_GOT_CONTINUATION; + curlen = 1; + uv = UNICODE_REPLACEMENT; + goto ready_to_handle_errors; + } + + uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen); + + send = (U8*) s0; + if (UNLIKELY(curlen < expectlen)) { + possible_problems |= UTF8_GOT_SHORT; + send += curlen; + } + else { + send += expectlen; + } + + for (s = s0 + 1; s < send; s++) { + if (LIKELY(UTF8_IS_CONTINUATION(*s))) { + uv = UTF8_ACCUMULATE(uv, *s); + continue; + } + + possible_problems |= UTF8_GOT_NON_CONTINUATION; + break; + } /* End of loop through the character's bytes */ + + curlen = s - s0; + +# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION) + + if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) { + uv_so_far = uv; + uv = UNICODE_REPLACEMENT; + } + + if (UNLIKELY(0 < S_does_utf8_overflow(s0, s, 1))) { + possible_problems |= UTF8_GOT_OVERFLOW; + uv = UNICODE_REPLACEMENT; + } + + if ( ( LIKELY(! possible_problems) + && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv))) + || ( UNLIKELY(possible_problems) + && ( UNLIKELY(! UTF8_IS_START(*s0)) + || ( curlen > 1 + && UNLIKELY(0 < S_is_utf8_overlong_given_start_byte_ok(s0, + s - s0)))))) + { + possible_problems |= UTF8_GOT_LONG; + + if ( UNLIKELY( possible_problems & UTF8_GOT_TOO_SHORT) + && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW))) + { + UV min_uv = uv_so_far; + STRLEN i; + + for (i = curlen; i < expectlen; i++) { + min_uv = UTF8_ACCUMULATE(min_uv, + I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK)); + } + + adjusted_s0 = temp_char_buf; + (void) uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0); + } + } + + /* Here, we have found all the possible problems, except for when the input + * is for a problematic code point not allowed by the input parameters. */ + + /* uv is valid for overlongs */ + if ( ( ( LIKELY(! (possible_problems & ~UTF8_GOT_LONG)) + && uv >= UNICODE_SURROGATE_FIRST) + || ( UNLIKELY(possible_problems) + && isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0))) + && ((flags & ( UTF8_DISALLOW_NONCHAR + |UTF8_DISALLOW_SURROGATE + |UTF8_DISALLOW_SUPER)))) + { + if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) { + if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) { + possible_problems |= UTF8_GOT_SURROGATE; + } + else if (UNLIKELY(uv > PERL_UNICODE_MAX)) { + possible_problems |= UTF8_GOT_SUPER; + } + else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) { + possible_problems |= UTF8_GOT_NONCHAR; + } + } + else { + if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0) + >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER)) + { + possible_problems |= UTF8_GOT_SUPER; + } + else if (curlen > 1) { + if (UNLIKELY(IS_UTF8_2_BYTE_SUPER( + NATIVE_UTF8_TO_I8(*adjusted_s0), + NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1))))) + { + possible_problems |= UTF8_GOT_SUPER; + } + else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE( + NATIVE_UTF8_TO_I8(*adjusted_s0), + NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1))))) + { + possible_problems |= UTF8_GOT_SURROGATE; + } + } + } + } + + ready_to_handle_errors: + + if (UNLIKELY(possible_problems)) { + bool disallowed = FALSE; + const U32 orig_problems = possible_problems; + + if (msgs) { + *msgs = NULL; + } + + while (possible_problems) { /* Handle each possible problem */ + UV pack_warn = 0; + char * message = NULL; + U32 this_flag_bit = 0; + + /* Each 'if' clause handles one problem. They are ordered so that + * the first ones' messages will be displayed before the later + * ones; this is kinda in decreasing severity order. But the + * overlong must come last, as it changes 'uv' looked at by the + * others */ + if (possible_problems & UTF8_GOT_OVERFLOW) { + + /* Overflow means also got a super; we handle both here */ + possible_problems + &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER); + + /* Disallow if any of the categories say to */ + if ( ! (flags & UTF8_ALLOW_OVERFLOW) + || (flags & UTF8_DISALLOW_SUPER)) + { + disallowed = TRUE; + } + + /* Likewise, warn if any say to */ + if ( ! (flags & UTF8_ALLOW_OVERFLOW)) { + + /* The warnings code explicitly says it doesn't handle the + * case of packWARN2 and two categories which have + * parent-child relationship. Even if it works now to + * raise the warning if either is enabled, it wouldn't + * necessarily do so in the future. We output (only) the + * most dire warning */ + if (! (flags & UTF8_CHECK_ONLY)) { + if (msgs || ckWARN_d(WARN_UTF8)) { + pack_warn = packWARN(WARN_UTF8); + } + else if (msgs || ckWARN_d(WARN_NON_UNICODE)) { + pack_warn = packWARN(WARN_NON_UNICODE); + } + if (pack_warn) { + message = Perl_form(aTHX_ "%s: %s (overflows)", + malformed_text, + _byte_dump_string(s0, curlen)); + this_flag_bit = UTF8_GOT_OVERFLOW; + } + } + } + } + else if (possible_problems & UTF8_GOT_EMPTY) { + possible_problems &= ~UTF8_GOT_EMPTY; + + if (! (flags & UTF8_ALLOW_EMPTY)) { + disallowed = TRUE; + if ( (msgs + || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY)) + { + pack_warn = packWARN(WARN_UTF8); + message = Perl_form(aTHX_ "%s (empty string)", + malformed_text); + this_flag_bit = UTF8_GOT_EMPTY; + } + } + } + else if (possible_problems & UTF8_GOT_CONTINUATION) { + possible_problems &= ~UTF8_GOT_CONTINUATION; + + if (! (flags & UTF8_ALLOW_CONTINUATION)) { + disallowed = TRUE; + if (( msgs + || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY)) + { + pack_warn = packWARN(WARN_UTF8); + message = Perl_form(aTHX_ + "%s: %s (unexpected continuation byte 0x%02x," + " with no preceding start byte)", + malformed_text, + _byte_dump_string(s0, 1), *s0); + this_flag_bit = UTF8_GOT_CONTINUATION; + } + } + } + else if (possible_problems & UTF8_GOT_SHORT) { + possible_problems &= ~UTF8_GOT_SHORT; + + if (! (flags & UTF8_ALLOW_SHORT)) { + disallowed = TRUE; + if (( msgs + || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY)) + { + pack_warn = packWARN(WARN_UTF8); + message = Perl_form(aTHX_ + "%s: %s (too short; %d byte%s available, need %d)", + malformed_text, + _byte_dump_string(s0, send - s0), + (int)curlen, + curlen == 1 ? "" : "s", + (int)expectlen); + this_flag_bit = UTF8_GOT_SHORT; + } + } + + } + else if (possible_problems & UTF8_GOT_NON_CONTINUATION) { + possible_problems &= ~UTF8_GOT_NON_CONTINUATION; + + if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) { + disallowed = TRUE; + if (( msgs + || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY)) + { + int printlen = s - s0; + pack_warn = packWARN(WARN_UTF8); + message = Perl_form(aTHX_ "%s", + S_unexpected_non_continuation_text(s0, + printlen, + s - s0, + (int) expectlen)); + this_flag_bit = UTF8_GOT_NON_CONTINUATION; + } + } + } + else if (possible_problems & UTF8_GOT_SURROGATE) { + possible_problems &= ~UTF8_GOT_SURROGATE; + + if (flags & UTF8_WARN_SURROGATE) { + + if ( ! (flags & UTF8_CHECK_ONLY) + && (msgs || ckWARN_d(WARN_SURROGATE))) + { + pack_warn = packWARN(WARN_SURROGATE); + + /* These are the only errors that can occur with a + * surrogate when the 'uv' isn't valid */ + if (orig_problems & UTF8_GOT_TOO_SHORT) { + message = Perl_form(aTHX_ + "UTF-16 surrogate (any UTF-8 sequence that" + " starts with \"%s\" is for a surrogate)", + _byte_dump_string(s0, curlen)); + } + else { + message = Perl_form(aTHX_ surrogate_cp_format, uv); + } + this_flag_bit = UTF8_GOT_SURROGATE; + } + } + + if (flags & UTF8_DISALLOW_SURROGATE) { + disallowed = TRUE; + } + } + else if (possible_problems & UTF8_GOT_SUPER) { + possible_problems &= ~UTF8_GOT_SUPER; + + if (flags & UTF8_WARN_SUPER) { + + if ( ! (flags & UTF8_CHECK_ONLY) + && (msgs || ckWARN_d(WARN_NON_UNICODE))) + { + pack_warn = packWARN(WARN_NON_UNICODE); + + if (orig_problems & UTF8_GOT_TOO_SHORT) { + message = Perl_form(aTHX_ + "Any UTF-8 sequence that starts with" + " \"%s\" is for a non-Unicode code point," + " may not be portable", + _byte_dump_string(s0, curlen)); + } + else { + message = Perl_form(aTHX_ super_cp_format, uv); + } + this_flag_bit = UTF8_GOT_SUPER; + } + } + + if (flags & UTF8_DISALLOW_SUPER) { + disallowed = TRUE; + } + } + else if (possible_problems & UTF8_GOT_NONCHAR) { + possible_problems &= ~UTF8_GOT_NONCHAR; + + if (flags & UTF8_WARN_NONCHAR) { + + if ( ! (flags & UTF8_CHECK_ONLY) + && (msgs || ckWARN_d(WARN_NONCHAR))) + { + /* The code above should have guaranteed that we don't + * get here with errors other than overlong */ + assert (! (orig_problems + & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR))); + + pack_warn = packWARN(WARN_NONCHAR); + message = Perl_form(aTHX_ nonchar_cp_format, uv); + this_flag_bit = UTF8_GOT_NONCHAR; + } + } + + if (flags & UTF8_DISALLOW_NONCHAR) { + disallowed = TRUE; + } + } + else if (possible_problems & UTF8_GOT_LONG) { + possible_problems &= ~UTF8_GOT_LONG; + + if (flags & UTF8_ALLOW_LONG) { + uv = UNICODE_REPLACEMENT; + } + else { + disallowed = TRUE; + + if (( msgs + || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY)) + { + pack_warn = packWARN(WARN_UTF8); + + /* These error types cause 'uv' to be something that + * isn't what was intended, so can't use it in the + * message. The other error types either can't + * generate an overlong, or else the 'uv' is valid */ + if (orig_problems & + (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW)) + { + message = Perl_form(aTHX_ + "%s: %s (any UTF-8 sequence that starts" + " with \"%s\" is overlong which can and" + " should be represented with a" + " different, shorter sequence)", + malformed_text, + _byte_dump_string(s0, send - s0), + _byte_dump_string(s0, curlen)); + } + else { + U8 tmpbuf[UTF8_MAXBYTES+1]; + const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf, + uv, 0); + /* Don't use U+ for non-Unicode code points, which + * includes those in the Latin1 range */ + const char * preface = ( uv > PERL_UNICODE_MAX +# ifdef EBCDIC + || uv <= 0xFF +# endif + ) + ? "0x" + : "U+"; + message = Perl_form(aTHX_ + "%s: %s (overlong; instead use %s to represent" + " %s%0*" UVXf ")", + malformed_text, + _byte_dump_string(s0, send - s0), + _byte_dump_string(tmpbuf, e - tmpbuf), + preface, + ((uv < 256) ? 2 : 4), /* Field width of 2 for + small code points */ + UNI_TO_NATIVE(uv)); + } + this_flag_bit = UTF8_GOT_LONG; + } + } + } /* End of looking through the possible flags */ + + /* Display the message (if any) for the problem being handled in + * this iteration of the loop */ + if (message) { + if (msgs) { + assert(this_flag_bit); + + if (*msgs == NULL) { + *msgs = newAV(); + } + + av_push(*msgs, newRV_noinc((SV*) S_new_msg_hv(message, + pack_warn))); + } + else if (PL_op) + Perl_warner(aTHX_ pack_warn, "%s in %s", message, + OP_DESC(PL_op)); + else + Perl_warner(aTHX_ pack_warn, "%s", message); + } + } /* End of 'while (possible_problems)' */ + + if (retlen) { + *retlen = curlen; + } + + if (disallowed) { + if (flags & UTF8_CHECK_ONLY && retlen) { + *retlen = ((STRLEN) -1); + } + return 0; + } + } + + return UNI_TO_NATIVE(uv); +} + +static STRLEN +S_is_utf8_char_helper(const U8 * const s, const U8 * e, const U32 flags) +{ + STRLEN len; + const U8 *x; + + assert(0 == (flags & ~UTF8_DISALLOW_ILLEGAL_INTERCHANGE)); + assert(! UTF8_IS_INVARIANT(*s)); + + if (UNLIKELY(! UTF8_IS_START(*s))) { + return 0; + } + + /* Examine a maximum of a single whole code point */ + if (e - s > UTF8SKIP(s)) { + e = s + UTF8SKIP(s); + } + + len = e - s; + + if (flags && isUTF8_POSSIBLY_PROBLEMATIC(*s)) { + const U8 s0 = NATIVE_UTF8_TO_I8(s[0]); + + if ( (flags & UTF8_DISALLOW_SUPER) + && UNLIKELY(s0 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER)) + { + return 0; /* Above Unicode */ + } + + if (len > 1) { + const U8 s1 = NATIVE_UTF8_TO_I8(s[1]); + + if ( (flags & UTF8_DISALLOW_SUPER) + && UNLIKELY(IS_UTF8_2_BYTE_SUPER(s0, s1))) + { + return 0; /* Above Unicode */ + } + + if ( (flags & UTF8_DISALLOW_SURROGATE) + && UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(s0, s1))) + { + return 0; /* Surrogate */ + } + + if ( (flags & UTF8_DISALLOW_NONCHAR) + && UNLIKELY(UTF8_IS_NONCHAR(s, e))) + { + return 0; /* Noncharacter code point */ + } + } + } + + for (x = s + 1; x < e; x++) { + if (UNLIKELY(! UTF8_IS_CONTINUATION(*x))) { + return 0; + } + } + + if (len > 1 && S_is_utf8_overlong_given_start_byte_ok(s, len) > 0) { + return 0; + } + + if (0 < S_does_utf8_overflow(s, e, 0)) { + return 0; + } + + return UTF8SKIP(s); +} + +# undef is_utf8_valid_partial_char_flags + +static bool +is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags) +{ + + return S_is_utf8_char_helper(s, e, flags) > 0; +} + +# undef is_utf8_string_loc_flags + +static bool +is_utf8_string_loc_flags(const U8 *s, STRLEN len, const U8 **ep, const U32 flags) +{ + const U8* send = s + len; + + assert(0 == (flags & ~UTF8_DISALLOW_ILLEGAL_INTERCHANGE)); + + while (s < send) { + if (UTF8_IS_INVARIANT(*s)) { + s++; + } + else if ( UNLIKELY(send - s < UTF8SKIP(s)) + || ! S_is_utf8_char_helper(s, send, flags)) + { + *ep = s; + return 0; + } + else { + s += UTF8SKIP(s); + } + } + + *ep = send; + + return 1; +} + +#endif + +#if defined(IN_UNICODE_XS) && ! defined(uvchr_to_utf8_flags_msgs) + +# define MY_SHIFT UTF_ACCUMULATION_SHIFT +# define MY_MARK UTF_CONTINUATION_MARK +# define MY_MASK UTF_CONTINUATION_MASK + +static const char cp_above_legal_max[] = + "Use of code point 0x%" UVXf " is not allowed; the" + " permissible max is 0x%" UVXf; + +/* These two can be dummys, as they are not looked at by the function, which + * has hard-coded into it what flags it is expecting are */ +# ifndef UNICODE_DISALLOW_ILLEGAL_INTERCHANGE +# define UNICODE_DISALLOW_ILLEGAL_INTERCHANGE 0 +# endif +# ifndef UNICODE_WARN_ILLEGAL_INTERCHANGE +# define UNICODE_WARN_ILLEGAL_INTERCHANGE 0 +# endif + +# ifndef OFFUNI_IS_INVARIANT +# define OFFUNI_IS_INVARIANT(cp) UNI_IS_INVARIANT(cp) +# endif +# ifndef MAX_EXTERNALLY_LEGAL_CP +# define MAX_EXTERNALLY_LEGAL_CP ((UV) (IV_MAX)) +# endif +# ifndef LATIN1_TO_NATIVE +# define LATIN1_TO_NATIVE(a) ASCII_TO_NATIVE(a) +# endif +# ifndef I8_TO_NATIVE_UTF8 +# define I8_TO_NATIVE_UTF8(a) NATIVE_TO_UTF(a) +# endif +# ifndef MAX_UTF8_TWO_BYTE +# define MAX_UTF8_TWO_BYTE (32 * (1U << UTF_ACCUMULATION_SHIFT) - 1) +# endif +# ifndef UNICODE_IS_32_CONTIGUOUS_NONCHARS +# define UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv) ((UV) (uv) >= 0xFDD0 \ + && (UV) (uv) <= 0xFDEF) +# endif +# ifndef UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER +# define UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv) \ + (((UV) (uv) & 0xFFFE) == 0xFFFE) +# endif +# ifndef UNICODE_IS_SUPER +# define UNICODE_IS_SUPER(uv) ((UV) (uv) > PERL_UNICODE_MAX) +# endif +# ifndef OFFUNISKIP +# define OFFUNISKIP(cp) UNISKIP(NATIVE_TO_UNI(cp)) +# endif + +# define HANDLE_UNICODE_SURROGATE(uv, flags, msgs) \ + STMT_START { \ + U32 category = packWARN(WARN_SURROGATE); \ + const char * format = surrogate_cp_format; \ + *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv), \ + category); \ + return NULL; \ + } STMT_END; + +# define HANDLE_UNICODE_NONCHAR(uv, flags, msgs) \ + STMT_START { \ + U32 category = packWARN(WARN_NONCHAR); \ + const char * format = nonchar_cp_format; \ + *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv), \ + category); \ + return NULL; \ + } STMT_END; + +static U8 * +uvchr_to_utf8_flags_msgs(U8 *d, UV uv, const UV flags, HV** msgs) +{ + dTHX; + + assert(msgs); + + PERL_UNUSED_ARG(flags); + + uv = NATIVE_TO_UNI(uv); + + *msgs = NULL; + + if (OFFUNI_IS_INVARIANT(uv)) { + *d++ = LATIN1_TO_NATIVE(uv); + return d; + } + + if (uv <= MAX_UTF8_TWO_BYTE) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> MY_SHIFT) | UTF_START_MARK(2)); + *d++ = I8_TO_NATIVE_UTF8(( uv & MY_MASK) | MY_MARK); + return d; + } + + /* Not 2-byte; test for and handle 3-byte result. In the test immediately + * below, the 16 is for start bytes E0-EF (which are all the possible ones + * for 3 byte characters). The 2 is for 2 continuation bytes; these each + * contribute MY_SHIFT bits. This yields 0x4000 on EBCDIC platforms, 0x1_0000 + * on ASCII; so 3 bytes covers the range 0x400-0x3FFF on EBCDIC; + * 0x800-0xFFFF on ASCII */ + if (uv < (16 * (1U << (2 * MY_SHIFT)))) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * MY_SHIFT)) | UTF_START_MARK(3)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MY_MASK) | MY_MARK); + +#ifndef EBCDIC /* These problematic code points are 4 bytes on EBCDIC, so + aren't tested here */ + /* The most likely code points in this range are below the surrogates. + * Do an extra test to quickly exclude those. */ + if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST)) { + if (UNLIKELY( UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv) + || UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) + { + HANDLE_UNICODE_NONCHAR(uv, flags, msgs); + } + else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) { + HANDLE_UNICODE_SURROGATE(uv, flags, msgs); + } + } +#endif + return d; + } + + /* Not 3-byte; that means the code point is at least 0x1_0000 on ASCII + * platforms, and 0x4000 on EBCDIC. There are problematic cases that can + * happen starting with 4-byte characters on ASCII platforms. We unify the + * code for these with EBCDIC, even though some of them require 5-bytes on + * those, because khw believes the code saving is worth the very slight + * performance hit on these high EBCDIC code points. */ + + if (UNLIKELY(UNICODE_IS_SUPER(uv))) { + const char * format = super_cp_format; + U32 category = packWARN(WARN_NON_UNICODE); + if (UNLIKELY(uv > MAX_EXTERNALLY_LEGAL_CP)) { + Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_EXTERNALLY_LEGAL_CP); + } + *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv), category); + return NULL; + } + else if (UNLIKELY(UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) { + HANDLE_UNICODE_NONCHAR(uv, flags, msgs); + } + + /* Test for and handle 4-byte result. In the test immediately below, the + * 8 is for start bytes F0-F7 (which are all the possible ones for 4 byte + * characters). The 3 is for 3 continuation bytes; these each contribute + * MY_SHIFT bits. This yields 0x4_0000 on EBCDIC platforms, 0x20_0000 on + * ASCII, so 4 bytes covers the range 0x4000-0x3_FFFF on EBCDIC; + * 0x1_0000-0x1F_FFFF on ASCII */ + if (uv < (8 * (1U << (3 * MY_SHIFT)))) { + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * MY_SHIFT)) | UTF_START_MARK(4)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MY_MASK) | MY_MARK); + +#ifdef EBCDIC /* These were handled on ASCII platforms in the code for 3-byte + characters. The end-plane non-characters for EBCDIC were + handled just above */ + if (UNLIKELY(UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv))) { + HANDLE_UNICODE_NONCHAR(uv, flags, msgs); + } + else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) { + HANDLE_UNICODE_SURROGATE(uv, flags, msgs); + } +#endif + + return d; + } + + /* Not 4-byte; that means the code point is at least 0x20_0000 on ASCII + * platforms, and 0x4000 on EBCDIC. At this point we switch to a loop + * format. The unrolled version above turns out to not save all that much + * time, and at these high code points (well above the legal Unicode range + * on ASCII platforms, and well above anything in common use in EBCDIC), + * khw believes that less code outweighs slight performance gains. */ + + { + STRLEN len = OFFUNISKIP(uv); + U8 *p = d+len-1; + while (p > d) { + *p-- = I8_TO_NATIVE_UTF8((uv & MY_MASK) | MY_MARK); + uv >>= MY_SHIFT; + } + *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); + return d+len; + } +} + +#endif /* End of defining our own uvchr_to_utf8_flags_msgs() */ +#endif /* End of UTF8SKIP */ + #endif /* ENCODE_H */ |