This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8de56ebe2115357d5f00dbacc4ca58549f2cef38
[perl5.git] / cpan / Encode / Encode / encode.h
1 #ifndef ENCODE_H
2 #define ENCODE_H
3
4 #ifndef H_PERL
5 /* check whether we're "in perl" so that we can do data parts without
6    getting extern references to the code parts
7 */
8 typedef unsigned char U8;
9 #endif
10
11 typedef struct encpage_s encpage_t;
12
13 struct encpage_s
14 {
15     /* fields ordered to pack nicely on 32-bit machines */
16     const U8 *const seq;   /* Packed output sequences we generate 
17                   if we match */
18     const encpage_t *const next;      /* Page to go to if we match */
19     const U8   min;        /* Min value of octet to match this entry */
20     const U8   max;        /* Max value of octet to match this entry */
21     const U8   dlen;       /* destination length - 
22                   size of entries in seq */
23     const U8   slen;       /* source length - 
24                   number of source octets needed */
25 };
26
27 /*
28   At any point in a translation there is a page pointer which points
29   at an array of the above structures.
30
31   Basic operation :
32   get octet from source stream.
33   if (octet >= min && octet < max) {
34     if slen is 0 then we cannot represent this character.
35     if we have less than slen octets (including this one) then 
36       we have a partial character.
37     otherwise
38       copy dlen octets from seq + dlen*(octet-min) to output
39       (dlen may be zero if we don't know yet.)
40       load page pointer with next to continue.
41       (is slen is one this is end of a character)
42       get next octet.
43   }
44   else {
45     increment the page pointer to look at next slot in the array
46   }
47
48   arrays SHALL be constructed so there is an entry which matches
49   ..0xFF at the end, and either maps it or indicates no
50   representation.
51
52   if MSB of slen is set then mapping is an approximate "FALLBACK" entry.
53
54 */
55
56
57 typedef struct encode_s encode_t;
58 struct encode_s
59 {
60     const encpage_t *const t_utf8;  /* Starting table for translation from 
61                        the encoding to UTF-8 form */
62     const encpage_t *const f_utf8;  /* Starting table for translation 
63                        from UTF-8 to the encoding */
64     const U8 *const rep;            /* Replacement character in this
65                        encoding e.g. "?" */
66     int        replen;              /* Number of octets in rep */
67     U8         min_el;              /* Minimum octets to represent a
68                        character */
69     U8         max_el;              /* Maximum octets to represent a
70                        character */
71     const char *const name[2];      /* name(s) of this encoding */
72 };
73
74 #ifdef H_PERL
75 /* See comment at top of file for deviousness */
76
77 extern int do_encode(const encpage_t *enc, const U8 *src, STRLEN *slen,
78                      U8 *dst, STRLEN dlen, STRLEN *dout, int approx,
79              const U8 *term, STRLEN tlen);
80
81 extern void Encode_DefineEncoding(encode_t *enc);
82
83 #endif /* H_PERL */
84
85 #define ENCODE_NOSPACE  1
86 #define ENCODE_PARTIAL  2
87 #define ENCODE_NOREP    3
88 #define ENCODE_FALLBACK 4
89 #define ENCODE_FOUND_TERM 5
90
91 /* Use the perl core value if available; it is portable to EBCDIC */
92 #ifdef REPLACEMENT_CHARACTER_UTF8
93 #  define FBCHAR_UTF8           REPLACEMENT_CHARACTER_UTF8
94 #else
95 #  define FBCHAR_UTF8           "\xEF\xBF\xBD"
96 #endif
97
98 #define  ENCODE_DIE_ON_ERR     0x0001 /* croaks immediately */
99 #define  ENCODE_WARN_ON_ERR    0x0002 /* warn on error; may proceed */
100 #define  ENCODE_RETURN_ON_ERR  0x0004 /* immediately returns on NOREP */
101 #define  ENCODE_LEAVE_SRC      0x0008 /* $src updated unless set */
102 #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 */
103 #define  ENCODE_PERLQQ         0x0100 /* perlqq fallback string */
104 #define  ENCODE_HTMLCREF       0x0200 /* HTML character ref. fb mode */
105 #define  ENCODE_XMLCREF        0x0400 /* XML  character ref. fb mode */
106 #define  ENCODE_STOP_AT_PARTIAL 0x0800 /* stop at partial explicitly */
107
108 #define  ENCODE_FB_DEFAULT     0x0000
109 #define  ENCODE_FB_CROAK       0x0001
110 #define  ENCODE_FB_QUIET       ENCODE_RETURN_ON_ERR
111 #define  ENCODE_FB_WARN        (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR)
112 #define  ENCODE_FB_PERLQQ      (ENCODE_PERLQQ|ENCODE_LEAVE_SRC)
113 #define  ENCODE_FB_HTMLCREF    (ENCODE_HTMLCREF|ENCODE_LEAVE_SRC)
114 #define  ENCODE_FB_XMLCREF     (ENCODE_XMLCREF|ENCODE_LEAVE_SRC)
115
116 #define encode_ckWARN(c, w) ((c & ENCODE_WARN_ON_ERR)                         \
117                         && (!(c & ENCODE_ONLY_PRAGMA_WARNINGS) || ckWARN(w)))
118
119 #ifdef UTF8SKIP
120 #  ifdef EBCDIC   /* The value on early perls is wrong */
121 #    undef UTF8_MAXBYTES 
122 #    define UTF8_MAXBYTES 14
123 #  endif
124 #  ifndef UNLIKELY
125 #    define UNLIKELY(x) (x)
126 #  endif
127 #  ifndef LIKELY
128 #    define LIKELY(x) (x)
129 #  endif
130
131 /* EBCDIC requires a later perl to work, so the next two definitions are for
132  * ASCII machines only */
133 #  ifndef NATIVE_UTF8_TO_I8
134 #    define NATIVE_UTF8_TO_I8(x) (x)
135 #  endif
136 #  ifndef I8_TO_NATIVE_UTF8
137 #    define I8_TO_NATIVE_UTF8(x)  (x)
138 #  endif
139 #  ifndef OFFUNISKIP
140 #    define OFFUNISKIP(x)  UNISKIP(x)
141 #  endif
142 #  ifndef uvoffuni_to_utf8_flags
143 #    define uvoffuni_to_utf8_flags(a,b,c) uvuni_to_utf8_flags(a,b,c)
144 #  endif
145 #  ifndef WARN_SURROGATE    /* Use the overarching category if these
146                                subcategories are missing */
147 #    define WARN_SURROGATE WARN_UTF8
148 #    define WARN_NONCHAR WARN_UTF8
149 #    define WARN_NON_UNICODE WARN_UTF8
150      /* If there's only one possible category, then packing is a no-op */
151 #    define encode_ckWARN_packed(c, w) encode_ckWARN(c, w)
152 #  else
153 #    define encode_ckWARN_packed(c, w)                                      \
154             ((c & ENCODE_WARN_ON_ERR)                                       \
155         && (!(c & ENCODE_ONLY_PRAGMA_WARNINGS) || Perl_ckwarn(aTHX_ w)))
156 #  endif
157
158 /* All these formats take a single UV code point argument */
159 static const char surrogate_cp_format[] = "UTF-16 surrogate U+%04" UVXf;
160 static const char nonchar_cp_format[]   = "Unicode non-character U+%04" UVXf
161                                    " is not recommended for open interchange";
162 static const char super_cp_format[]     = "Code point 0x%" UVXf " is not Unicode,"
163                                    " may not be portable";
164
165 /* If the perl doesn't have the 5.28 functions, this file includes
166  * stripped-down versions of them but containing enough functionality to be
167  * suitable for Encode's needs.  Many of the comments have been removed.  But
168  * you can inspect the 5.28 source if you get stuck.
169  *
170  * These could be put in Devel::PPPort, but Encode is likely the only user */
171
172 #if    (defined(IN_ENCODE_XS) || defined(IN_UNICODE_XS))                     \
173   && (! defined(utf8n_to_uvchr_msgs) && ! defined(uvchr_to_utf8_flags_msgs))
174
175 #  ifndef hv_stores
176 #    define hv_stores(hv, key, val) hv_store((hv), ("" key ""), (sizeof(key)-1), (val), 0)
177 #  endif
178
179 static HV *
180 S_new_msg_hv(const char * const message, /* The message text */
181                    U32 categories)  /* Packed warning categories */
182 {
183     /* Creates, populates, and returns an HV* that describes an error message
184      * for the translators between UTF8 and code point */
185
186     dTHX;
187     SV* msg_sv = newSVpv(message, 0);
188     SV* category_sv = newSVuv(categories);
189
190     HV* msg_hv = newHV();
191
192     (void) hv_stores(msg_hv, "text", msg_sv);
193     (void) hv_stores(msg_hv, "warn_categories",  category_sv);
194
195     return msg_hv;
196 }
197
198 #endif
199
200 #if ! defined(utf8n_to_uvchr_msgs)                      \
201   && (defined(IN_ENCODE_XS) || defined(IN_UNICODE_XS))
202
203 #  undef utf8n_to_uvchr     /* Don't use an earlier version: use the version
204                                defined in this file */
205 #  define utf8n_to_uvchr(a,b,c,d) utf8n_to_uvchr_msgs(a, b, c, d, 0, NULL)
206
207 #  undef UTF8_IS_START      /* Early perls wrongly accepted C0 and C1 */
208 #  define UTF8_IS_START(c)  (((U8)(c)) >= 0xc2)
209 #  ifndef isUTF8_POSSIBLY_PROBLEMATIC
210 #    ifdef EBCDIC
211 #      define isUTF8_POSSIBLY_PROBLEMATIC(c) ((U8) c > ' ')
212 #    else
213 #      define isUTF8_POSSIBLY_PROBLEMATIC(c) ((U8) c >= 0xED)
214 #    endif
215 #  endif
216 #  ifndef UTF8_ALLOW_OVERFLOW
217 #    define UTF8_ALLOW_OVERFLOW (1U<<31)    /* Choose highest bit to avoid
218                                                potential conflicts */
219 #    define UTF8_GOT_OVERFLOW           UTF8_ALLOW_OVERFLOW
220 #  endif
221 #  undef UTF8_ALLOW_ANY     /* Early perl definitions don't work properly with
222                                the code in this file */
223 #  define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION                              \
224                           |UTF8_ALLOW_NON_CONTINUATION                          \
225                           |UTF8_ALLOW_SHORT                                     \
226                           |UTF8_ALLOW_LONG                                      \
227                           |UTF8_ALLOW_OVERFLOW)
228
229 /* The meanings of these were complemented at some point, but the functions
230  * bundled in this file use the complemented meanings */
231 #  ifndef UTF8_DISALLOW_SURROGATE
232 #    define UTF8_DISALLOW_SURROGATE     UTF8_ALLOW_SURROGATE
233 #    define UTF8_DISALLOW_NONCHAR       UTF8_ALLOW_FFFF
234 #    define UTF8_DISALLOW_SUPER         UTF8_ALLOW_FE_FF
235
236      /* In the stripped-down implementation in this file, disallowing is not
237       * independent of warning */
238 #    define UTF8_WARN_SURROGATE     UTF8_DISALLOW_SURROGATE
239 #    define UTF8_WARN_NONCHAR       UTF8_DISALLOW_NONCHAR
240 #    define UTF8_WARN_SUPER         UTF8_DISALLOW_SUPER
241 #  endif
242 #  ifndef UTF8_DISALLOW_ILLEGAL_INTERCHANGE
243 #    define UTF8_DISALLOW_ILLEGAL_INTERCHANGE                                   \
244      (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_SURROGATE|UTF8_DISALLOW_NONCHAR)
245 #  endif
246 #  ifndef UTF8_WARN_ILLEGAL_INTERCHANGE
247 #    define UTF8_WARN_ILLEGAL_INTERCHANGE                                       \
248          (UTF8_WARN_SUPER|UTF8_WARN_SURROGATE|UTF8_WARN_NONCHAR)
249 #  endif
250 #  ifndef FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER
251 #    ifdef EBCDIC   /* On EBCDIC, these are actually I8 bytes */
252 #      define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER  0xFA
253 #      define IS_UTF8_2_BYTE_SUPER(s0, s1) ((s0) == 0xF9 && (s1) >= 0xA2)
254
255 #      define IS_UTF8_2_BYTE_SURROGATE(s0, s1)     ((s0) == 0xF1            \
256                                               && ((s1) & 0xFE ) == 0xB6)
257 #    else
258 #      define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER  0xF5
259 #      define IS_UTF8_2_BYTE_SUPER(s0, s1)       ((s0) == 0xF4 && (s1) >= 0x90)
260 #      define IS_UTF8_2_BYTE_SURROGATE(s0, s1)   ((s0) == 0xED && (s1) >= 0xA0)
261 #    endif
262 #    if defined(UV_IS_QUAD) /* These assume IV_MAX is 2**63-1 */
263 #      ifdef EBCDIC     /* Actually is I8 */
264 #       define HIGHEST_REPRESENTABLE_UTF8                                       \
265                 "\xFF\xA7\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
266 #      else
267 #       define HIGHEST_REPRESENTABLE_UTF8                                       \
268                 "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
269 #      endif
270 #    endif
271 #  endif
272
273 #  ifndef Newx
274 #    define Newx(v,n,t) New(0,v,n,t)
275 #  endif
276
277 #  ifndef PERL_UNUSED_ARG
278 #    define PERL_UNUSED_ARG(x) ((void)x)
279 #  endif
280
281 static const char malformed_text[] = "Malformed UTF-8 character";
282
283 static char *
284 _byte_dump_string(const U8 * const start, const STRLEN len)
285 {
286     /* Returns a mortalized C string that is a displayable copy of the 'len' */
287
288     const STRLEN output_len = 4 * len + 1;  /* 4 bytes per each input, plus a
289                                                trailing NUL */
290     const U8 * s = start;
291     const U8 * const e = start + len;
292     char * output;
293     char * d;
294     dTHX;
295
296     Newx(output, output_len, char);
297     SAVEFREEPV(output);
298
299     d = output;
300     for (s = start; s < e; s++) {
301         const unsigned high_nibble = (*s & 0xF0) >> 4;
302         const unsigned low_nibble =  (*s & 0x0F);
303
304         *d++ = '\\';
305         *d++ = 'x';
306
307         if (high_nibble < 10) {
308             *d++ = high_nibble + '0';
309         }
310         else {
311             *d++ = high_nibble - 10 + 'a';
312         }
313
314         if (low_nibble < 10) {
315             *d++ = low_nibble + '0';
316         }
317         else {
318             *d++ = low_nibble - 10 + 'a';
319         }
320     }
321
322     *d = '\0';
323     return output;
324 }
325
326 static char *
327 S_unexpected_non_continuation_text(const U8 * const s,
328
329                                          /* Max number of bytes to print */
330                                          STRLEN print_len,
331
332                                          /* Which one is the non-continuation */
333                                          const STRLEN non_cont_byte_pos,
334
335                                          /* How many bytes should there be? */
336                                          const STRLEN expect_len)
337 {
338     /* Return the malformation warning text for an unexpected continuation
339      * byte. */
340
341     dTHX;
342     const char * const where = (non_cont_byte_pos == 1)
343                                ? "immediately"
344                                : Perl_form(aTHX_ "%d bytes",
345                                                  (int) non_cont_byte_pos);
346     const U8 * x = s + non_cont_byte_pos;
347     const U8 * e = s + print_len;
348
349     /* We don't need to pass this parameter, but since it has already been
350      * calculated, it's likely faster to pass it; verify under DEBUGGING */
351     assert(expect_len == UTF8SKIP(s));
352
353     /* As a defensive coding measure, don't output anything past a NUL.  Such
354      * bytes shouldn't be in the middle of a malformation, and could mark the
355      * end of the allocated string, and what comes after is undefined */
356     for (; x < e; x++) {
357         if (*x == '\0') {
358             x++;            /* Output this particular NUL */
359             break;
360         }
361     }
362
363     return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x,"
364                            " %s after start byte 0x%02x; need %d bytes, got %d)",
365                            malformed_text,
366                            _byte_dump_string(s, x - s),
367                            *(s + non_cont_byte_pos),
368                            where,
369                            *s,
370                            (int) expect_len,
371                            (int) non_cont_byte_pos);
372 }
373
374 static int
375 S_does_utf8_overflow(const U8 * const s,
376                        const U8 * e,
377                        const bool consider_overlongs)
378 {
379     /* Returns an int indicating whether or not the UTF-8 sequence from 's' to
380      * 'e' - 1 would overflow an IV on this platform. */
381
382 #  if ! defined(UV_IS_QUAD)
383
384     const STRLEN len = e - s;
385     int is_overlong;
386
387     assert(s <= e && s + UTF8SKIP(s) >= e);
388     assert(! UTF8_IS_INVARIANT(*s) && e > s);
389
390 #    ifdef EBCDIC
391
392     PERL_UNUSED_ARG(consider_overlongs);
393
394     if (*s != 0xFE) {
395         return 0;
396     }
397
398     if (len == 1) {
399         return -1;
400     }
401
402 #    else
403
404     if (LIKELY(*s < 0xFE)) {
405         return 0;
406     }
407
408     if (! consider_overlongs) {
409         return 1;
410     }
411
412     if (len == 1) {
413         return -1;
414     }
415
416     is_overlong = S_is_utf8_overlong_given_start_byte_ok(s, len);
417
418     if (is_overlong == 0) {
419         return 1;
420     }
421
422     if (is_overlong < 0) {
423         return -1;
424     }
425
426     if (*s == 0xFE) {
427         return 0;
428     }
429
430 #    endif
431
432     /* Here, ASCII and EBCDIC rejoin:
433     *  On ASCII:   We have an overlong sequence starting with FF
434     *  On EBCDIC:  We have a sequence starting with FE. */
435
436     {   /* For C89, use a block so the declaration can be close to its use */
437
438 #    ifdef EBCDIC
439         const U8 conts_for_highest_30_bit[] = "\x41\x41\x41\x41\x41\x41\x42";
440 #    else
441         const U8 conts_for_highest_30_bit[] = "\x80\x80\x80\x80\x80\x80\x81";
442 #    endif
443         const STRLEN conts_len = sizeof(conts_for_highest_30_bit) - 1;
444         const STRLEN cmp_len = MIN(conts_len, len - 1);
445
446         if (cmp_len >= conts_len || memNE(s + 1,
447                                           conts_for_highest_30_bit,
448                                           cmp_len))
449         {
450             return memGT(s + 1, conts_for_highest_30_bit, cmp_len);
451         }
452
453         return -1;
454     }
455
456 #  else /* Below is 64-bit word */
457
458     PERL_UNUSED_ARG(consider_overlongs);
459
460     {
461         const STRLEN len = e - s;
462         const U8 *x;
463         const U8 * y = (const U8 *) HIGHEST_REPRESENTABLE_UTF8;
464
465         for (x = s; x < e; x++, y++) {
466
467             if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) == *y)) {
468                 continue;
469             }
470             return NATIVE_UTF8_TO_I8(*x) > *y;
471         }
472
473         if (len < sizeof(HIGHEST_REPRESENTABLE_UTF8) - 1) {
474             return -1;
475         }
476
477         return 0;
478     }
479
480 #  endif
481
482 }
483
484 static int
485 S_isFF_OVERLONG(const U8 * const s, const STRLEN len);
486
487 static int
488 S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len)
489 {
490     const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
491     const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
492
493     assert(len > 1 && UTF8_IS_START(*s));
494
495 #         ifdef EBCDIC
496 #             define F0_ABOVE_OVERLONG 0xB0
497 #             define F8_ABOVE_OVERLONG 0xA8
498 #             define FC_ABOVE_OVERLONG 0xA4
499 #             define FE_ABOVE_OVERLONG 0xA2
500 #             define FF_OVERLONG_PREFIX "\xfe\x41\x41\x41\x41\x41\x41\x41"
501 #         else
502
503     if (s0 == 0xE0 && UNLIKELY(s1 < 0xA0)) {
504         return 1;
505     }
506
507 #             define F0_ABOVE_OVERLONG 0x90
508 #             define F8_ABOVE_OVERLONG 0x88
509 #             define FC_ABOVE_OVERLONG 0x84
510 #             define FE_ABOVE_OVERLONG 0x82
511 #             define FF_OVERLONG_PREFIX "\xff\x80\x80\x80\x80\x80\x80"
512 #         endif
513
514     if (   (s0 == 0xF0 && UNLIKELY(s1 < F0_ABOVE_OVERLONG))
515         || (s0 == 0xF8 && UNLIKELY(s1 < F8_ABOVE_OVERLONG))
516         || (s0 == 0xFC && UNLIKELY(s1 < FC_ABOVE_OVERLONG))
517         || (s0 == 0xFE && UNLIKELY(s1 < FE_ABOVE_OVERLONG)))
518     {
519         return 1;
520     }
521
522     /* Check for the FF overlong */
523     return S_isFF_OVERLONG(s, len);
524 }
525
526 int
527 S_isFF_OVERLONG(const U8 * const s, const STRLEN len)
528 {
529     if (LIKELY(memNE(s, FF_OVERLONG_PREFIX,
530                      MIN(len, sizeof(FF_OVERLONG_PREFIX) - 1))))
531     {
532         return 0;
533     }
534
535     if (len >= sizeof(FF_OVERLONG_PREFIX) - 1) {
536         return 1;
537     }
538
539     return -1;
540 }
541
542 #  ifndef UTF8_GOT_CONTINUATION
543 #    define UTF8_GOT_CONTINUATION       UTF8_ALLOW_CONTINUATION
544 #    define UTF8_GOT_EMPTY              UTF8_ALLOW_EMPTY
545 #    define UTF8_GOT_LONG               UTF8_ALLOW_LONG
546 #    define UTF8_GOT_NON_CONTINUATION   UTF8_ALLOW_NON_CONTINUATION
547 #    define UTF8_GOT_SHORT              UTF8_ALLOW_SHORT
548 #    define UTF8_GOT_SURROGATE          UTF8_DISALLOW_SURROGATE
549 #    define UTF8_GOT_NONCHAR            UTF8_DISALLOW_NONCHAR
550 #    define UTF8_GOT_SUPER              UTF8_DISALLOW_SUPER
551 #  endif
552
553 #  ifndef UNICODE_IS_SUPER
554 #    define UNICODE_IS_SUPER(uv)    ((UV) (uv) > PERL_UNICODE_MAX)
555 #  endif
556 #  ifndef UNICODE_IS_32_CONTIGUOUS_NONCHARS
557 #    define UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv)      ((UV) (uv) >= 0xFDD0   \
558                                                    && (UV) (uv) <= 0xFDEF)
559 #  endif
560 #  ifndef UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER
561 #    define UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv)                  \
562                                           (((UV) (uv) & 0xFFFE) == 0xFFFE)
563 #  endif
564 #  ifndef is_NONCHAR_utf8_safe
565 #    define is_NONCHAR_utf8_safe(s,e)     /*** GENERATED CODE ***/            \
566 ( ( ( LIKELY((e) > (s)) ) && ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ) ? ( ( 0xEF == ((const U8*)s)[0] ) ?\
567             ( ( 0xB7 == ((const U8*)s)[1] ) ?                               \
568                 ( ( 0x90 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0xAF ) ? 3 : 0 )\
569             : ( ( 0xBF == ((const U8*)s)[1] ) && ( ( ((const U8*)s)[2] & 0xFE ) == 0xBE ) ) ? 3 : 0 )\
570         : ( 0xF0 == ((const U8*)s)[0] ) ?                                   \
571             ( ( ( ( ((const U8*)s)[1] == 0x9F || ( ( ((const U8*)s)[1] & 0xEF ) == 0xAF ) ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 )\
572         : ( 0xF1 <= ((const U8*)s)[0] && ((const U8*)s)[0] <= 0xF3 ) ?      \
573             ( ( ( ( ( ((const U8*)s)[1] & 0xCF ) == 0x8F ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 )\
574         : ( ( ( ( 0xF4 == ((const U8*)s)[0] ) && ( 0x8F == ((const U8*)s)[1] ) ) && ( 0xBF == ((const U8*)s)[2] ) ) && ( ( ((const U8*)s)[3] & 0xFE ) == 0xBE ) ) ? 4 : 0 ) : 0 )
575 #  endif
576
577 #  ifndef UTF8_IS_NONCHAR
578 #    define UTF8_IS_NONCHAR(s, e) (is_NONCHAR_utf8_safe(s,e) > 0)
579 #  endif
580 #  ifndef UNICODE_IS_NONCHAR
581 #    define UNICODE_IS_NONCHAR(uv)                                    \
582     (   UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv)                       \
583      || (   LIKELY( ! UNICODE_IS_SUPER(uv))                         \
584          && UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv)))
585 #  endif
586
587 #  ifndef UTF8_MAXBYTES
588 #    define UTF8_MAXBYTES UTF8_MAXLEN
589 #  endif
590
591 static UV
592 utf8n_to_uvchr_msgs(const U8 *s,
593                     STRLEN curlen,
594                     STRLEN *retlen,
595                     const U32 flags,
596                     U32 * errors,
597                     AV ** msgs)
598 {
599     const U8 * const s0 = s;
600     const U8 * send = NULL;
601     U32 possible_problems = 0;
602     UV uv = *s;
603     STRLEN expectlen   = 0;
604     U8 * adjusted_s0 = (U8 *) s0;
605     U8 temp_char_buf[UTF8_MAXBYTES + 1];
606     UV uv_so_far = 0;
607     dTHX;
608
609     assert(errors == NULL); /* This functionality has been stripped */
610
611     if (UNLIKELY(curlen == 0)) {
612         possible_problems |= UTF8_GOT_EMPTY;
613         curlen = 0;
614         uv = UNICODE_REPLACEMENT;
615         goto ready_to_handle_errors;
616     }
617
618     expectlen = UTF8SKIP(s);
619
620     if (retlen) {
621         *retlen = expectlen;
622     }
623
624     if (UTF8_IS_INVARIANT(uv)) {
625         return uv;
626     }
627
628     if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
629         possible_problems |= UTF8_GOT_CONTINUATION;
630         curlen = 1;
631         uv = UNICODE_REPLACEMENT;
632         goto ready_to_handle_errors;
633     }
634
635     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
636
637     send = (U8*) s0;
638     if (UNLIKELY(curlen < expectlen)) {
639         possible_problems |= UTF8_GOT_SHORT;
640         send += curlen;
641     }
642     else {
643         send += expectlen;
644     }
645
646     for (s = s0 + 1; s < send; s++) {
647         if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
648             uv = UTF8_ACCUMULATE(uv, *s);
649             continue;
650         }
651
652         possible_problems |= UTF8_GOT_NON_CONTINUATION;
653         break;
654     } /* End of loop through the character's bytes */
655
656     curlen = s - s0;
657
658 #     define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
659
660     if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
661         uv_so_far = uv;
662         uv = UNICODE_REPLACEMENT;
663     }
664
665     if (UNLIKELY(0 < S_does_utf8_overflow(s0, s, 1))) {
666         possible_problems |= UTF8_GOT_OVERFLOW;
667         uv = UNICODE_REPLACEMENT;
668     }
669
670     if (     (   LIKELY(! possible_problems)
671               && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv)))
672         || (       UNLIKELY(possible_problems)
673             && (   UNLIKELY(! UTF8_IS_START(*s0))
674                 || (   curlen > 1
675                     && UNLIKELY(0 < S_is_utf8_overlong_given_start_byte_ok(s0,
676                                                                 s - s0))))))
677     {
678         possible_problems |= UTF8_GOT_LONG;
679
680         if (   UNLIKELY(   possible_problems & UTF8_GOT_TOO_SHORT)
681             &&   LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW)))
682         {
683             UV min_uv = uv_so_far;
684             STRLEN i;
685
686             for (i = curlen; i < expectlen; i++) {
687                 min_uv = UTF8_ACCUMULATE(min_uv,
688                                      I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
689             }
690
691             adjusted_s0 = temp_char_buf;
692             (void) uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
693         }
694     }
695
696     /* Here, we have found all the possible problems, except for when the input
697      * is for a problematic code point not allowed by the input parameters. */
698
699                                 /* uv is valid for overlongs */
700     if (   (   (      LIKELY(! (possible_problems & ~UTF8_GOT_LONG))
701                    && uv >= UNICODE_SURROGATE_FIRST)
702             || (   UNLIKELY(possible_problems)
703                 && isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0)))
704         && ((flags & ( UTF8_DISALLOW_NONCHAR
705                       |UTF8_DISALLOW_SURROGATE
706                       |UTF8_DISALLOW_SUPER))))
707     {
708         if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) {
709             if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
710                 possible_problems |= UTF8_GOT_SURROGATE;
711             }
712             else if (UNLIKELY(uv > PERL_UNICODE_MAX)) {
713                 possible_problems |= UTF8_GOT_SUPER;
714             }
715             else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) {
716                 possible_problems |= UTF8_GOT_NONCHAR;
717             }
718         }
719         else {
720             if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0)
721                                 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
722             {
723                 possible_problems |= UTF8_GOT_SUPER;
724             }
725             else if (curlen > 1) {
726                 if (UNLIKELY(IS_UTF8_2_BYTE_SUPER(
727                                       NATIVE_UTF8_TO_I8(*adjusted_s0),
728                                       NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
729                 {
730                     possible_problems |= UTF8_GOT_SUPER;
731                 }
732                 else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(
733                                       NATIVE_UTF8_TO_I8(*adjusted_s0),
734                                       NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
735                 {
736                     possible_problems |= UTF8_GOT_SURROGATE;
737                 }
738             }
739         }
740     }
741
742   ready_to_handle_errors:
743
744     if (UNLIKELY(possible_problems)) {
745         bool disallowed = FALSE;
746         const U32 orig_problems = possible_problems;
747
748         if (msgs) {
749             *msgs = NULL;
750         }
751
752         while (possible_problems) { /* Handle each possible problem */
753             UV pack_warn = 0;
754             char * message = NULL;
755             U32 this_flag_bit = 0;
756
757             /* Each 'if' clause handles one problem.  They are ordered so that
758              * the first ones' messages will be displayed before the later
759              * ones; this is kinda in decreasing severity order.  But the
760              * overlong must come last, as it changes 'uv' looked at by the
761              * others */
762             if (possible_problems & UTF8_GOT_OVERFLOW) {
763
764                 /* Overflow means also got a super; we handle both here */
765                 possible_problems
766                   &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER);
767
768                 /* Disallow if any of the categories say to */
769                 if ( ! (flags &  UTF8_ALLOW_OVERFLOW)
770                     || (flags &  UTF8_DISALLOW_SUPER))
771                 {
772                     disallowed = TRUE;
773                 }
774
775                 /* Likewise, warn if any say to */
776                 if (  ! (flags & UTF8_ALLOW_OVERFLOW)) {
777
778                     /* The warnings code explicitly says it doesn't handle the
779                      * case of packWARN2 and two categories which have
780                      * parent-child relationship.  Even if it works now to
781                      * raise the warning if either is enabled, it wouldn't
782                      * necessarily do so in the future.  We output (only) the
783                      * most dire warning */
784                     if (! (flags & UTF8_CHECK_ONLY)) {
785                         if (msgs || ckWARN_d(WARN_UTF8)) {
786                             pack_warn = packWARN(WARN_UTF8);
787                         }
788                         else if (msgs || ckWARN_d(WARN_NON_UNICODE)) {
789                             pack_warn = packWARN(WARN_NON_UNICODE);
790                         }
791                         if (pack_warn) {
792                             message = Perl_form(aTHX_ "%s: %s (overflows)",
793                                             malformed_text,
794                                             _byte_dump_string(s0, curlen));
795                             this_flag_bit = UTF8_GOT_OVERFLOW;
796                         }
797                     }
798                 }
799             }
800             else if (possible_problems & UTF8_GOT_EMPTY) {
801                 possible_problems &= ~UTF8_GOT_EMPTY;
802
803                 if (! (flags & UTF8_ALLOW_EMPTY)) {
804                     disallowed = TRUE;
805                     if (  (msgs
806                         || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
807                     {
808                         pack_warn = packWARN(WARN_UTF8);
809                         message = Perl_form(aTHX_ "%s (empty string)",
810                                                    malformed_text);
811                         this_flag_bit = UTF8_GOT_EMPTY;
812                     }
813                 }
814             }
815             else if (possible_problems & UTF8_GOT_CONTINUATION) {
816                 possible_problems &= ~UTF8_GOT_CONTINUATION;
817
818                 if (! (flags & UTF8_ALLOW_CONTINUATION)) {
819                     disallowed = TRUE;
820                     if ((   msgs
821                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
822                     {
823                         pack_warn = packWARN(WARN_UTF8);
824                         message = Perl_form(aTHX_
825                                 "%s: %s (unexpected continuation byte 0x%02x,"
826                                 " with no preceding start byte)",
827                                 malformed_text,
828                                 _byte_dump_string(s0, 1), *s0);
829                         this_flag_bit = UTF8_GOT_CONTINUATION;
830                     }
831                 }
832             }
833             else if (possible_problems & UTF8_GOT_SHORT) {
834                 possible_problems &= ~UTF8_GOT_SHORT;
835
836                 if (! (flags & UTF8_ALLOW_SHORT)) {
837                     disallowed = TRUE;
838                     if ((   msgs
839                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
840                     {
841                         pack_warn = packWARN(WARN_UTF8);
842                         message = Perl_form(aTHX_
843                              "%s: %s (too short; %d byte%s available, need %d)",
844                              malformed_text,
845                              _byte_dump_string(s0, send - s0),
846                              (int)curlen,
847                              curlen == 1 ? "" : "s",
848                              (int)expectlen);
849                         this_flag_bit = UTF8_GOT_SHORT;
850                     }
851                 }
852
853             }
854             else if (possible_problems & UTF8_GOT_NON_CONTINUATION) {
855                 possible_problems &= ~UTF8_GOT_NON_CONTINUATION;
856
857                 if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) {
858                     disallowed = TRUE;
859                     if ((   msgs
860                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
861                     {
862                         int printlen = s - s0;
863                         pack_warn = packWARN(WARN_UTF8);
864                         message = Perl_form(aTHX_ "%s",
865                             S_unexpected_non_continuation_text(s0,
866                                                             printlen,
867                                                             s - s0,
868                                                             (int) expectlen));
869                         this_flag_bit = UTF8_GOT_NON_CONTINUATION;
870                     }
871                 }
872             }
873             else if (possible_problems & UTF8_GOT_SURROGATE) {
874                 possible_problems &= ~UTF8_GOT_SURROGATE;
875
876                 if (flags & UTF8_WARN_SURROGATE) {
877
878                     if (   ! (flags & UTF8_CHECK_ONLY)
879                         && (msgs || ckWARN_d(WARN_SURROGATE)))
880                     {
881                         pack_warn = packWARN(WARN_SURROGATE);
882
883                         /* These are the only errors that can occur with a
884                         * surrogate when the 'uv' isn't valid */
885                         if (orig_problems & UTF8_GOT_TOO_SHORT) {
886                             message = Perl_form(aTHX_
887                                     "UTF-16 surrogate (any UTF-8 sequence that"
888                                     " starts with \"%s\" is for a surrogate)",
889                                     _byte_dump_string(s0, curlen));
890                         }
891                         else {
892                             message = Perl_form(aTHX_ surrogate_cp_format, uv);
893                         }
894                         this_flag_bit = UTF8_GOT_SURROGATE;
895                     }
896                 }
897
898                 if (flags & UTF8_DISALLOW_SURROGATE) {
899                     disallowed = TRUE;
900                 }
901             }
902             else if (possible_problems & UTF8_GOT_SUPER) {
903                 possible_problems &= ~UTF8_GOT_SUPER;
904
905                 if (flags & UTF8_WARN_SUPER) {
906
907                     if (   ! (flags & UTF8_CHECK_ONLY)
908                         && (msgs || ckWARN_d(WARN_NON_UNICODE)))
909                     {
910                         pack_warn = packWARN(WARN_NON_UNICODE);
911
912                         if (orig_problems & UTF8_GOT_TOO_SHORT) {
913                             message = Perl_form(aTHX_
914                                     "Any UTF-8 sequence that starts with"
915                                     " \"%s\" is for a non-Unicode code point,"
916                                     " may not be portable",
917                                     _byte_dump_string(s0, curlen));
918                         }
919                         else {
920                             message = Perl_form(aTHX_ super_cp_format, uv);
921                         }
922                         this_flag_bit = UTF8_GOT_SUPER;
923                     }
924                 }
925
926                 if (flags & UTF8_DISALLOW_SUPER) {
927                     disallowed = TRUE;
928                 }
929             }
930             else if (possible_problems & UTF8_GOT_NONCHAR) {
931                 possible_problems &= ~UTF8_GOT_NONCHAR;
932
933                 if (flags & UTF8_WARN_NONCHAR) {
934
935                     if (  ! (flags & UTF8_CHECK_ONLY)
936                         && (msgs || ckWARN_d(WARN_NONCHAR)))
937                     {
938                         /* The code above should have guaranteed that we don't
939                          * get here with errors other than overlong */
940                         assert (! (orig_problems
941                                         & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR)));
942
943                         pack_warn = packWARN(WARN_NONCHAR);
944                         message = Perl_form(aTHX_ nonchar_cp_format, uv);
945                         this_flag_bit = UTF8_GOT_NONCHAR;
946                     }
947                 }
948
949                 if (flags & UTF8_DISALLOW_NONCHAR) {
950                     disallowed = TRUE;
951                 }
952             }
953             else if (possible_problems & UTF8_GOT_LONG) {
954                 possible_problems &= ~UTF8_GOT_LONG;
955
956                 if (flags & UTF8_ALLOW_LONG) {
957                     uv = UNICODE_REPLACEMENT;
958                 }
959                 else {
960                     disallowed = TRUE;
961
962                     if ((   msgs
963                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
964                     {
965                         pack_warn = packWARN(WARN_UTF8);
966
967                         /* These error types cause 'uv' to be something that
968                          * isn't what was intended, so can't use it in the
969                          * message.  The other error types either can't
970                          * generate an overlong, or else the 'uv' is valid */
971                         if (orig_problems &
972                                         (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
973                         {
974                             message = Perl_form(aTHX_
975                                     "%s: %s (any UTF-8 sequence that starts"
976                                     " with \"%s\" is overlong which can and"
977                                     " should be represented with a"
978                                     " different, shorter sequence)",
979                                     malformed_text,
980                                     _byte_dump_string(s0, send - s0),
981                                     _byte_dump_string(s0, curlen));
982                         }
983                         else {
984                             U8 tmpbuf[UTF8_MAXBYTES+1];
985                             const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf,
986                                                                         uv, 0);
987                             /* Don't use U+ for non-Unicode code points, which
988                              * includes those in the Latin1 range */
989                             const char * preface = (    uv > PERL_UNICODE_MAX
990 #  ifdef EBCDIC
991                                                      || uv <= 0xFF
992 #  endif
993                                                     )
994                                                    ? "0x"
995                                                    : "U+";
996                             message = Perl_form(aTHX_
997                                 "%s: %s (overlong; instead use %s to represent"
998                                 " %s%0*" UVXf ")",
999                                 malformed_text,
1000                                 _byte_dump_string(s0, send - s0),
1001                                 _byte_dump_string(tmpbuf, e - tmpbuf),
1002                                 preface,
1003                                 ((uv < 256) ? 2 : 4), /* Field width of 2 for
1004                                                          small code points */
1005                                 UNI_TO_NATIVE(uv));
1006                         }
1007                         this_flag_bit = UTF8_GOT_LONG;
1008                     }
1009                 }
1010             } /* End of looking through the possible flags */
1011
1012             /* Display the message (if any) for the problem being handled in
1013              * this iteration of the loop */
1014             if (message) {
1015                 if (msgs) {
1016                     assert(this_flag_bit);
1017
1018                     if (*msgs == NULL) {
1019                         *msgs = newAV();
1020                     }
1021
1022                     av_push(*msgs, newRV_noinc((SV*) S_new_msg_hv(message,
1023                                                                 pack_warn)));
1024                 }
1025                 else if (PL_op)
1026                     Perl_warner(aTHX_ pack_warn, "%s in %s", message,
1027                                                  OP_DESC(PL_op));
1028                 else
1029                     Perl_warner(aTHX_ pack_warn, "%s", message);
1030             }
1031         }   /* End of 'while (possible_problems)' */
1032
1033         if (retlen) {
1034             *retlen = curlen;
1035         }
1036
1037         if (disallowed) {
1038             if (flags & UTF8_CHECK_ONLY && retlen) {
1039                 *retlen = ((STRLEN) -1);
1040             }
1041             return 0;
1042         }
1043     }
1044
1045     return UNI_TO_NATIVE(uv);
1046 }
1047
1048 static STRLEN
1049 S_is_utf8_char_helper(const U8 * const s, const U8 * e, const U32 flags)
1050 {
1051     STRLEN len;
1052     const U8 *x;
1053
1054     assert(0 == (flags & ~UTF8_DISALLOW_ILLEGAL_INTERCHANGE));
1055     assert(! UTF8_IS_INVARIANT(*s));
1056
1057     if (UNLIKELY(! UTF8_IS_START(*s))) {
1058         return 0;
1059     }
1060
1061     /* Examine a maximum of a single whole code point */
1062     if (e - s > UTF8SKIP(s)) {
1063         e = s + UTF8SKIP(s);
1064     }
1065
1066     len = e - s;
1067
1068     if (flags && isUTF8_POSSIBLY_PROBLEMATIC(*s)) {
1069         const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
1070
1071         if (  (flags & UTF8_DISALLOW_SUPER)
1072             && UNLIKELY(s0 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
1073         {
1074             return 0;           /* Above Unicode */
1075         }
1076
1077         if (len > 1) {
1078             const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
1079
1080             if (   (flags & UTF8_DISALLOW_SUPER)
1081                 &&  UNLIKELY(IS_UTF8_2_BYTE_SUPER(s0, s1)))
1082             {
1083                 return 0;       /* Above Unicode */
1084             }
1085
1086             if (   (flags & UTF8_DISALLOW_SURROGATE)
1087                 &&  UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(s0, s1)))
1088             {
1089                 return 0;       /* Surrogate */
1090             }
1091
1092             if (  (flags & UTF8_DISALLOW_NONCHAR)
1093                 && UNLIKELY(UTF8_IS_NONCHAR(s, e)))
1094             {
1095                 return 0;       /* Noncharacter code point */
1096             }
1097         }
1098     }
1099
1100     for (x = s + 1; x < e; x++) {
1101         if (UNLIKELY(! UTF8_IS_CONTINUATION(*x))) {
1102             return 0;
1103         }
1104     }
1105
1106     if (len > 1 && S_is_utf8_overlong_given_start_byte_ok(s, len) > 0) {
1107         return 0;
1108     }
1109
1110     if (0 < S_does_utf8_overflow(s, e, 0)) {
1111         return 0;
1112     }
1113
1114     return UTF8SKIP(s);
1115 }
1116
1117 #  undef is_utf8_valid_partial_char_flags
1118
1119 static bool
1120 is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1121 {
1122
1123     return S_is_utf8_char_helper(s, e, flags) > 0;
1124 }
1125
1126 #  undef is_utf8_string_loc_flags
1127
1128 static bool
1129 is_utf8_string_loc_flags(const U8 *s, STRLEN len, const U8 **ep, const U32 flags)
1130 {
1131     const U8* send = s + len;
1132
1133     assert(0 == (flags & ~UTF8_DISALLOW_ILLEGAL_INTERCHANGE));
1134
1135     while (s < send) {
1136         if (UTF8_IS_INVARIANT(*s)) {
1137             s++;
1138         }
1139         else if (     UNLIKELY(send - s < UTF8SKIP(s))
1140                  || ! S_is_utf8_char_helper(s, send, flags))
1141         {
1142             *ep = s;
1143             return 0;
1144         }
1145         else {
1146             s += UTF8SKIP(s);
1147         }
1148     }
1149
1150     *ep = send;
1151
1152     return 1;
1153 }
1154
1155 #endif
1156
1157 #if defined(IN_UNICODE_XS) && ! defined(uvchr_to_utf8_flags_msgs)
1158
1159 #  define MY_SHIFT   UTF_ACCUMULATION_SHIFT
1160 #  define MY_MARK    UTF_CONTINUATION_MARK
1161 #  define MY_MASK    UTF_CONTINUATION_MASK
1162
1163 static const char cp_above_legal_max[] =
1164                         "Use of code point 0x%" UVXf " is not allowed; the"
1165                         " permissible max is 0x%" UVXf;
1166
1167 /* These two can be dummys, as they are not looked at by the function, which
1168  * has hard-coded into it what flags it is expecting are */
1169 #  ifndef UNICODE_DISALLOW_ILLEGAL_INTERCHANGE
1170 #    define UNICODE_DISALLOW_ILLEGAL_INTERCHANGE 0
1171 #  endif
1172 #  ifndef UNICODE_WARN_ILLEGAL_INTERCHANGE
1173 #    define UNICODE_WARN_ILLEGAL_INTERCHANGE 0
1174 #  endif
1175
1176 #  ifndef OFFUNI_IS_INVARIANT
1177 #    define OFFUNI_IS_INVARIANT(cp) UNI_IS_INVARIANT(cp)
1178 #  endif
1179 #  ifndef MAX_EXTERNALLY_LEGAL_CP
1180 #    define MAX_EXTERNALLY_LEGAL_CP ((UV) (IV_MAX))
1181 #  endif
1182 #  ifndef LATIN1_TO_NATIVE
1183 #    define LATIN1_TO_NATIVE(a) ASCII_TO_NATIVE(a)
1184 #  endif
1185 #  ifndef I8_TO_NATIVE_UTF8
1186 #    define I8_TO_NATIVE_UTF8(a) NATIVE_TO_UTF(a)
1187 #  endif
1188 #  ifndef MAX_UTF8_TWO_BYTE
1189 #    define MAX_UTF8_TWO_BYTE (32 * (1U << UTF_ACCUMULATION_SHIFT) - 1)
1190 #  endif
1191 #  ifndef UNICODE_IS_32_CONTIGUOUS_NONCHARS
1192 #    define UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv)    ((UV) (uv) >= 0xFDD0   \
1193                                                  && (UV) (uv) <= 0xFDEF)
1194 #  endif
1195 #  ifndef UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER
1196 #    define UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv)                \
1197                                           (((UV) (uv) & 0xFFFE) == 0xFFFE)
1198 #  endif
1199 #  ifndef UNICODE_IS_SUPER
1200 #    define UNICODE_IS_SUPER(uv)    ((UV) (uv) > PERL_UNICODE_MAX)
1201 #  endif
1202 #  ifndef OFFUNISKIP
1203 #    define OFFUNISKIP(cp)    UNISKIP(NATIVE_TO_UNI(cp))
1204 #  endif
1205
1206 #  define HANDLE_UNICODE_SURROGATE(uv, flags, msgs)                 \
1207     STMT_START {                                                    \
1208         U32 category = packWARN(WARN_SURROGATE);                    \
1209         const char * format = surrogate_cp_format;                  \
1210         *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv),           \
1211                                  category);                         \
1212         return NULL;                                                \
1213     } STMT_END;
1214
1215 #  define HANDLE_UNICODE_NONCHAR(uv, flags, msgs)                   \
1216     STMT_START {                                                    \
1217         U32 category = packWARN(WARN_NONCHAR);                      \
1218         const char * format = nonchar_cp_format;                    \
1219         *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv),           \
1220                                  category);                         \
1221         return NULL;                                                \
1222     } STMT_END;
1223
1224 static U8 *
1225 uvchr_to_utf8_flags_msgs(U8 *d, UV uv, const UV flags, HV** msgs)
1226 {
1227     dTHX;
1228
1229     assert(msgs);
1230
1231     PERL_UNUSED_ARG(flags);
1232
1233     uv = NATIVE_TO_UNI(uv);
1234
1235     *msgs = NULL;
1236
1237     if (OFFUNI_IS_INVARIANT(uv)) {
1238         *d++ = LATIN1_TO_NATIVE(uv);
1239         return d;
1240     }
1241
1242     if (uv <= MAX_UTF8_TWO_BYTE) {
1243         *d++ = I8_TO_NATIVE_UTF8(( uv >> MY_SHIFT) | UTF_START_MARK(2));
1244         *d++ = I8_TO_NATIVE_UTF8(( uv   & MY_MASK) | MY_MARK);
1245         return d;
1246     }
1247
1248     /* Not 2-byte; test for and handle 3-byte result.   In the test immediately
1249      * below, the 16 is for start bytes E0-EF (which are all the possible ones
1250      * for 3 byte characters).  The 2 is for 2 continuation bytes; these each
1251      * contribute MY_SHIFT bits.  This yields 0x4000 on EBCDIC platforms, 0x1_0000
1252      * on ASCII; so 3 bytes covers the range 0x400-0x3FFF on EBCDIC;
1253      * 0x800-0xFFFF on ASCII */
1254     if (uv < (16 * (1U << (2 * MY_SHIFT)))) {
1255         *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * MY_SHIFT)) | UTF_START_MARK(3));
1256         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK);
1257         *d++ = I8_TO_NATIVE_UTF8(( uv  /* (1 - 1) */           & MY_MASK) | MY_MARK);
1258
1259 #ifndef EBCDIC  /* These problematic code points are 4 bytes on EBCDIC, so
1260                    aren't tested here */
1261         /* The most likely code points in this range are below the surrogates.
1262          * Do an extra test to quickly exclude those. */
1263         if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST)) {
1264             if (UNLIKELY(   UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv)
1265                          || UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv)))
1266             {
1267                 HANDLE_UNICODE_NONCHAR(uv, flags, msgs);
1268             }
1269             else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
1270                 HANDLE_UNICODE_SURROGATE(uv, flags, msgs);
1271             }
1272         }
1273 #endif
1274         return d;
1275     }
1276
1277     /* Not 3-byte; that means the code point is at least 0x1_0000 on ASCII
1278      * platforms, and 0x4000 on EBCDIC.  There are problematic cases that can
1279      * happen starting with 4-byte characters on ASCII platforms.  We unify the
1280      * code for these with EBCDIC, even though some of them require 5-bytes on
1281      * those, because khw believes the code saving is worth the very slight
1282      * performance hit on these high EBCDIC code points. */
1283
1284     if (UNLIKELY(UNICODE_IS_SUPER(uv))) {
1285         const char * format = super_cp_format;
1286         U32 category = packWARN(WARN_NON_UNICODE);
1287         if (UNLIKELY(uv > MAX_EXTERNALLY_LEGAL_CP)) {
1288             Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_EXTERNALLY_LEGAL_CP);
1289         }
1290         *msgs = S_new_msg_hv(Perl_form(aTHX_ format, uv), category);
1291         return NULL;
1292     }
1293     else if (UNLIKELY(UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) {
1294         HANDLE_UNICODE_NONCHAR(uv, flags, msgs);
1295     }
1296
1297     /* Test for and handle 4-byte result.   In the test immediately below, the
1298      * 8 is for start bytes F0-F7 (which are all the possible ones for 4 byte
1299      * characters).  The 3 is for 3 continuation bytes; these each contribute
1300      * MY_SHIFT bits.  This yields 0x4_0000 on EBCDIC platforms, 0x20_0000 on
1301      * ASCII, so 4 bytes covers the range 0x4000-0x3_FFFF on EBCDIC;
1302      * 0x1_0000-0x1F_FFFF on ASCII */
1303     if (uv < (8 * (1U << (3 * MY_SHIFT)))) {
1304         *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * MY_SHIFT)) | UTF_START_MARK(4));
1305         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK);
1306         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * MY_SHIFT)) & MY_MASK) | MY_MARK);
1307         *d++ = I8_TO_NATIVE_UTF8(( uv  /* (1 - 1) */           & MY_MASK) | MY_MARK);
1308
1309 #ifdef EBCDIC   /* These were handled on ASCII platforms in the code for 3-byte
1310                    characters.  The end-plane non-characters for EBCDIC were
1311                    handled just above */
1312         if (UNLIKELY(UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv))) {
1313             HANDLE_UNICODE_NONCHAR(uv, flags, msgs);
1314         }
1315         else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
1316             HANDLE_UNICODE_SURROGATE(uv, flags, msgs);
1317         }
1318 #endif
1319
1320         return d;
1321     }
1322
1323     /* Not 4-byte; that means the code point is at least 0x20_0000 on ASCII
1324      * platforms, and 0x4000 on EBCDIC.  At this point we switch to a loop
1325      * format.  The unrolled version above turns out to not save all that much
1326      * time, and at these high code points (well above the legal Unicode range
1327      * on ASCII platforms, and well above anything in common use in EBCDIC),
1328      * khw believes that less code outweighs slight performance gains. */
1329
1330     {
1331         STRLEN len  = OFFUNISKIP(uv);
1332         U8 *p = d+len-1;
1333         while (p > d) {
1334             *p-- = I8_TO_NATIVE_UTF8((uv & MY_MASK) | MY_MARK);
1335             uv >>= MY_SHIFT;
1336         }
1337         *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1338         return d+len;
1339     }
1340 }
1341
1342 #endif  /* End of defining our own uvchr_to_utf8_flags_msgs() */
1343 #endif  /* End of UTF8SKIP */
1344
1345 #endif /* ENCODE_H */