This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
21664d5cf8cc46bca694180a645bcd3813c82337
[perl5.git] / utf8.c
1 /*    utf8.c
2  *
3  *    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'What a fix!' said Sam.  'That's the one place in all the lands we've ever
13  *  heard of that we don't want to see any closer; and that's the one place
14  *  we're trying to get to!  And that's just where we can't get, nohow.'
15  *
16  *     [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
17  *
18  * 'Well do I understand your speech,' he answered in the same language;
19  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
20  *  as is the custom in the West, if you wish to be answered?'
21  *                           --Gandalf, addressing Théoden's door wardens
22  *
23  *     [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
24  *
25  * ...the travellers perceived that the floor was paved with stones of many
26  * hues; branching runes and strange devices intertwined beneath their feet.
27  *
28  *     [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
29  */
30
31 #include "EXTERN.h"
32 #define PERL_IN_UTF8_C
33 #include "perl.h"
34 #include "invlist_inline.h"
35
36 static const char malformed_text[] = "Malformed UTF-8 character";
37 static const char unees[] =
38                         "Malformed UTF-8 character (unexpected end of string)";
39 static const char cp_above_legal_max[] =
40                         "Use of code point 0x%" UVXf " is not allowed; the"
41                         " permissible max is 0x%" UVXf;
42
43 #define MAX_EXTERNALLY_LEGAL_CP ((UV) (IV_MAX))
44
45 /*
46 =head1 Unicode Support
47 These are various utility functions for manipulating UTF8-encoded
48 strings.  For the uninitiated, this is a method of representing arbitrary
49 Unicode characters as a variable number of bytes, in such a way that
50 characters in the ASCII range are unmodified, and a zero byte never appears
51 within non-zero characters.
52
53 =cut
54 */
55
56 void
57 Perl__force_out_malformed_utf8_message(pTHX_
58             const U8 *const p,      /* First byte in UTF-8 sequence */
59             const U8 * const e,     /* Final byte in sequence (may include
60                                        multiple chars */
61             const U32 flags,        /* Flags to pass to utf8n_to_uvchr(),
62                                        usually 0, or some DISALLOW flags */
63             const bool die_here)    /* If TRUE, this function does not return */
64 {
65     /* This core-only function is to be called when a malformed UTF-8 character
66      * is found, in order to output the detailed information about the
67      * malformation before dieing.  The reason it exists is for the occasions
68      * when such a malformation is fatal, but warnings might be turned off, so
69      * that normally they would not be actually output.  This ensures that they
70      * do get output.  Because a sequence may be malformed in more than one
71      * way, multiple messages may be generated, so we can't make them fatal, as
72      * that would cause the first one to die.
73      *
74      * Instead we pretend -W was passed to perl, then die afterwards.  The
75      * flexibility is here to return to the caller so they can finish up and
76      * die themselves */
77     U32 errors;
78
79     PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE;
80
81     ENTER;
82     SAVEI8(PL_dowarn);
83     SAVESPTR(PL_curcop);
84
85     PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
86     if (PL_curcop) {
87         PL_curcop->cop_warnings = pWARN_ALL;
88     }
89
90     (void) utf8n_to_uvchr_error(p, e - p, NULL, flags & ~UTF8_CHECK_ONLY, &errors);
91
92     LEAVE;
93
94     if (! errors) {
95         Perl_croak(aTHX_ "panic: _force_out_malformed_utf8_message should"
96                          " be called only when there are errors found");
97     }
98
99     if (die_here) {
100         Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
101     }
102 }
103
104 /*
105 =for apidoc uvoffuni_to_utf8_flags
106
107 THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
108 Instead, B<Almost all code should use L</uvchr_to_utf8> or
109 L</uvchr_to_utf8_flags>>.
110
111 This function is like them, but the input is a strict Unicode
112 (as opposed to native) code point.  Only in very rare circumstances should code
113 not be using the native code point.
114
115 For details, see the description for L</uvchr_to_utf8_flags>.
116
117 =cut
118 */
119
120 /* All these formats take a single UV code point argument */
121 const char surrogate_cp_format[] = "UTF-16 surrogate U+%04" UVXf;
122 const char nonchar_cp_format[]   = "Unicode non-character U+%04" UVXf
123                                    " is not recommended for open interchange";
124 const char super_cp_format[]     = "Code point 0x%" UVXf " is not Unicode,"
125                                    " may not be portable";
126 const char perl_extended_cp_format[] = "Code point 0x%" UVXf " is not"        \
127                                        " Unicode, requires a Perl extension," \
128                                        " and so is not portable";
129
130 #define HANDLE_UNICODE_SURROGATE(uv, flags)                         \
131     STMT_START {                                                    \
132         if (flags & UNICODE_WARN_SURROGATE) {                       \
133             Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),        \
134                                    surrogate_cp_format, uv);        \
135         }                                                           \
136         if (flags & UNICODE_DISALLOW_SURROGATE) {                   \
137             return NULL;                                            \
138         }                                                           \
139     } STMT_END;
140
141 #define HANDLE_UNICODE_NONCHAR(uv, flags)                           \
142     STMT_START {                                                    \
143         if (flags & UNICODE_WARN_NONCHAR) {                         \
144             Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),          \
145                                    nonchar_cp_format, uv);          \
146         }                                                           \
147         if (flags & UNICODE_DISALLOW_NONCHAR) {                     \
148             return NULL;                                            \
149         }                                                           \
150     } STMT_END;
151
152 /*  Use shorter names internally in this file */
153 #define SHIFT   UTF_ACCUMULATION_SHIFT
154 #undef  MARK
155 #define MARK    UTF_CONTINUATION_MARK
156 #define MASK    UTF_CONTINUATION_MASK
157
158 U8 *
159 Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, const UV flags)
160 {
161     PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS;
162
163     if (OFFUNI_IS_INVARIANT(uv)) {
164         *d++ = LATIN1_TO_NATIVE(uv);
165         return d;
166     }
167
168     if (uv <= MAX_UTF8_TWO_BYTE) {
169         *d++ = I8_TO_NATIVE_UTF8(( uv >> SHIFT) | UTF_START_MARK(2));
170         *d++ = I8_TO_NATIVE_UTF8(( uv           & MASK) |   MARK);
171         return d;
172     }
173
174     /* Not 2-byte; test for and handle 3-byte result.   In the test immediately
175      * below, the 16 is for start bytes E0-EF (which are all the possible ones
176      * for 3 byte characters).  The 2 is for 2 continuation bytes; these each
177      * contribute SHIFT bits.  This yields 0x4000 on EBCDIC platforms, 0x1_0000
178      * on ASCII; so 3 bytes covers the range 0x400-0x3FFF on EBCDIC;
179      * 0x800-0xFFFF on ASCII */
180     if (uv < (16 * (1U << (2 * SHIFT)))) {
181         *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * SHIFT)) | UTF_START_MARK(3));
182         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) |   MARK);
183         *d++ = I8_TO_NATIVE_UTF8(( uv  /* (1 - 1) */        & MASK) |   MARK);
184
185 #ifndef EBCDIC  /* These problematic code points are 4 bytes on EBCDIC, so
186                    aren't tested here */
187         /* The most likely code points in this range are below the surrogates.
188          * Do an extra test to quickly exclude those. */
189         if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST)) {
190             if (UNLIKELY(   UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv)
191                          || UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv)))
192             {
193                 HANDLE_UNICODE_NONCHAR(uv, flags);
194             }
195             else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
196                 HANDLE_UNICODE_SURROGATE(uv, flags);
197             }
198         }
199 #endif
200         return d;
201     }
202
203     /* Not 3-byte; that means the code point is at least 0x1_0000 on ASCII
204      * platforms, and 0x4000 on EBCDIC.  There are problematic cases that can
205      * happen starting with 4-byte characters on ASCII platforms.  We unify the
206      * code for these with EBCDIC, even though some of them require 5-bytes on
207      * those, because khw believes the code saving is worth the very slight
208      * performance hit on these high EBCDIC code points. */
209
210     if (UNLIKELY(UNICODE_IS_SUPER(uv))) {
211         if (UNLIKELY(uv > MAX_EXTERNALLY_LEGAL_CP)) {
212             Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_EXTERNALLY_LEGAL_CP);
213         }
214         if (      (flags & UNICODE_WARN_SUPER)
215             || (  (flags & UNICODE_WARN_PERL_EXTENDED)
216                 && UNICODE_IS_PERL_EXTENDED(uv)))
217         {
218             Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE),
219
220               /* Choose the more dire applicable warning */
221               (UNICODE_IS_PERL_EXTENDED(uv))
222               ? perl_extended_cp_format
223               : super_cp_format,
224              uv);
225         }
226         if (       (flags & UNICODE_DISALLOW_SUPER)
227             || (   (flags & UNICODE_DISALLOW_PERL_EXTENDED)
228                 &&  UNICODE_IS_PERL_EXTENDED(uv)))
229         {
230             return NULL;
231         }
232     }
233     else if (UNLIKELY(UNICODE_IS_END_PLANE_NONCHAR_GIVEN_NOT_SUPER(uv))) {
234         HANDLE_UNICODE_NONCHAR(uv, flags);
235     }
236
237     /* Test for and handle 4-byte result.   In the test immediately below, the
238      * 8 is for start bytes F0-F7 (which are all the possible ones for 4 byte
239      * characters).  The 3 is for 3 continuation bytes; these each contribute
240      * SHIFT bits.  This yields 0x4_0000 on EBCDIC platforms, 0x20_0000 on
241      * ASCII, so 4 bytes covers the range 0x4000-0x3_FFFF on EBCDIC;
242      * 0x1_0000-0x1F_FFFF on ASCII */
243     if (uv < (8 * (1U << (3 * SHIFT)))) {
244         *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * SHIFT)) | UTF_START_MARK(4));
245         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * SHIFT)) & MASK) |   MARK);
246         *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) |   MARK);
247         *d++ = I8_TO_NATIVE_UTF8(( uv  /* (1 - 1) */        & MASK) |   MARK);
248
249 #ifdef EBCDIC   /* These were handled on ASCII platforms in the code for 3-byte
250                    characters.  The end-plane non-characters for EBCDIC were
251                    handled just above */
252         if (UNLIKELY(UNICODE_IS_32_CONTIGUOUS_NONCHARS(uv))) {
253             HANDLE_UNICODE_NONCHAR(uv, flags);
254         }
255         else if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
256             HANDLE_UNICODE_SURROGATE(uv, flags);
257         }
258 #endif
259
260         return d;
261     }
262
263     /* Not 4-byte; that means the code point is at least 0x20_0000 on ASCII
264      * platforms, and 0x4000 on EBCDIC.  At this point we switch to a loop
265      * format.  The unrolled version above turns out to not save all that much
266      * time, and at these high code points (well above the legal Unicode range
267      * on ASCII platforms, and well above anything in common use in EBCDIC),
268      * khw believes that less code outweighs slight performance gains. */
269
270     {
271         STRLEN len  = OFFUNISKIP(uv);
272         U8 *p = d+len-1;
273         while (p > d) {
274             *p-- = I8_TO_NATIVE_UTF8((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
275             uv >>= UTF_ACCUMULATION_SHIFT;
276         }
277         *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
278         return d+len;
279     }
280 }
281
282 /*
283 =for apidoc uvchr_to_utf8
284
285 Adds the UTF-8 representation of the native code point C<uv> to the end
286 of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
287 C<UTF8_MAXBYTES+1>) free bytes available.  The return value is the pointer to
288 the byte after the end of the new character.  In other words,
289
290     d = uvchr_to_utf8(d, uv);
291
292 is the recommended wide native character-aware way of saying
293
294     *(d++) = uv;
295
296 This function accepts any code point from 0..C<IV_MAX> as input.
297 C<IV_MAX> is typically 0x7FFF_FFFF in a 32-bit word.
298
299 It is possible to forbid or warn on non-Unicode code points, or those that may
300 be problematic by using L</uvchr_to_utf8_flags>.
301
302 =cut
303 */
304
305 /* This is also a macro */
306 PERL_CALLCONV U8*       Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
307
308 U8 *
309 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
310 {
311     return uvchr_to_utf8(d, uv);
312 }
313
314 /*
315 =for apidoc uvchr_to_utf8_flags
316
317 Adds the UTF-8 representation of the native code point C<uv> to the end
318 of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
319 C<UTF8_MAXBYTES+1>) free bytes available.  The return value is the pointer to
320 the byte after the end of the new character.  In other words,
321
322     d = uvchr_to_utf8_flags(d, uv, flags);
323
324 or, in most cases,
325
326     d = uvchr_to_utf8_flags(d, uv, 0);
327
328 This is the Unicode-aware way of saying
329
330     *(d++) = uv;
331
332 If C<flags> is 0, this function accepts any code point from 0..C<IV_MAX> as
333 input.  C<IV_MAX> is typically 0x7FFF_FFFF in a 32-bit word.
334
335 Specifying C<flags> can further restrict what is allowed and not warned on, as
336 follows:
337
338 If C<uv> is a Unicode surrogate code point and C<UNICODE_WARN_SURROGATE> is set,
339 the function will raise a warning, provided UTF8 warnings are enabled.  If
340 instead C<UNICODE_DISALLOW_SURROGATE> is set, the function will fail and return
341 NULL.  If both flags are set, the function will both warn and return NULL.
342
343 Similarly, the C<UNICODE_WARN_NONCHAR> and C<UNICODE_DISALLOW_NONCHAR> flags
344 affect how the function handles a Unicode non-character.
345
346 And likewise, the C<UNICODE_WARN_SUPER> and C<UNICODE_DISALLOW_SUPER> flags
347 affect the handling of code points that are above the Unicode maximum of
348 0x10FFFF.  Languages other than Perl may not be able to accept files that
349 contain these.
350
351 The flag C<UNICODE_WARN_ILLEGAL_INTERCHANGE> selects all three of
352 the above WARN flags; and C<UNICODE_DISALLOW_ILLEGAL_INTERCHANGE> selects all
353 three DISALLOW flags.  C<UNICODE_DISALLOW_ILLEGAL_INTERCHANGE> restricts the
354 allowed inputs to the strict UTF-8 traditionally defined by Unicode.
355 Similarly, C<UNICODE_WARN_ILLEGAL_C9_INTERCHANGE> and
356 C<UNICODE_DISALLOW_ILLEGAL_C9_INTERCHANGE> are shortcuts to select the
357 above-Unicode and surrogate flags, but not the non-character ones, as
358 defined in
359 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
360 See L<perlunicode/Noncharacter code points>.
361
362 Extremely high code points were never specified in any standard, and require an
363 extension to UTF-8 to express, which Perl does.  It is likely that programs
364 written in something other than Perl would not be able to read files that
365 contain these; nor would Perl understand files written by something that uses a
366 different extension.  For these reasons, there is a separate set of flags that
367 can warn and/or disallow these extremely high code points, even if other
368 above-Unicode ones are accepted.  They are the C<UNICODE_WARN_PERL_EXTENDED>
369 and C<UNICODE_DISALLOW_PERL_EXTENDED> flags.  For more information see
370 L</C<UTF8_GOT_PERL_EXTENDED>>.  Of course C<UNICODE_DISALLOW_SUPER> will
371 treat all above-Unicode code points, including these, as malformations.  (Note
372 that the Unicode standard considers anything above 0x10FFFF to be illegal, but
373 there are standards predating it that allow up to 0x7FFF_FFFF (2**31 -1))
374
375 A somewhat misleadingly named synonym for C<UNICODE_WARN_PERL_EXTENDED> is
376 retained for backward compatibility: C<UNICODE_WARN_ABOVE_31_BIT>.  Similarly,
377 C<UNICODE_DISALLOW_ABOVE_31_BIT> is usable instead of the more accurately named
378 C<UNICODE_DISALLOW_PERL_EXTENDED>.  The names are misleading because these
379 flags can apply to code points that actually do fit in 31 bits.  This happens
380 on EBCDIC platforms, and sometimes when the L<overlong
381 malformation|/C<UTF8_GOT_LONG>> is also present.  The new names accurately
382 describe the situation in all cases.
383
384 =cut
385 */
386
387 /* This is also a macro */
388 PERL_CALLCONV U8*       Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags);
389
390 U8 *
391 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
392 {
393     return uvchr_to_utf8_flags(d, uv, flags);
394 }
395
396 #ifndef UV_IS_QUAD
397
398 STATIC int
399 S_is_utf8_cp_above_31_bits(const U8 * const s,
400                            const U8 * const e,
401                            const bool consider_overlongs)
402 {
403     /* Returns TRUE if the first code point represented by the Perl-extended-
404      * UTF-8-encoded string starting at 's', and looking no further than 'e -
405      * 1' doesn't fit into 31 bytes.  That is, that if it is >= 2**31.
406      *
407      * The function handles the case where the input bytes do not include all
408      * the ones necessary to represent a full character.  That is, they may be
409      * the intial bytes of the representation of a code point, but possibly
410      * the final ones necessary for the complete representation may be beyond
411      * 'e - 1'.
412      *
413      * The function also can handle the case where the input is an overlong
414      * sequence.  If 'consider_overlongs' is 0, the function assumes the
415      * input is not overlong, without checking, and will return based on that
416      * assumption.  If this parameter is 1, the function will go to the trouble
417      * of figuring out if it actually evaluates to above or below 31 bits.
418      *
419      * The sequence is otherwise assumed to be well-formed, without checking.
420      */
421
422     const STRLEN len = e - s;
423     int is_overlong;
424
425     PERL_ARGS_ASSERT_IS_UTF8_CP_ABOVE_31_BITS;
426
427     assert(! UTF8_IS_INVARIANT(*s) && e > s);
428
429 #ifdef EBCDIC
430
431     PERL_UNUSED_ARG(consider_overlongs);
432
433     /* On the EBCDIC code pages we handle, only the native start byte 0xFE can
434      * mean a 32-bit or larger code point (0xFF is an invariant).  0xFE can
435      * also be the start byte for a 31-bit code point; we need at least 2
436      * bytes, and maybe up through 8 bytes, to determine that.  (It can also be
437      * the start byte for an overlong sequence, but for 30-bit or smaller code
438      * points, so we don't have to worry about overlongs on EBCDIC.) */
439     if (*s != 0xFE) {
440         return 0;
441     }
442
443     if (len == 1) {
444         return -1;
445     }
446
447 #else
448
449     /* On ASCII, FE and FF are the only start bytes that can evaluate to
450      * needing more than 31 bits. */
451     if (LIKELY(*s < 0xFE)) {
452         return 0;
453     }
454
455     /* What we have left are FE and FF.  Both of these require more than 31
456      * bits unless they are for overlongs. */
457     if (! consider_overlongs) {
458         return 1;
459     }
460
461     /* Here, we have FE or FF.  If the input isn't overlong, it evaluates to
462      * above 31 bits.  But we need more than one byte to discern this, so if
463      * passed just the start byte, it could be an overlong evaluating to
464      * smaller */
465     if (len == 1) {
466         return -1;
467     }
468
469     /* Having excluded len==1, and knowing that FE and FF are both valid start
470      * bytes, we can call the function below to see if the sequence is
471      * overlong.  (We don't need the full generality of the called function,
472      * but for these huge code points, speed shouldn't be a consideration, and
473      * the compiler does have enough information, since it's static to this
474      * file, to optimize to just the needed parts.) */
475     is_overlong = is_utf8_overlong_given_start_byte_ok(s, len);
476
477     /* If it isn't overlong, more than 31 bits are required. */
478     if (is_overlong == 0) {
479         return 1;
480     }
481
482     /* If it is indeterminate if it is overlong, return that */
483     if (is_overlong < 0) {
484         return -1;
485     }
486
487     /* Here is overlong.  Such a sequence starting with FE is below 31 bits, as
488      * the max it can be is 2**31 - 1 */
489     if (*s == 0xFE) {
490         return 0;
491     }
492
493 #endif
494
495     /* Here, ASCII and EBCDIC rejoin:
496     *  On ASCII:   We have an overlong sequence starting with FF
497     *  On EBCDIC:  We have a sequence starting with FE. */
498
499     {   /* For C89, use a block so the declaration can be close to its use */
500
501 #ifdef EBCDIC
502
503         /* U+7FFFFFFF (2 ** 31 - 1)
504          *              [0] [1] [2] [3] [4] [5] [6] [7] [8] [9] 10  11  12  13
505          *   IBM-1047: \xFE\x41\x41\x41\x41\x41\x41\x42\x73\x73\x73\x73\x73\x73
506          *    IBM-037: \xFE\x41\x41\x41\x41\x41\x41\x42\x72\x72\x72\x72\x72\x72
507          *   POSIX-BC: \xFE\x41\x41\x41\x41\x41\x41\x42\x75\x75\x75\x75\x75\x75
508          *         I8: \xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA1\xBF\xBF\xBF\xBF\xBF\xBF
509          * U+80000000 (2 ** 31):
510          *   IBM-1047: \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41
511          *    IBM-037: \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41
512          *   POSIX-BC: \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41
513          *         I8: \xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA2\xA0\xA0\xA0\xA0\xA0\xA0
514          *
515          * and since we know that *s = \xfe, any continuation sequcence
516          * following it that is gt the below is above 31 bits
517                                                 [0] [1] [2] [3] [4] [5] [6] */
518         const U8 conts_for_highest_30_bit[] = "\x41\x41\x41\x41\x41\x41\x42";
519
520 #else
521
522         /* FF overlong for U+7FFFFFFF (2 ** 31 - 1)
523          *      ASCII: \xFF\x80\x80\x80\x80\x80\x80\x81\xBF\xBF\xBF\xBF\xBF
524          * FF overlong for U+80000000 (2 ** 31):
525          *      ASCII: \xFF\x80\x80\x80\x80\x80\x80\x82\x80\x80\x80\x80\x80
526          * and since we know that *s = \xff, any continuation sequcence
527          * following it that is gt the below is above 30 bits
528                                                 [0] [1] [2] [3] [4] [5] [6] */
529         const U8 conts_for_highest_30_bit[] = "\x80\x80\x80\x80\x80\x80\x81";
530
531
532 #endif
533         const STRLEN conts_len = sizeof(conts_for_highest_30_bit) - 1;
534         const STRLEN cmp_len = MIN(conts_len, len - 1);
535
536         /* Now compare the continuation bytes in s with the ones we have
537          * compiled in that are for the largest 30 bit code point.  If we have
538          * enough bytes available to determine the answer, or the bytes we do
539          * have differ from them, we can compare the two to get a definitive
540          * answer (Note that in UTF-EBCDIC, the two lowest possible
541          * continuation bytes are \x41 and \x42.) */
542         if (cmp_len >= conts_len || memNE(s + 1,
543                                           conts_for_highest_30_bit,
544                                           cmp_len))
545         {
546             return cBOOL(memGT(s + 1, conts_for_highest_30_bit, cmp_len));
547         }
548
549         /* Here, all the bytes we have are the same as the highest 30-bit code
550          * point, but we are missing so many bytes that we can't make the
551          * determination */
552         return -1;
553     }
554 }
555
556 #endif
557
558 PERL_STATIC_INLINE int
559 S_is_utf8_overlong_given_start_byte_ok(const U8 * const s, const STRLEN len)
560 {
561     /* Returns an int indicating whether or not the UTF-8 sequence from 's' to
562      * 's' + 'len' - 1 is an overlong.  It returns 1 if it is an overlong; 0 if
563      * it isn't, and -1 if there isn't enough information to tell.  This last
564      * return value can happen if the sequence is incomplete, missing some
565      * trailing bytes that would form a complete character.  If there are
566      * enough bytes to make a definitive decision, this function does so.
567      * Usually 2 bytes sufficient.
568      *
569      * Overlongs can occur whenever the number of continuation bytes changes.
570      * That means whenever the number of leading 1 bits in a start byte
571      * increases from the next lower start byte.  That happens for start bytes
572      * C0, E0, F0, F8, FC, FE, and FF.  On modern perls, the following illegal
573      * start bytes have already been excluded, so don't need to be tested here;
574      * ASCII platforms: C0, C1
575      * EBCDIC platforms C0, C1, C2, C3, C4, E0
576      */
577
578     const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
579     const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
580
581     PERL_ARGS_ASSERT_IS_UTF8_OVERLONG_GIVEN_START_BYTE_OK;
582     assert(len > 1 && UTF8_IS_START(*s));
583
584     /* Each platform has overlongs after the start bytes given above (expressed
585      * in I8 for EBCDIC).  What constitutes an overlong varies by platform, but
586      * the logic is the same, except the E0 overlong has already been excluded
587      * on EBCDIC platforms.   The  values below were found by manually
588      * inspecting the UTF-8 patterns.  See the tables in utf8.h and
589      * utfebcdic.h. */
590
591 #       ifdef EBCDIC
592 #           define F0_ABOVE_OVERLONG 0xB0
593 #           define F8_ABOVE_OVERLONG 0xA8
594 #           define FC_ABOVE_OVERLONG 0xA4
595 #           define FE_ABOVE_OVERLONG 0xA2
596 #           define FF_OVERLONG_PREFIX "\xfe\x41\x41\x41\x41\x41\x41\x41"
597                                     /* I8(0xfe) is FF */
598 #       else
599
600     if (s0 == 0xE0 && UNLIKELY(s1 < 0xA0)) {
601         return 1;
602     }
603
604 #           define F0_ABOVE_OVERLONG 0x90
605 #           define F8_ABOVE_OVERLONG 0x88
606 #           define FC_ABOVE_OVERLONG 0x84
607 #           define FE_ABOVE_OVERLONG 0x82
608 #           define FF_OVERLONG_PREFIX "\xff\x80\x80\x80\x80\x80\x80"
609 #       endif
610
611
612     if (   (s0 == 0xF0 && UNLIKELY(s1 < F0_ABOVE_OVERLONG))
613         || (s0 == 0xF8 && UNLIKELY(s1 < F8_ABOVE_OVERLONG))
614         || (s0 == 0xFC && UNLIKELY(s1 < FC_ABOVE_OVERLONG))
615         || (s0 == 0xFE && UNLIKELY(s1 < FE_ABOVE_OVERLONG)))
616     {
617         return 1;
618     }
619
620     /* Check for the FF overlong */
621     return isFF_OVERLONG(s, len);
622 }
623
624 PERL_STATIC_INLINE int
625 S_isFF_OVERLONG(const U8 * const s, const STRLEN len)
626 {
627     /* Returns an int indicating whether or not the UTF-8 sequence from 's' to
628      * 'e' - 1 is an overlong beginning with \xFF.  It returns 1 if it is; 0 if
629      * it isn't, and -1 if there isn't enough information to tell.  This last
630      * return value can happen if the sequence is incomplete, missing some
631      * trailing bytes that would form a complete character.  If there are
632      * enough bytes to make a definitive decision, this function does so. */
633
634     PERL_ARGS_ASSERT_ISFF_OVERLONG;
635
636     /* To be an FF overlong, all the available bytes must match */
637     if (LIKELY(memNE(s, FF_OVERLONG_PREFIX,
638                      MIN(len, sizeof(FF_OVERLONG_PREFIX) - 1))))
639     {
640         return 0;
641     }
642
643     /* To be an FF overlong sequence, all the bytes in FF_OVERLONG_PREFIX must
644      * be there; what comes after them doesn't matter.  See tables in utf8.h,
645      * utfebcdic.h. */
646     if (len >= sizeof(FF_OVERLONG_PREFIX) - 1) {
647         return 1;
648     }
649
650     /* The missing bytes could cause the result to go one way or the other, so
651      * the result is indeterminate */
652     return -1;
653 }
654
655 #if defined(UV_IS_QUAD) /* These assume IV_MAX is 2**63-1 */
656 #  ifdef EBCDIC     /* Actually is I8 */
657 #   define HIGHEST_REPRESENTABLE_UTF8                                       \
658                 "\xFF\xA7\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
659 #  else
660 #   define HIGHEST_REPRESENTABLE_UTF8                                       \
661                 "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
662 #  endif
663 #endif
664
665 PERL_STATIC_INLINE int
666 S_does_utf8_overflow(const U8 * const s,
667                      const U8 * e,
668                      const bool consider_overlongs)
669 {
670     /* Returns an int indicating whether or not the UTF-8 sequence from 's' to
671      * 'e' - 1 would overflow an IV on this platform; that is if it represents
672      * a code point larger than the highest representable code point.  It
673      * returns 1 if it does overflow; 0 if it doesn't, and -1 if there isn't
674      * enough information to tell.  This last return value can happen if the
675      * sequence is incomplete, missing some trailing bytes that would form a
676      * complete character.  If there are enough bytes to make a definitive
677      * decision, this function does so.
678      *
679      * If 'consider_overlongs' is TRUE, the function checks for the possibility
680      * that the sequence is an overlong that doesn't overflow.  Otherwise, it
681      * assumes the sequence is not an overlong.  This can give different
682      * results only on ASCII 32-bit platforms.
683      *
684      * (For ASCII platforms, we could use memcmp() because we don't have to
685      * convert each byte to I8, but it's very rare input indeed that would
686      * approach overflow, so the loop below will likely only get executed once.)
687      *
688      * 'e' - 1 must not be beyond a full character. */
689
690
691     PERL_ARGS_ASSERT_DOES_UTF8_OVERFLOW;
692     assert(s <= e && s + UTF8SKIP(s) >= e);
693
694 #if ! defined(UV_IS_QUAD)
695
696     return is_utf8_cp_above_31_bits(s, e, consider_overlongs);
697
698 #else
699
700     PERL_UNUSED_ARG(consider_overlongs);
701
702     {
703         const STRLEN len = e - s;
704         const U8 *x;
705         const U8 * y = (const U8 *) HIGHEST_REPRESENTABLE_UTF8;
706
707         for (x = s; x < e; x++, y++) {
708
709             if (UNLIKELY(NATIVE_UTF8_TO_I8(*x) == *y)) {
710                 continue;
711             }
712
713             /* If this byte is larger than the corresponding highest UTF-8
714              * byte, the sequence overflow; otherwise the byte is less than,
715              * and so the sequence doesn't overflow */
716             return NATIVE_UTF8_TO_I8(*x) > *y;
717
718         }
719
720         /* Got to the end and all bytes are the same.  If the input is a whole
721          * character, it doesn't overflow.  And if it is a partial character,
722          * there's not enough information to tell */
723         if (len < sizeof(HIGHEST_REPRESENTABLE_UTF8) - 1) {
724             return -1;
725         }
726
727         return 0;
728     }
729
730 #endif
731
732 }
733
734 #if 0
735
736 /* This is the portions of the above function that deal with UV_MAX instead of
737  * IV_MAX.  They are left here in case we want to combine them so that internal
738  * uses can have larger code points.  The only logic difference is that the
739  * 32-bit EBCDIC platform is treate like the 64-bit, and the 32-bit ASCII has
740  * different logic.
741  */
742
743 /* Anything larger than this will overflow the word if it were converted into a UV */
744 #if defined(UV_IS_QUAD)
745 #  ifdef EBCDIC     /* Actually is I8 */
746 #   define HIGHEST_REPRESENTABLE_UTF8                                       \
747                 "\xFF\xAF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
748 #  else
749 #   define HIGHEST_REPRESENTABLE_UTF8                                       \
750                 "\xFF\x80\x8F\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"
751 #  endif
752 #else   /* 32-bit */
753 #  ifdef EBCDIC
754 #   define HIGHEST_REPRESENTABLE_UTF8                                       \
755                 "\xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA3\xBF\xBF\xBF\xBF\xBF\xBF"
756 #  else
757 #   define HIGHEST_REPRESENTABLE_UTF8  "\xFE\x83\xBF\xBF\xBF\xBF\xBF"
758 #  endif
759 #endif
760
761 #if ! defined(UV_IS_QUAD) && ! defined(EBCDIC)
762
763     /* On 32 bit ASCII machines, many overlongs that start with FF don't
764      * overflow */
765     if (consider_overlongs && isFF_OVERLONG(s, len) > 0) {
766
767         /* To be such an overlong, the first bytes of 's' must match
768          * FF_OVERLONG_PREFIX, which is "\xff\x80\x80\x80\x80\x80\x80".  If we
769          * don't have any additional bytes available, the sequence, when
770          * completed might or might not fit in 32 bits.  But if we have that
771          * next byte, we can tell for sure.  If it is <= 0x83, then it does
772          * fit. */
773         if (len <= sizeof(FF_OVERLONG_PREFIX) - 1) {
774             return -1;
775         }
776
777         return s[sizeof(FF_OVERLONG_PREFIX) - 1] > 0x83;
778     }
779
780 /* Starting with the #else, the rest of the function is identical except
781  *      1.  we need to move the 'len' declaration to be global to the function
782  *      2.  the endif move to just after the UNUSED_ARG.
783  * An empty endif is given just below to satisfy the preprocessor
784  */
785 #endif
786
787 #endif
788
789 #undef F0_ABOVE_OVERLONG
790 #undef F8_ABOVE_OVERLONG
791 #undef FC_ABOVE_OVERLONG
792 #undef FE_ABOVE_OVERLONG
793 #undef FF_OVERLONG_PREFIX
794
795 STRLEN
796 Perl__is_utf8_char_helper(const U8 * const s, const U8 * e, const U32 flags)
797 {
798     STRLEN len;
799     const U8 *x;
800
801     /* A helper function that should not be called directly.
802      *
803      * This function returns non-zero if the string beginning at 's' and
804      * looking no further than 'e - 1' is well-formed Perl-extended-UTF-8 for a
805      * code point; otherwise it returns 0.  The examination stops after the
806      * first code point in 's' is validated, not looking at the rest of the
807      * input.  If 'e' is such that there are not enough bytes to represent a
808      * complete code point, this function will return non-zero anyway, if the
809      * bytes it does have are well-formed UTF-8 as far as they go, and aren't
810      * excluded by 'flags'.
811      *
812      * A non-zero return gives the number of bytes required to represent the
813      * code point.  Be aware that if the input is for a partial character, the
814      * return will be larger than 'e - s'.
815      *
816      * This function assumes that the code point represented is UTF-8 variant.
817      * The caller should have excluded the possibility of it being invariant
818      * before calling this function.
819      *
820      * 'flags' can be 0, or any combination of the UTF8_DISALLOW_foo flags
821      * accepted by L</utf8n_to_uvchr>.  If non-zero, this function will return
822      * 0 if the code point represented is well-formed Perl-extended-UTF-8, but
823      * disallowed by the flags.  If the input is only for a partial character,
824      * the function will return non-zero if there is any sequence of
825      * well-formed UTF-8 that, when appended to the input sequence, could
826      * result in an allowed code point; otherwise it returns 0.  Non characters
827      * cannot be determined based on partial character input.  But many  of the
828      * other excluded types can be determined with just the first one or two
829      * bytes.
830      *
831      */
832
833     PERL_ARGS_ASSERT__IS_UTF8_CHAR_HELPER;
834
835     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
836                           |UTF8_DISALLOW_PERL_EXTENDED)));
837     assert(! UTF8_IS_INVARIANT(*s));
838
839     /* A variant char must begin with a start byte */
840     if (UNLIKELY(! UTF8_IS_START(*s))) {
841         return 0;
842     }
843
844     /* Examine a maximum of a single whole code point */
845     if (e - s > UTF8SKIP(s)) {
846         e = s + UTF8SKIP(s);
847     }
848
849     len = e - s;
850
851     if (flags && isUTF8_POSSIBLY_PROBLEMATIC(*s)) {
852         const U8 s0 = NATIVE_UTF8_TO_I8(s[0]);
853
854         /* Here, we are disallowing some set of largish code points, and the
855          * first byte indicates the sequence is for a code point that could be
856          * in the excluded set.  We generally don't have to look beyond this or
857          * the second byte to see if the sequence is actually for one of the
858          * excluded classes.  The code below is derived from this table:
859          *
860          *              UTF-8            UTF-EBCDIC I8
861          *   U+D800: \xED\xA0\x80      \xF1\xB6\xA0\xA0      First surrogate
862          *   U+DFFF: \xED\xBF\xBF      \xF1\xB7\xBF\xBF      Final surrogate
863          * U+110000: \xF4\x90\x80\x80  \xF9\xA2\xA0\xA0\xA0  First above Unicode
864          *
865          * Keep in mind that legal continuation bytes range between \x80..\xBF
866          * for UTF-8, and \xA0..\xBF for I8.  Anything above those aren't
867          * continuation bytes.  Hence, we don't have to test the upper edge
868          * because if any of those is encountered, the sequence is malformed,
869          * and would fail elsewhere in this function.
870          *
871          * The code here likewise assumes that there aren't other
872          * malformations; again the function should fail elsewhere because of
873          * these.  For example, an overlong beginning with FC doesn't actually
874          * have to be a super; it could actually represent a small code point,
875          * even U+0000.  But, since overlongs (and other malformations) are
876          * illegal, the function should return FALSE in either case.
877          */
878
879 #ifdef EBCDIC   /* On EBCDIC, these are actually I8 bytes */
880 #  define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER  0xFA
881 #  define IS_UTF8_2_BYTE_SUPER(s0, s1)           ((s0) == 0xF9 && (s1) >= 0xA2)
882
883 #  define IS_UTF8_2_BYTE_SURROGATE(s0, s1)       ((s0) == 0xF1              \
884                                                        /* B6 and B7 */      \
885                                               && ((s1) & 0xFE ) == 0xB6)
886 #  define isUTF8_PERL_EXTENDED(s)   (*s == I8_TO_NATIVE_UTF8(0xFF))
887 #else
888 #  define FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER  0xF5
889 #  define IS_UTF8_2_BYTE_SUPER(s0, s1)           ((s0) == 0xF4 && (s1) >= 0x90)
890 #  define IS_UTF8_2_BYTE_SURROGATE(s0, s1)       ((s0) == 0xED && (s1) >= 0xA0)
891 #  define isUTF8_PERL_EXTENDED(s)   (*s >= 0xFE)
892 #endif
893
894         if (  (flags & UTF8_DISALLOW_SUPER)
895             && UNLIKELY(s0 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
896         {
897             return 0;           /* Above Unicode */
898         }
899
900         if (   (flags & UTF8_DISALLOW_PERL_EXTENDED)
901             &&  UNLIKELY(isUTF8_PERL_EXTENDED(s)))
902         {
903             return 0;
904         }
905
906         if (len > 1) {
907             const U8 s1 = NATIVE_UTF8_TO_I8(s[1]);
908
909             if (   (flags & UTF8_DISALLOW_SUPER)
910                 &&  UNLIKELY(IS_UTF8_2_BYTE_SUPER(s0, s1)))
911             {
912                 return 0;       /* Above Unicode */
913             }
914
915             if (   (flags & UTF8_DISALLOW_SURROGATE)
916                 &&  UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(s0, s1)))
917             {
918                 return 0;       /* Surrogate */
919             }
920
921             if (  (flags & UTF8_DISALLOW_NONCHAR)
922                 && UNLIKELY(UTF8_IS_NONCHAR(s, e)))
923             {
924                 return 0;       /* Noncharacter code point */
925             }
926         }
927     }
928
929     /* Make sure that all that follows are continuation bytes */
930     for (x = s + 1; x < e; x++) {
931         if (UNLIKELY(! UTF8_IS_CONTINUATION(*x))) {
932             return 0;
933         }
934     }
935
936     /* Here is syntactically valid.  Next, make sure this isn't the start of an
937      * overlong. */
938     if (len > 1 && is_utf8_overlong_given_start_byte_ok(s, len) > 0) {
939         return 0;
940     }
941
942     /* And finally, that the code point represented fits in a word on this
943      * platform */
944     if (0 < does_utf8_overflow(s, e,
945                                0 /* Don't consider overlongs */
946                               ))
947     {
948         return 0;
949     }
950
951     return UTF8SKIP(s);
952 }
953
954 char *
955 Perl__byte_dump_string(pTHX_ const U8 * const start, const STRLEN len, const bool format)
956 {
957     /* Returns a mortalized C string that is a displayable copy of the 'len'
958      * bytes starting at 'start'.  'format' gives how to display each byte.
959      * Currently, there are only two formats, so it is currently a bool:
960      *      0   \xab
961      *      1    ab         (that is a space between two hex digit bytes)
962      */
963
964     const STRLEN output_len = 4 * len + 1;  /* 4 bytes per each input, plus a
965                                                trailing NUL */
966     const U8 * s = start;
967     const U8 * const e = start + len;
968     char * output;
969     char * d;
970
971     PERL_ARGS_ASSERT__BYTE_DUMP_STRING;
972
973     Newx(output, output_len, char);
974     SAVEFREEPV(output);
975
976     d = output;
977     for (s = start; s < e; s++) {
978         const unsigned high_nibble = (*s & 0xF0) >> 4;
979         const unsigned low_nibble =  (*s & 0x0F);
980
981         if (format) {
982             if (s > start) {
983                 *d++ = ' ';
984             }
985         }
986         else {
987             *d++ = '\\';
988             *d++ = 'x';
989         }
990
991         if (high_nibble < 10) {
992             *d++ = high_nibble + '0';
993         }
994         else {
995             *d++ = high_nibble - 10 + 'a';
996         }
997
998         if (low_nibble < 10) {
999             *d++ = low_nibble + '0';
1000         }
1001         else {
1002             *d++ = low_nibble - 10 + 'a';
1003         }
1004     }
1005
1006     *d = '\0';
1007     return output;
1008 }
1009
1010 PERL_STATIC_INLINE char *
1011 S_unexpected_non_continuation_text(pTHX_ const U8 * const s,
1012
1013                                          /* How many bytes to print */
1014                                          STRLEN print_len,
1015
1016                                          /* Which one is the non-continuation */
1017                                          const STRLEN non_cont_byte_pos,
1018
1019                                          /* How many bytes should there be? */
1020                                          const STRLEN expect_len)
1021 {
1022     /* Return the malformation warning text for an unexpected continuation
1023      * byte. */
1024
1025     const char * const where = (non_cont_byte_pos == 1)
1026                                ? "immediately"
1027                                : Perl_form(aTHX_ "%d bytes",
1028                                                  (int) non_cont_byte_pos);
1029
1030     PERL_ARGS_ASSERT_UNEXPECTED_NON_CONTINUATION_TEXT;
1031
1032     /* We don't need to pass this parameter, but since it has already been
1033      * calculated, it's likely faster to pass it; verify under DEBUGGING */
1034     assert(expect_len == UTF8SKIP(s));
1035
1036     return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x,"
1037                            " %s after start byte 0x%02x; need %d bytes, got %d)",
1038                            malformed_text,
1039                            _byte_dump_string(s, print_len, 0),
1040                            *(s + non_cont_byte_pos),
1041                            where,
1042                            *s,
1043                            (int) expect_len,
1044                            (int) non_cont_byte_pos);
1045 }
1046
1047 /*
1048
1049 =for apidoc utf8n_to_uvchr
1050
1051 THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
1052 Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
1053
1054 Bottom level UTF-8 decode routine.
1055 Returns the native code point value of the first character in the string C<s>,
1056 which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
1057 C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
1058 the length, in bytes, of that character.
1059
1060 The value of C<flags> determines the behavior when C<s> does not point to a
1061 well-formed UTF-8 character.  If C<flags> is 0, encountering a malformation
1062 causes zero to be returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>)
1063 is the next possible position in C<s> that could begin a non-malformed
1064 character.  Also, if UTF-8 warnings haven't been lexically disabled, a warning
1065 is raised.  Some UTF-8 input sequences may contain multiple malformations.
1066 This function tries to find every possible one in each call, so multiple
1067 warnings can be raised for the same sequence.
1068
1069 Various ALLOW flags can be set in C<flags> to allow (and not warn on)
1070 individual types of malformations, such as the sequence being overlong (that
1071 is, when there is a shorter sequence that can express the same code point;
1072 overlong sequences are expressly forbidden in the UTF-8 standard due to
1073 potential security issues).  Another malformation example is the first byte of
1074 a character not being a legal first byte.  See F<utf8.h> for the list of such
1075 flags.  Even if allowed, this function generally returns the Unicode
1076 REPLACEMENT CHARACTER when it encounters a malformation.  There are flags in
1077 F<utf8.h> to override this behavior for the overlong malformations, but don't
1078 do that except for very specialized purposes.
1079
1080 The C<UTF8_CHECK_ONLY> flag overrides the behavior when a non-allowed (by other
1081 flags) malformation is found.  If this flag is set, the routine assumes that
1082 the caller will raise a warning, and this function will silently just set
1083 C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
1084
1085 Note that this API requires disambiguation between successful decoding a C<NUL>
1086 character, and an error return (unless the C<UTF8_CHECK_ONLY> flag is set), as
1087 in both cases, 0 is returned, and, depending on the malformation, C<retlen> may
1088 be set to 1.  To disambiguate, upon a zero return, see if the first byte of
1089 C<s> is 0 as well.  If so, the input was a C<NUL>; if not, the input had an
1090 error.  Or you can use C<L</utf8n_to_uvchr_error>>.
1091
1092 Certain code points are considered problematic.  These are Unicode surrogates,
1093 Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
1094 By default these are considered regular code points, but certain situations
1095 warrant special handling for them, which can be specified using the C<flags>
1096 parameter.  If C<flags> contains C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, all
1097 three classes are treated as malformations and handled as such.  The flags
1098 C<UTF8_DISALLOW_SURROGATE>, C<UTF8_DISALLOW_NONCHAR>, and
1099 C<UTF8_DISALLOW_SUPER> (meaning above the legal Unicode maximum) can be set to
1100 disallow these categories individually.  C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>
1101 restricts the allowed inputs to the strict UTF-8 traditionally defined by
1102 Unicode.  Use C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE> to use the strictness
1103 definition given by
1104 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1105 The difference between traditional strictness and C9 strictness is that the
1106 latter does not forbid non-character code points.  (They are still discouraged,
1107 however.)  For more discussion see L<perlunicode/Noncharacter code points>.
1108
1109 The flags C<UTF8_WARN_ILLEGAL_INTERCHANGE>,
1110 C<UTF8_WARN_ILLEGAL_C9_INTERCHANGE>, C<UTF8_WARN_SURROGATE>,
1111 C<UTF8_WARN_NONCHAR>, and C<UTF8_WARN_SUPER> will cause warning messages to be
1112 raised for their respective categories, but otherwise the code points are
1113 considered valid (not malformations).  To get a category to both be treated as
1114 a malformation and raise a warning, specify both the WARN and DISALLOW flags.
1115 (But note that warnings are not raised if lexically disabled nor if
1116 C<UTF8_CHECK_ONLY> is also specified.)
1117
1118 Extremely high code points were never specified in any standard, and require an
1119 extension to UTF-8 to express, which Perl does.  It is likely that programs
1120 written in something other than Perl would not be able to read files that
1121 contain these; nor would Perl understand files written by something that uses a
1122 different extension.  For these reasons, there is a separate set of flags that
1123 can warn and/or disallow these extremely high code points, even if other
1124 above-Unicode ones are accepted.  They are the C<UTF8_WARN_PERL_EXTENDED> and
1125 C<UTF8_DISALLOW_PERL_EXTENDED> flags.  For more information see
1126 L</C<UTF8_GOT_PERL_EXTENDED>>.  Of course C<UTF8_DISALLOW_SUPER> will treat all
1127 above-Unicode code points, including these, as malformations.
1128 (Note that the Unicode standard considers anything above 0x10FFFF to be
1129 illegal, but there are standards predating it that allow up to 0x7FFF_FFFF
1130 (2**31 -1))
1131
1132 A somewhat misleadingly named synonym for C<UTF8_WARN_PERL_EXTENDED> is
1133 retained for backward compatibility: C<UTF8_WARN_ABOVE_31_BIT>.  Similarly,
1134 C<UTF8_DISALLOW_ABOVE_31_BIT> is usable instead of the more accurately named
1135 C<UTF8_DISALLOW_PERL_EXTENDED>.  The names are misleading because these flags
1136 can apply to code points that actually do fit in 31 bits.  This happens on
1137 EBCDIC platforms, and sometimes when the L<overlong
1138 malformation|/C<UTF8_GOT_LONG>> is also present.  The new names accurately
1139 describe the situation in all cases.
1140
1141
1142 All other code points corresponding to Unicode characters, including private
1143 use and those yet to be assigned, are never considered malformed and never
1144 warn.
1145
1146 =cut
1147
1148 Also implemented as a macro in utf8.h
1149 */
1150
1151 UV
1152 Perl_utf8n_to_uvchr(pTHX_ const U8 *s,
1153                           STRLEN curlen,
1154                           STRLEN *retlen,
1155                           const U32 flags)
1156 {
1157     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
1158
1159     return utf8n_to_uvchr_error(s, curlen, retlen, flags, NULL);
1160 }
1161
1162 /* The tables below come from http://bjoern.hoehrmann.de/utf-8/decoder/dfa/,
1163  * which requires this copyright notice */
1164
1165 /* Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
1166
1167 Permission is hereby granted, free of charge, to any person obtaining a copy of
1168 this software and associated documentation files (the "Software"), to deal in
1169 the Software without restriction, including without limitation the rights to
1170 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
1171 of the Software, and to permit persons to whom the Software is furnished to do
1172 so, subject to the following conditions:
1173
1174 The above copyright notice and this permission notice shall be included in all
1175 copies or substantial portions of the Software.
1176
1177 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
1178 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
1179 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
1180 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
1181 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
1182 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
1183 SOFTWARE.
1184
1185 */
1186
1187 #if 0
1188 static U8 utf8d_C9[] = {
1189   /* The first part of the table maps bytes to character classes that
1190    * to reduce the size of the transition table and create bitmasks. */
1191    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-1F*/
1192    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-3F*/
1193    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-5F*/
1194    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-7F*/
1195    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,  9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, /*-9F*/
1196    7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, /*-BF*/
1197    8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /*-DF*/
1198   10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, /*-FF*/
1199
1200   /* The second part is a transition table that maps a combination
1201    * of a state of the automaton and a character class to a state. */
1202    0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
1203   12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
1204   12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
1205   12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
1206   12,36,12,12,12,12,12,12,12,12,12,12
1207 };
1208
1209 #endif
1210
1211 #ifndef EBCDIC
1212
1213 /* This is a version of the above table customized for Perl that doesn't
1214  * exclude surrogates and accepts start bytes up through F7 (representing
1215  * 2**21 - 1). */
1216 static U8 dfa_tab_for_perl[] = {
1217     /* The first part of the table maps bytes to character classes to reduce
1218      * the size of the transition table and create bitmasks. */
1219    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-1F*/
1220    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-3F*/
1221    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-5F*/
1222    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-7F*/
1223    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,  9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, /*-9F*/
1224    7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, /*-BF*/
1225    8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /*-DF*/
1226   10,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, 11,4,4,4,4,4,4,4,8,8,8,8,8,8,8,8, /*-FF*/
1227
1228   /* The second part is a transition table that maps a combination
1229    * of a state of the automaton and a character class to a state. */
1230    0,12,24,36,96,12,12,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,/*23*/
1231   12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,/*47*/
1232   12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,/*71*/
1233   12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,/*95*/
1234   12,36,12,12,12,12,12,36,12,36,12,12 /* 96- 107 */
1235
1236  /* The customization was to repurpose the surrogates type '4' to instead be
1237   * for start bytes F1-F7.  Types 5 and 6 are now unused, and their entries in
1238   * the transition part of the table are set to 12, so are illegal.
1239   *
1240   * To do higher code points would require expansion and some rearrangement of
1241   * the table.  The type '1' entries for continuation bytes 80-8f would have to
1242   * be split into several types, because they aren't treated uniformly for
1243   * higher start bytes, since overlongs for F8 are 80-87; FC: 80-83; and FE:
1244   * 80-81.  We start needing to worry about overflow if FE is included.
1245   * Ignoring, FE and FF, we could use type 5 for F9-FB, and 6 for FD (remember
1246   * from the web site that these are used to right shift).  FE would
1247   * necessarily be type 7; and FF, type 8.  And new states would have to be
1248   * created for F8 and FC (and FE and FF if used), so quite a bit of work would
1249   * be involved.
1250   *
1251   * XXX Better would be to customize the table so that the noncharacters are
1252   * excluded.  This again is non trivial, but doing so would simplify the code
1253   * that uses this, and might make it small enough to make it inlinable */
1254 };
1255
1256 #endif
1257
1258 /*
1259
1260 =for apidoc utf8n_to_uvchr_error
1261
1262 THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
1263 Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
1264
1265 This function is for code that needs to know what the precise malformation(s)
1266 are when an error is found.  If you also need to know the generated warning
1267 messages, use L</utf8n_to_uvchr_msgs>() instead.
1268
1269 It is like C<L</utf8n_to_uvchr>> but it takes an extra parameter placed after
1270 all the others, C<errors>.  If this parameter is 0, this function behaves
1271 identically to C<L</utf8n_to_uvchr>>.  Otherwise, C<errors> should be a pointer
1272 to a C<U32> variable, which this function sets to indicate any errors found.
1273 Upon return, if C<*errors> is 0, there were no errors found.  Otherwise,
1274 C<*errors> is the bit-wise C<OR> of the bits described in the list below.  Some
1275 of these bits will be set if a malformation is found, even if the input
1276 C<flags> parameter indicates that the given malformation is allowed; those
1277 exceptions are noted:
1278
1279 =over 4
1280
1281 =item C<UTF8_GOT_PERL_EXTENDED>
1282
1283 The input sequence is not standard UTF-8, but a Perl extension.  This bit is
1284 set only if the input C<flags> parameter contains either the
1285 C<UTF8_DISALLOW_PERL_EXTENDED> or the C<UTF8_WARN_PERL_EXTENDED> flags.
1286
1287 Code points above 0x7FFF_FFFF (2**31 - 1) were never specified in any standard,
1288 and so some extension must be used to express them.  Perl uses a natural
1289 extension to UTF-8 to represent the ones up to 2**36-1, and invented a further
1290 extension to represent even higher ones, so that any code point that fits in a
1291 64-bit word can be represented.  Text using these extensions is not likely to
1292 be portable to non-Perl code.  We lump both of these extensions together and
1293 refer to them as Perl extended UTF-8.  There exist other extensions that people
1294 have invented, incompatible with Perl's.
1295
1296 On EBCDIC platforms starting in Perl v5.24, the Perl extension for representing
1297 extremely high code points kicks in at 0x3FFF_FFFF (2**30 -1), which is lower
1298 than on ASCII.  Prior to that, code points 2**31 and higher were simply
1299 unrepresentable, and a different, incompatible method was used to represent
1300 code points between 2**30 and 2**31 - 1.
1301
1302 On both platforms, ASCII and EBCDIC, C<UTF8_GOT_PERL_EXTENDED> is set if
1303 Perl extended UTF-8 is used.
1304
1305 In earlier Perls, this bit was named C<UTF8_GOT_ABOVE_31_BIT>, which you still
1306 may use for backward compatibility.  That name is misleading, as this flag may
1307 be set when the code point actually does fit in 31 bits.  This happens on
1308 EBCDIC platforms, and sometimes when the L<overlong
1309 malformation|/C<UTF8_GOT_LONG>> is also present.  The new name accurately
1310 describes the situation in all cases.
1311
1312 =item C<UTF8_GOT_CONTINUATION>
1313
1314 The input sequence was malformed in that the first byte was a a UTF-8
1315 continuation byte.
1316
1317 =item C<UTF8_GOT_EMPTY>
1318
1319 The input C<curlen> parameter was 0.
1320
1321 =item C<UTF8_GOT_LONG>
1322
1323 The input sequence was malformed in that there is some other sequence that
1324 evaluates to the same code point, but that sequence is shorter than this one.
1325
1326 Until Unicode 3.1, it was legal for programs to accept this malformation, but
1327 it was discovered that this created security issues.
1328
1329 =item C<UTF8_GOT_NONCHAR>
1330
1331 The code point represented by the input UTF-8 sequence is for a Unicode
1332 non-character code point.
1333 This bit is set only if the input C<flags> parameter contains either the
1334 C<UTF8_DISALLOW_NONCHAR> or the C<UTF8_WARN_NONCHAR> flags.
1335
1336 =item C<UTF8_GOT_NON_CONTINUATION>
1337
1338 The input sequence was malformed in that a non-continuation type byte was found
1339 in a position where only a continuation type one should be.
1340
1341 =item C<UTF8_GOT_OVERFLOW>
1342
1343 The input sequence was malformed in that it is for a code point that is not
1344 representable in the number of bits available in an IV on the current platform.
1345
1346 =item C<UTF8_GOT_SHORT>
1347
1348 The input sequence was malformed in that C<curlen> is smaller than required for
1349 a complete sequence.  In other words, the input is for a partial character
1350 sequence.
1351
1352 =item C<UTF8_GOT_SUPER>
1353
1354 The input sequence was malformed in that it is for a non-Unicode code point;
1355 that is, one above the legal Unicode maximum.
1356 This bit is set only if the input C<flags> parameter contains either the
1357 C<UTF8_DISALLOW_SUPER> or the C<UTF8_WARN_SUPER> flags.
1358
1359 =item C<UTF8_GOT_SURROGATE>
1360
1361 The input sequence was malformed in that it is for a -Unicode UTF-16 surrogate
1362 code point.
1363 This bit is set only if the input C<flags> parameter contains either the
1364 C<UTF8_DISALLOW_SURROGATE> or the C<UTF8_WARN_SURROGATE> flags.
1365
1366 =back
1367
1368 To do your own error handling, call this function with the C<UTF8_CHECK_ONLY>
1369 flag to suppress any warnings, and then examine the C<*errors> return.
1370
1371 =cut
1372
1373 Also implemented as a macro in utf8.h
1374 */
1375
1376 UV
1377 Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
1378                           STRLEN curlen,
1379                           STRLEN *retlen,
1380                           const U32 flags,
1381                           U32 * errors)
1382 {
1383     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR;
1384
1385     return utf8n_to_uvchr_msgs(s, curlen, retlen, flags, errors, NULL);
1386 }
1387
1388 /*
1389
1390 =for apidoc utf8n_to_uvchr_msgs
1391
1392 THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
1393 Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
1394
1395 This function is for code that needs to know what the precise malformation(s)
1396 are when an error is found, and wants the corresponding warning and/or error
1397 messages to be returned to the caller rather than be displayed.  All messages
1398 that would have been displayed if all lexcial warnings are enabled will be
1399 returned.
1400
1401 It is just like C<L</utf8n_to_uvchr_error>> but it takes an extra parameter
1402 placed after all the others, C<msgs>.  If this parameter is 0, this function
1403 behaves identically to C<L</utf8n_to_uvchr_error>>.  Otherwise, C<msgs> should
1404 be a pointer to an C<AV *> variable, in which this function creates a new AV to
1405 contain any appropriate messages.  The elements of the array are ordered so
1406 that the first message that would have been displayed is in the 0th element,
1407 and so on.  Each element is a hash with three key-value pairs, as follows:
1408
1409 =over 4
1410
1411 =item C<text>
1412
1413 The text of the message as a C<SVpv>.
1414
1415 =item C<warn_categories>
1416
1417 The warning category (or categories) packed into a C<SVuv>.
1418
1419 =item C<flag>
1420
1421 A single flag bit associated with this message, in a C<SVuv>.
1422 The bit corresponds to some bit in the C<*errors> return value,
1423 such as C<UTF8_GOT_LONG>.
1424
1425 =back
1426
1427 It's important to note that specifying this parameter as non-null will cause
1428 any warnings this function would otherwise generate to be suppressed, and
1429 instead be placed in C<*msgs>.  The caller can check the lexical warnings state
1430 (or not) when choosing what to do with the returned messages.
1431
1432 If the flag C<UTF8_CHECK_ONLY> is passed, no warnings are generated, and hence
1433 no AV is created.
1434
1435 The caller, of course, is responsible for freeing any returned AV.
1436
1437 =cut
1438 */
1439
1440 UV
1441 Perl_utf8n_to_uvchr_msgs(pTHX_ const U8 *s,
1442                                STRLEN curlen,
1443                                STRLEN *retlen,
1444                                const U32 flags,
1445                                U32 * errors,
1446                                AV ** msgs)
1447 {
1448     const U8 * const s0 = s;
1449     const U8 * send = s0 + curlen;
1450     U32 possible_problems = 0;  /* A bit is set here for each potential problem
1451                                    found as we go along */
1452     UV uv;
1453     STRLEN expectlen   = 0;     /* How long should this sequence be?
1454                                    (initialized to silence compilers' wrong
1455                                    warning) */
1456     STRLEN avail_len   = 0;     /* When input is too short, gives what that is */
1457     U32 discard_errors = 0;     /* Used to save branches when 'errors' is NULL;
1458                                    this gets set and discarded */
1459
1460     /* The below are used only if there is both an overlong malformation and a
1461      * too short one.  Otherwise the first two are set to 's0' and 'send', and
1462      * the third not used at all */
1463     U8 * adjusted_s0 = (U8 *) s0;
1464     U8 temp_char_buf[UTF8_MAXBYTES + 1]; /* Used to avoid a Newx in this
1465                                             routine; see [perl #130921] */
1466     UV uv_so_far = 0;   /* (Initialized to silence compilers' wrong warning) */
1467
1468     UV state = 0;
1469
1470     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1471
1472     if (errors) {
1473         *errors = 0;
1474     }
1475     else {
1476         errors = &discard_errors;
1477     }
1478
1479     /* The order of malformation tests here is important.  We should consume as
1480      * few bytes as possible in order to not skip any valid character.  This is
1481      * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
1482      * http://unicode.org/reports/tr36 for more discussion as to why.  For
1483      * example, once we've done a UTF8SKIP, we can tell the expected number of
1484      * bytes, and could fail right off the bat if the input parameters indicate
1485      * that there are too few available.  But it could be that just that first
1486      * byte is garbled, and the intended character occupies fewer bytes.  If we
1487      * blindly assumed that the first byte is correct, and skipped based on
1488      * that number, we could skip over a valid input character.  So instead, we
1489      * always examine the sequence byte-by-byte.
1490      *
1491      * We also should not consume too few bytes, otherwise someone could inject
1492      * things.  For example, an input could be deliberately designed to
1493      * overflow, and if this code bailed out immediately upon discovering that,
1494      * returning to the caller C<*retlen> pointing to the very next byte (one
1495      * which is actually part of of the overflowing sequence), that could look
1496      * legitimate to the caller, which could discard the initial partial
1497      * sequence and process the rest, inappropriately.
1498      *
1499      * Some possible input sequences are malformed in more than one way.  This
1500      * function goes to lengths to try to find all of them.  This is necessary
1501      * for correctness, as the inputs may allow one malformation but not
1502      * another, and if we abandon searching for others after finding the
1503      * allowed one, we could allow in something that shouldn't have been.
1504      */
1505
1506     if (UNLIKELY(curlen == 0)) {
1507         possible_problems |= UTF8_GOT_EMPTY;
1508         curlen = 0;
1509         uv = UNICODE_REPLACEMENT;
1510         goto ready_to_handle_errors;
1511     }
1512
1513     expectlen = UTF8SKIP(s);
1514
1515     /* A well-formed UTF-8 character, as the vast majority of calls to this
1516      * function will be for, has this expected length.  For efficiency, set
1517      * things up here to return it.  It will be overriden only in those rare
1518      * cases where a malformation is found */
1519     if (retlen) {
1520         *retlen = expectlen;
1521     }
1522
1523     /* An invariant is trivially well-formed */
1524     if (UTF8_IS_INVARIANT(*s0)) {
1525         return *s0;
1526     }
1527
1528 #ifndef EBCDIC
1529
1530     /* Measurements show that this dfa is somewhat faster than the regular code
1531      * below, so use it first, dropping down for the non-normal cases. */
1532
1533 #  define PERL_UTF8_DECODE_REJECT 12
1534
1535     while (s < send && LIKELY(state != PERL_UTF8_DECODE_REJECT)) {
1536         UV type = dfa_tab_for_perl[*s];
1537
1538         if (state != 0) {
1539             uv = (*s & 0x3fu) | (uv << UTF_ACCUMULATION_SHIFT);
1540             state = dfa_tab_for_perl[256 + state + type];
1541         }
1542         else {
1543             uv = (0xff >> type) & (*s);
1544             state = dfa_tab_for_perl[256 + type];
1545         }
1546
1547         if (state == 0) {
1548
1549             /* If this could be a code point that the flags don't allow (the first
1550             * surrogate is the first such possible one), delve further, but we already
1551             * have calculated 'uv' */
1552             if (  (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1553                            |UTF8_WARN_ILLEGAL_INTERCHANGE))
1554                 && uv >= UNICODE_SURROGATE_FIRST)
1555             {
1556                 curlen = s + 1 - s0;
1557                 goto got_uv;
1558             }
1559
1560             return uv;
1561         }
1562
1563         s++;
1564     }
1565
1566     /* Here, is some sort of failure.  Use the full mechanism */
1567
1568     uv = *s0;
1569
1570 #endif
1571
1572     /* A continuation character can't start a valid sequence */
1573     if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
1574         possible_problems |= UTF8_GOT_CONTINUATION;
1575         curlen = 1;
1576         uv = UNICODE_REPLACEMENT;
1577         goto ready_to_handle_errors;
1578     }
1579
1580     /* Here is not a continuation byte, nor an invariant.  The only thing left
1581      * is a start byte (possibly for an overlong).  (We can't use UTF8_IS_START
1582      * because it excludes start bytes like \xC0 that always lead to
1583      * overlongs.) */
1584
1585     /* Convert to I8 on EBCDIC (no-op on ASCII), then remove the leading bits
1586      * that indicate the number of bytes in the character's whole UTF-8
1587      * sequence, leaving just the bits that are part of the value.  */
1588     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
1589
1590     /* Setup the loop end point, making sure to not look past the end of the
1591      * input string, and flag it as too short if the size isn't big enough. */
1592     if (UNLIKELY(curlen < expectlen)) {
1593         possible_problems |= UTF8_GOT_SHORT;
1594         avail_len = curlen;
1595     }
1596     else {
1597         send = (U8*) s0 + expectlen;
1598     }
1599
1600     /* Now, loop through the remaining bytes in the character's sequence,
1601      * accumulating each into the working value as we go. */
1602     for (s = s0 + 1; s < send; s++) {
1603         if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
1604             uv = UTF8_ACCUMULATE(uv, *s);
1605             continue;
1606         }
1607
1608         /* Here, found a non-continuation before processing all expected bytes.
1609          * This byte indicates the beginning of a new character, so quit, even
1610          * if allowing this malformation. */
1611         possible_problems |= UTF8_GOT_NON_CONTINUATION;
1612         break;
1613     } /* End of loop through the character's bytes */
1614
1615     /* Save how many bytes were actually in the character */
1616     curlen = s - s0;
1617
1618     /* Note that there are two types of too-short malformation.  One is when
1619      * there is actual wrong data before the normal termination of the
1620      * sequence.  The other is that the sequence wasn't complete before the end
1621      * of the data we are allowed to look at, based on the input 'curlen'.
1622      * This means that we were passed data for a partial character, but it is
1623      * valid as far as we saw.  The other is definitely invalid.  This
1624      * distinction could be important to a caller, so the two types are kept
1625      * separate.
1626      *
1627      * A convenience macro that matches either of the too-short conditions.  */
1628 #   define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
1629
1630     if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
1631         uv_so_far = uv;
1632         uv = UNICODE_REPLACEMENT;
1633     }
1634
1635     /* Check for overflow.  The algorithm requires us to not look past the end
1636      * of the current character, even if partial, so the upper limit is 's' */
1637     if (UNLIKELY(0 < does_utf8_overflow(s0, s,
1638                                          1 /* Do consider overlongs */
1639                                         )))
1640     {
1641         possible_problems |= UTF8_GOT_OVERFLOW;
1642         uv = UNICODE_REPLACEMENT;
1643     }
1644
1645     /* Check for overlong.  If no problems so far, 'uv' is the correct code
1646      * point value.  Simply see if it is expressible in fewer bytes.  Otherwise
1647      * we must look at the UTF-8 byte sequence itself to see if it is for an
1648      * overlong */
1649     if (     (   LIKELY(! possible_problems)
1650               && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv)))
1651         || (       UNLIKELY(possible_problems)
1652             && (   UNLIKELY(! UTF8_IS_START(*s0))
1653                 || (   curlen > 1
1654                     && UNLIKELY(0 < is_utf8_overlong_given_start_byte_ok(s0,
1655                                                                 s - s0))))))
1656     {
1657         possible_problems |= UTF8_GOT_LONG;
1658
1659         if (   UNLIKELY(   possible_problems & UTF8_GOT_TOO_SHORT)
1660
1661                           /* The calculation in the 'true' branch of this 'if'
1662                            * below won't work if overflows, and isn't needed
1663                            * anyway.  Further below we handle all overflow
1664                            * cases */
1665             &&   LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW)))
1666         {
1667             UV min_uv = uv_so_far;
1668             STRLEN i;
1669
1670             /* Here, the input is both overlong and is missing some trailing
1671              * bytes.  There is no single code point it could be for, but there
1672              * may be enough information present to determine if what we have
1673              * so far is for an unallowed code point, such as for a surrogate.
1674              * The code further below has the intelligence to determine this,
1675              * but just for non-overlong UTF-8 sequences.  What we do here is
1676              * calculate the smallest code point the input could represent if
1677              * there were no too short malformation.  Then we compute and save
1678              * the UTF-8 for that, which is what the code below looks at
1679              * instead of the raw input.  It turns out that the smallest such
1680              * code point is all we need. */
1681             for (i = curlen; i < expectlen; i++) {
1682                 min_uv = UTF8_ACCUMULATE(min_uv,
1683                                      I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
1684             }
1685
1686             adjusted_s0 = temp_char_buf;
1687             (void) uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
1688         }
1689     }
1690
1691   got_uv:
1692
1693     /* Here, we have found all the possible problems, except for when the input
1694      * is for a problematic code point not allowed by the input parameters. */
1695
1696                                 /* uv is valid for overlongs */
1697     if (   (   (      LIKELY(! (possible_problems & ~UTF8_GOT_LONG))
1698
1699                       /* isn't problematic if < this */
1700                    && uv >= UNICODE_SURROGATE_FIRST)
1701             || (   UNLIKELY(possible_problems)
1702
1703                           /* if overflow, we know without looking further
1704                            * precisely which of the problematic types it is,
1705                            * and we deal with those in the overflow handling
1706                            * code */
1707                 && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW))
1708                 && (   isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0)
1709                     || UNLIKELY(isUTF8_PERL_EXTENDED(s0)))))
1710         && ((flags & ( UTF8_DISALLOW_NONCHAR
1711                       |UTF8_DISALLOW_SURROGATE
1712                       |UTF8_DISALLOW_SUPER
1713                       |UTF8_DISALLOW_PERL_EXTENDED
1714                       |UTF8_WARN_NONCHAR
1715                       |UTF8_WARN_SURROGATE
1716                       |UTF8_WARN_SUPER
1717                       |UTF8_WARN_PERL_EXTENDED))))
1718     {
1719         /* If there were no malformations, or the only malformation is an
1720          * overlong, 'uv' is valid */
1721         if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) {
1722             if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
1723                 possible_problems |= UTF8_GOT_SURROGATE;
1724             }
1725             else if (UNLIKELY(uv > PERL_UNICODE_MAX)) {
1726                 possible_problems |= UTF8_GOT_SUPER;
1727             }
1728             else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) {
1729                 possible_problems |= UTF8_GOT_NONCHAR;
1730             }
1731         }
1732         else {  /* Otherwise, need to look at the source UTF-8, possibly
1733                    adjusted to be non-overlong */
1734
1735             if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0)
1736                                 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
1737             {
1738                 possible_problems |= UTF8_GOT_SUPER;
1739             }
1740             else if (curlen > 1) {
1741                 if (UNLIKELY(IS_UTF8_2_BYTE_SUPER(
1742                                       NATIVE_UTF8_TO_I8(*adjusted_s0),
1743                                       NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
1744                 {
1745                     possible_problems |= UTF8_GOT_SUPER;
1746                 }
1747                 else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(
1748                                       NATIVE_UTF8_TO_I8(*adjusted_s0),
1749                                       NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
1750                 {
1751                     possible_problems |= UTF8_GOT_SURROGATE;
1752                 }
1753             }
1754
1755             /* We need a complete well-formed UTF-8 character to discern
1756              * non-characters, so can't look for them here */
1757         }
1758     }
1759
1760   ready_to_handle_errors:
1761
1762     /* At this point:
1763      * curlen               contains the number of bytes in the sequence that
1764      *                      this call should advance the input by.
1765      * avail_len            gives the available number of bytes passed in, but
1766      *                      only if this is less than the expected number of
1767      *                      bytes, based on the code point's start byte.
1768      * possible_problems'   is 0 if there weren't any problems; otherwise a bit
1769      *                      is set in it for each potential problem found.
1770      * uv                   contains the code point the input sequence
1771      *                      represents; or if there is a problem that prevents
1772      *                      a well-defined value from being computed, it is
1773      *                      some subsitute value, typically the REPLACEMENT
1774      *                      CHARACTER.
1775      * s0                   points to the first byte of the character
1776      * s                    points to just after were we left off processing
1777      *                      the character
1778      * send                 points to just after where that character should
1779      *                      end, based on how many bytes the start byte tells
1780      *                      us should be in it, but no further than s0 +
1781      *                      avail_len
1782      */
1783
1784     if (UNLIKELY(possible_problems)) {
1785         bool disallowed = FALSE;
1786         const U32 orig_problems = possible_problems;
1787
1788         if (msgs) {
1789             *msgs = NULL;
1790         }
1791
1792         while (possible_problems) { /* Handle each possible problem */
1793             UV pack_warn = 0;
1794             char * message = NULL;
1795             U32 this_flag_bit = 0;
1796
1797             /* Each 'if' clause handles one problem.  They are ordered so that
1798              * the first ones' messages will be displayed before the later
1799              * ones; this is kinda in decreasing severity order.  But the
1800              * overlong must come last, as it changes 'uv' looked at by the
1801              * others */
1802             if (possible_problems & UTF8_GOT_OVERFLOW) {
1803
1804                 /* Overflow means also got a super and are using Perl's
1805                  * extended UTF-8, but we handle all three cases here */
1806                 possible_problems
1807                   &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER|UTF8_GOT_PERL_EXTENDED);
1808                 *errors |= UTF8_GOT_OVERFLOW;
1809
1810                 /* But the API says we flag all errors found */
1811                 if (flags & (UTF8_WARN_SUPER|UTF8_DISALLOW_SUPER)) {
1812                     *errors |= UTF8_GOT_SUPER;
1813                 }
1814                 if (flags
1815                         & (UTF8_WARN_PERL_EXTENDED|UTF8_DISALLOW_PERL_EXTENDED))
1816                 {
1817                     *errors |= UTF8_GOT_PERL_EXTENDED;
1818                 }
1819
1820                 /* Disallow if any of the three categories say to */
1821                 if ( ! (flags &   UTF8_ALLOW_OVERFLOW)
1822                     || (flags & ( UTF8_DISALLOW_SUPER
1823                                  |UTF8_DISALLOW_PERL_EXTENDED)))
1824                 {
1825                     disallowed = TRUE;
1826                 }
1827
1828                 /* Likewise, warn if any say to */
1829                 if (  ! (flags & UTF8_ALLOW_OVERFLOW)
1830                     ||  (flags & (UTF8_WARN_SUPER|UTF8_WARN_PERL_EXTENDED)))
1831                 {
1832
1833                     /* The warnings code explicitly says it doesn't handle the
1834                      * case of packWARN2 and two categories which have
1835                      * parent-child relationship.  Even if it works now to
1836                      * raise the warning if either is enabled, it wouldn't
1837                      * necessarily do so in the future.  We output (only) the
1838                      * most dire warning */
1839                     if (! (flags & UTF8_CHECK_ONLY)) {
1840                         if (msgs || ckWARN_d(WARN_UTF8)) {
1841                             pack_warn = packWARN(WARN_UTF8);
1842                         }
1843                         else if (msgs || ckWARN_d(WARN_NON_UNICODE)) {
1844                             pack_warn = packWARN(WARN_NON_UNICODE);
1845                         }
1846                         if (pack_warn) {
1847                             message = Perl_form(aTHX_ "%s: %s (overflows)",
1848                                             malformed_text,
1849                                             _byte_dump_string(s0, curlen, 0));
1850                             this_flag_bit = UTF8_GOT_OVERFLOW;
1851                         }
1852                     }
1853                 }
1854             }
1855             else if (possible_problems & UTF8_GOT_EMPTY) {
1856                 possible_problems &= ~UTF8_GOT_EMPTY;
1857                 *errors |= UTF8_GOT_EMPTY;
1858
1859                 if (! (flags & UTF8_ALLOW_EMPTY)) {
1860
1861                     /* This so-called malformation is now treated as a bug in
1862                      * the caller.  If you have nothing to decode, skip calling
1863                      * this function */
1864                     assert(0);
1865
1866                     disallowed = TRUE;
1867                     if (  (msgs
1868                         || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1869                     {
1870                         pack_warn = packWARN(WARN_UTF8);
1871                         message = Perl_form(aTHX_ "%s (empty string)",
1872                                                    malformed_text);
1873                         this_flag_bit = UTF8_GOT_EMPTY;
1874                     }
1875                 }
1876             }
1877             else if (possible_problems & UTF8_GOT_CONTINUATION) {
1878                 possible_problems &= ~UTF8_GOT_CONTINUATION;
1879                 *errors |= UTF8_GOT_CONTINUATION;
1880
1881                 if (! (flags & UTF8_ALLOW_CONTINUATION)) {
1882                     disallowed = TRUE;
1883                     if ((   msgs
1884                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1885                     {
1886                         pack_warn = packWARN(WARN_UTF8);
1887                         message = Perl_form(aTHX_
1888                                 "%s: %s (unexpected continuation byte 0x%02x,"
1889                                 " with no preceding start byte)",
1890                                 malformed_text,
1891                                 _byte_dump_string(s0, 1, 0), *s0);
1892                         this_flag_bit = UTF8_GOT_CONTINUATION;
1893                     }
1894                 }
1895             }
1896             else if (possible_problems & UTF8_GOT_SHORT) {
1897                 possible_problems &= ~UTF8_GOT_SHORT;
1898                 *errors |= UTF8_GOT_SHORT;
1899
1900                 if (! (flags & UTF8_ALLOW_SHORT)) {
1901                     disallowed = TRUE;
1902                     if ((   msgs
1903                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1904                     {
1905                         pack_warn = packWARN(WARN_UTF8);
1906                         message = Perl_form(aTHX_
1907                              "%s: %s (too short; %d byte%s available, need %d)",
1908                              malformed_text,
1909                              _byte_dump_string(s0, send - s0, 0),
1910                              (int)avail_len,
1911                              avail_len == 1 ? "" : "s",
1912                              (int)expectlen);
1913                         this_flag_bit = UTF8_GOT_SHORT;
1914                     }
1915                 }
1916
1917             }
1918             else if (possible_problems & UTF8_GOT_NON_CONTINUATION) {
1919                 possible_problems &= ~UTF8_GOT_NON_CONTINUATION;
1920                 *errors |= UTF8_GOT_NON_CONTINUATION;
1921
1922                 if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) {
1923                     disallowed = TRUE;
1924                     if ((   msgs
1925                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1926                     {
1927
1928                         /* If we don't know for sure that the input length is
1929                          * valid, avoid as much as possible reading past the
1930                          * end of the buffer */
1931                         int printlen = (flags & _UTF8_NO_CONFIDENCE_IN_CURLEN)
1932                                        ? s - s0
1933                                        : send - s0;
1934                         pack_warn = packWARN(WARN_UTF8);
1935                         message = Perl_form(aTHX_ "%s",
1936                             unexpected_non_continuation_text(s0,
1937                                                             printlen,
1938                                                             s - s0,
1939                                                             (int) expectlen));
1940                         this_flag_bit = UTF8_GOT_NON_CONTINUATION;
1941                     }
1942                 }
1943             }
1944             else if (possible_problems & UTF8_GOT_SURROGATE) {
1945                 possible_problems &= ~UTF8_GOT_SURROGATE;
1946
1947                 if (flags & UTF8_WARN_SURROGATE) {
1948                     *errors |= UTF8_GOT_SURROGATE;
1949
1950                     if (   ! (flags & UTF8_CHECK_ONLY)
1951                         && (msgs || ckWARN_d(WARN_SURROGATE)))
1952                     {
1953                         pack_warn = packWARN(WARN_SURROGATE);
1954
1955                         /* These are the only errors that can occur with a
1956                         * surrogate when the 'uv' isn't valid */
1957                         if (orig_problems & UTF8_GOT_TOO_SHORT) {
1958                             message = Perl_form(aTHX_
1959                                     "UTF-16 surrogate (any UTF-8 sequence that"
1960                                     " starts with \"%s\" is for a surrogate)",
1961                                     _byte_dump_string(s0, curlen, 0));
1962                         }
1963                         else {
1964                             message = Perl_form(aTHX_ surrogate_cp_format, uv);
1965                         }
1966                         this_flag_bit = UTF8_GOT_SURROGATE;
1967                     }
1968                 }
1969
1970                 if (flags & UTF8_DISALLOW_SURROGATE) {
1971                     disallowed = TRUE;
1972                     *errors |= UTF8_GOT_SURROGATE;
1973                 }
1974             }
1975             else if (possible_problems & UTF8_GOT_SUPER) {
1976                 possible_problems &= ~UTF8_GOT_SUPER;
1977
1978                 if (flags & UTF8_WARN_SUPER) {
1979                     *errors |= UTF8_GOT_SUPER;
1980
1981                     if (   ! (flags & UTF8_CHECK_ONLY)
1982                         && (msgs || ckWARN_d(WARN_NON_UNICODE)))
1983                     {
1984                         pack_warn = packWARN(WARN_NON_UNICODE);
1985
1986                         if (orig_problems & UTF8_GOT_TOO_SHORT) {
1987                             message = Perl_form(aTHX_
1988                                     "Any UTF-8 sequence that starts with"
1989                                     " \"%s\" is for a non-Unicode code point,"
1990                                     " may not be portable",
1991                                     _byte_dump_string(s0, curlen, 0));
1992                         }
1993                         else {
1994                             message = Perl_form(aTHX_ super_cp_format, uv);
1995                         }
1996                         this_flag_bit = UTF8_GOT_SUPER;
1997                     }
1998                 }
1999
2000                 /* Test for Perl's extended UTF-8 after the regular SUPER ones,
2001                  * and before possibly bailing out, so that the more dire
2002                  * warning will override the regular one. */
2003                 if (UNLIKELY(isUTF8_PERL_EXTENDED(s0))) {
2004                     if (  ! (flags & UTF8_CHECK_ONLY)
2005                         &&  (flags & (UTF8_WARN_PERL_EXTENDED|UTF8_WARN_SUPER))
2006                         &&  (msgs || ckWARN_d(WARN_NON_UNICODE)))
2007                     {
2008                         pack_warn = packWARN(WARN_NON_UNICODE);
2009
2010                         /* If it is an overlong that evaluates to a code point
2011                          * that doesn't have to use the Perl extended UTF-8, it
2012                          * still used it, and so we output a message that
2013                          * doesn't refer to the code point.  The same is true
2014                          * if there was a SHORT malformation where the code
2015                          * point is not valid.  In that case, 'uv' will have
2016                          * been set to the REPLACEMENT CHAR, and the message
2017                          * below without the code point in it will be selected
2018                          * */
2019                         if (UNICODE_IS_PERL_EXTENDED(uv)) {
2020                             message = Perl_form(aTHX_
2021                                             perl_extended_cp_format, uv);
2022                         }
2023                         else {
2024                             message = Perl_form(aTHX_
2025                                         "Any UTF-8 sequence that starts with"
2026                                         " \"%s\" is a Perl extension, and"
2027                                         " so is not portable",
2028                                         _byte_dump_string(s0, curlen, 0));
2029                         }
2030                         this_flag_bit = UTF8_GOT_PERL_EXTENDED;
2031                     }
2032
2033                     if (flags & ( UTF8_WARN_PERL_EXTENDED
2034                                  |UTF8_DISALLOW_PERL_EXTENDED))
2035                     {
2036                         *errors |= UTF8_GOT_PERL_EXTENDED;
2037
2038                         if (flags & UTF8_DISALLOW_PERL_EXTENDED) {
2039                             disallowed = TRUE;
2040                         }
2041                     }
2042                 }
2043
2044                 if (flags & UTF8_DISALLOW_SUPER) {
2045                     *errors |= UTF8_GOT_SUPER;
2046                     disallowed = TRUE;
2047                 }
2048             }
2049             else if (possible_problems & UTF8_GOT_NONCHAR) {
2050                 possible_problems &= ~UTF8_GOT_NONCHAR;
2051
2052                 if (flags & UTF8_WARN_NONCHAR) {
2053                     *errors |= UTF8_GOT_NONCHAR;
2054
2055                     if (  ! (flags & UTF8_CHECK_ONLY)
2056                         && (msgs || ckWARN_d(WARN_NONCHAR)))
2057                     {
2058                         /* The code above should have guaranteed that we don't
2059                          * get here with errors other than overlong */
2060                         assert (! (orig_problems
2061                                         & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR)));
2062
2063                         pack_warn = packWARN(WARN_NONCHAR);
2064                         message = Perl_form(aTHX_ nonchar_cp_format, uv);
2065                         this_flag_bit = UTF8_GOT_NONCHAR;
2066                     }
2067                 }
2068
2069                 if (flags & UTF8_DISALLOW_NONCHAR) {
2070                     disallowed = TRUE;
2071                     *errors |= UTF8_GOT_NONCHAR;
2072                 }
2073             }
2074             else if (possible_problems & UTF8_GOT_LONG) {
2075                 possible_problems &= ~UTF8_GOT_LONG;
2076                 *errors |= UTF8_GOT_LONG;
2077
2078                 if (flags & UTF8_ALLOW_LONG) {
2079
2080                     /* We don't allow the actual overlong value, unless the
2081                      * special extra bit is also set */
2082                     if (! (flags & (   UTF8_ALLOW_LONG_AND_ITS_VALUE
2083                                     & ~UTF8_ALLOW_LONG)))
2084                     {
2085                         uv = UNICODE_REPLACEMENT;
2086                     }
2087                 }
2088                 else {
2089                     disallowed = TRUE;
2090
2091                     if ((   msgs
2092                          || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
2093                     {
2094                         pack_warn = packWARN(WARN_UTF8);
2095
2096                         /* These error types cause 'uv' to be something that
2097                          * isn't what was intended, so can't use it in the
2098                          * message.  The other error types either can't
2099                          * generate an overlong, or else the 'uv' is valid */
2100                         if (orig_problems &
2101                                         (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
2102                         {
2103                             message = Perl_form(aTHX_
2104                                     "%s: %s (any UTF-8 sequence that starts"
2105                                     " with \"%s\" is overlong which can and"
2106                                     " should be represented with a"
2107                                     " different, shorter sequence)",
2108                                     malformed_text,
2109                                     _byte_dump_string(s0, send - s0, 0),
2110                                     _byte_dump_string(s0, curlen, 0));
2111                         }
2112                         else {
2113                             U8 tmpbuf[UTF8_MAXBYTES+1];
2114                             const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf,
2115                                                                         uv, 0);
2116                             /* Don't use U+ for non-Unicode code points, which
2117                              * includes those in the Latin1 range */
2118                             const char * preface = (    uv > PERL_UNICODE_MAX
2119 #ifdef EBCDIC
2120                                                      || uv <= 0xFF
2121 #endif
2122                                                     )
2123                                                    ? "0x"
2124                                                    : "U+";
2125                             message = Perl_form(aTHX_
2126                                 "%s: %s (overlong; instead use %s to represent"
2127                                 " %s%0*" UVXf ")",
2128                                 malformed_text,
2129                                 _byte_dump_string(s0, send - s0, 0),
2130                                 _byte_dump_string(tmpbuf, e - tmpbuf, 0),
2131                                 preface,
2132                                 ((uv < 256) ? 2 : 4), /* Field width of 2 for
2133                                                          small code points */
2134                                 UNI_TO_NATIVE(uv));
2135                         }
2136                         this_flag_bit = UTF8_GOT_LONG;
2137                     }
2138                 }
2139             } /* End of looking through the possible flags */
2140
2141             /* Display the message (if any) for the problem being handled in
2142              * this iteration of the loop */
2143             if (message) {
2144                 if (msgs) {
2145                     SV* msg_sv = newSVpv(message, 0);
2146                     SV* category_sv = newSVuv(pack_warn);
2147                     SV* flag_bit_sv = newSVuv(this_flag_bit);
2148                     HV* msg_hv = newHV();
2149
2150                     assert(this_flag_bit);
2151
2152                     if (*msgs == NULL) {
2153                         *msgs = newAV();
2154                     }
2155
2156                     hv_stores(msg_hv, "text", msg_sv);
2157                     hv_stores(msg_hv, "warn_categories",  category_sv);
2158                     hv_stores(msg_hv, "flag_bit", flag_bit_sv);
2159
2160                     av_push(*msgs, newRV_noinc((SV*)msg_hv));
2161                 }
2162                 else if (PL_op)
2163                     Perl_warner(aTHX_ pack_warn, "%s in %s", message,
2164                                                  OP_DESC(PL_op));
2165                 else
2166                     Perl_warner(aTHX_ pack_warn, "%s", message);
2167             }
2168         }   /* End of 'while (possible_problems)' */
2169
2170         /* Since there was a possible problem, the returned length may need to
2171          * be changed from the one stored at the beginning of this function.
2172          * Instead of trying to figure out if that's needed, just do it. */
2173         if (retlen) {
2174             *retlen = curlen;
2175         }
2176
2177         if (disallowed) {
2178             if (flags & UTF8_CHECK_ONLY && retlen) {
2179                 *retlen = ((STRLEN) -1);
2180             }
2181             return 0;
2182         }
2183     }
2184
2185     return UNI_TO_NATIVE(uv);
2186 }
2187
2188 /*
2189 =for apidoc utf8_to_uvchr_buf
2190
2191 Returns the native code point of the first character in the string C<s> which
2192 is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
2193 C<*retlen> will be set to the length, in bytes, of that character.
2194
2195 If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
2196 enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
2197 C<NULL>) to -1.  If those warnings are off, the computed value, if well-defined
2198 (or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
2199 C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
2200 the next possible position in C<s> that could begin a non-malformed character.
2201 See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
2202 returned.
2203
2204 =cut
2205
2206 Also implemented as a macro in utf8.h
2207
2208 */
2209
2210
2211 UV
2212 Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
2213 {
2214     PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
2215
2216     assert(s < send);
2217
2218     return utf8n_to_uvchr(s, send - s, retlen,
2219                      ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
2220 }
2221
2222 /* This is marked as deprecated
2223  *
2224 =for apidoc utf8_to_uvuni_buf
2225
2226 Only in very rare circumstances should code need to be dealing in Unicode
2227 (as opposed to native) code points.  In those few cases, use
2228 C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>> instead.
2229
2230 Returns the Unicode (not-native) code point of the first character in the
2231 string C<s> which
2232 is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
2233 C<retlen> will be set to the length, in bytes, of that character.
2234
2235 If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
2236 enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
2237 NULL) to -1.  If those warnings are off, the computed value if well-defined (or
2238 the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
2239 is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
2240 next possible position in C<s> that could begin a non-malformed character.
2241 See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
2242
2243 =cut
2244 */
2245
2246 UV
2247 Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
2248 {
2249     PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
2250
2251     assert(send > s);
2252
2253     return NATIVE_TO_UNI(utf8_to_uvchr_buf(s, send, retlen));
2254 }
2255
2256 /*
2257 =for apidoc utf8_length
2258
2259 Returns the number of characters in the sequence of UTF-8-encoded bytes starting
2260 at C<s> and ending at the byte just before C<e>.  If <s> and <e> point to the
2261 same place, it returns 0 with no warning raised.
2262
2263 If C<e E<lt> s> or if the scan would end up past C<e>, it raises a UTF8 warning
2264 and returns the number of valid characters.
2265
2266 =cut
2267 */
2268
2269 STRLEN
2270 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
2271 {
2272     STRLEN len = 0;
2273
2274     PERL_ARGS_ASSERT_UTF8_LENGTH;
2275
2276     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
2277      * the bitops (especially ~) can create illegal UTF-8.
2278      * In other words: in Perl UTF-8 is not just for Unicode. */
2279
2280     if (e < s)
2281         goto warn_and_return;
2282     while (s < e) {
2283         s += UTF8SKIP(s);
2284         len++;
2285     }
2286
2287     if (e != s) {
2288         len--;
2289         warn_and_return:
2290         if (PL_op)
2291             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2292                              "%s in %s", unees, OP_DESC(PL_op));
2293         else
2294             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
2295     }
2296
2297     return len;
2298 }
2299
2300 /*
2301 =for apidoc bytes_cmp_utf8
2302
2303 Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
2304 sequence of characters (stored as UTF-8)
2305 in C<u>, C<ulen>.  Returns 0 if they are
2306 equal, -1 or -2 if the first string is less than the second string, +1 or +2
2307 if the first string is greater than the second string.
2308
2309 -1 or +1 is returned if the shorter string was identical to the start of the
2310 longer string.  -2 or +2 is returned if
2311 there was a difference between characters
2312 within the strings.
2313
2314 =cut
2315 */
2316
2317 int
2318 Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
2319 {
2320     const U8 *const bend = b + blen;
2321     const U8 *const uend = u + ulen;
2322
2323     PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
2324
2325     while (b < bend && u < uend) {
2326         U8 c = *u++;
2327         if (!UTF8_IS_INVARIANT(c)) {
2328             if (UTF8_IS_DOWNGRADEABLE_START(c)) {
2329                 if (u < uend) {
2330                     U8 c1 = *u++;
2331                     if (UTF8_IS_CONTINUATION(c1)) {
2332                         c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
2333                     } else {
2334                         /* diag_listed_as: Malformed UTF-8 character%s */
2335                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2336                               "%s %s%s",
2337                               unexpected_non_continuation_text(u - 2, 2, 1, 2),
2338                               PL_op ? " in " : "",
2339                               PL_op ? OP_DESC(PL_op) : "");
2340                         return -2;
2341                     }
2342                 } else {
2343                     if (PL_op)
2344                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2345                                          "%s in %s", unees, OP_DESC(PL_op));
2346                     else
2347                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
2348                     return -2; /* Really want to return undef :-)  */
2349                 }
2350             } else {
2351                 return -2;
2352             }
2353         }
2354         if (*b != c) {
2355             return *b < c ? -2 : +2;
2356         }
2357         ++b;
2358     }
2359
2360     if (b == bend && u == uend)
2361         return 0;
2362
2363     return b < bend ? +1 : -1;
2364 }
2365
2366 /*
2367 =for apidoc utf8_to_bytes
2368
2369 Converts a string C<"s"> of length C<*lenp> from UTF-8 into native byte encoding.
2370 Unlike L</bytes_to_utf8>, this over-writes the original string, and
2371 updates C<*lenp> to contain the new length.
2372 Returns zero on failure (leaving C<"s"> unchanged) setting C<*lenp> to -1.
2373
2374 Upon successful return, the number of variants in the string can be computed by
2375 having saved the value of C<*lenp> before the call, and subtracting the
2376 after-call value of C<*lenp> from it.
2377
2378 If you need a copy of the string, see L</bytes_from_utf8>.
2379
2380 =cut
2381 */
2382
2383 U8 *
2384 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *lenp)
2385 {
2386     U8 * first_variant;
2387
2388     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
2389     PERL_UNUSED_CONTEXT;
2390
2391     /* This is a no-op if no variants at all in the input */
2392     if (is_utf8_invariant_string_loc(s, *lenp, (const U8 **) &first_variant)) {
2393         return s;
2394     }
2395
2396     {
2397         U8 * const save = s;
2398         U8 * const send = s + *lenp;
2399         U8 * d;
2400
2401         /* Nothing before the first variant needs to be changed, so start the real
2402          * work there */
2403         s = first_variant;
2404         while (s < send) {
2405             if (! UTF8_IS_INVARIANT(*s)) {
2406                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
2407                     *lenp = ((STRLEN) -1);
2408                     return 0;
2409                 }
2410                 s++;
2411             }
2412             s++;
2413         }
2414
2415         /* Is downgradable, so do it */
2416         d = s = first_variant;
2417         while (s < send) {
2418             U8 c = *s++;
2419             if (! UVCHR_IS_INVARIANT(c)) {
2420                 /* Then it is two-byte encoded */
2421                 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
2422                 s++;
2423             }
2424             *d++ = c;
2425         }
2426         *d = '\0';
2427         *lenp = d - save;
2428
2429         return save;
2430     }
2431 }
2432
2433 /*
2434 =for apidoc bytes_from_utf8
2435
2436 Converts a potentially UTF-8 encoded string C<s> of length C<*lenp> into native
2437 byte encoding.  On input, the boolean C<*is_utf8p> gives whether or not C<s> is
2438 actually encoded in UTF-8.
2439
2440 Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, this is non-destructive of
2441 the input string.
2442
2443 Do nothing if C<*is_utf8p> is 0, or if there are code points in the string
2444 not expressible in native byte encoding.  In these cases, C<*is_utf8p> and
2445 C<*lenp> are unchanged, and the return value is the original C<s>.
2446
2447 Otherwise, C<*is_utf8p> is set to 0, and the return value is a pointer to a
2448 newly created string containing a downgraded copy of C<s>, and whose length is
2449 returned in C<*lenp>, updated.  The new string is C<NUL>-terminated.
2450
2451 Upon successful return, the number of variants in the string can be computed by
2452 having saved the value of C<*lenp> before the call, and subtracting the
2453 after-call value of C<*lenp> from it.
2454
2455 =cut
2456
2457 There is a macro that avoids this function call, but this is retained for
2458 anyone who calls it with the Perl_ prefix */
2459
2460 U8 *
2461 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *lenp, bool *is_utf8p)
2462 {
2463     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
2464     PERL_UNUSED_CONTEXT;
2465
2466     return bytes_from_utf8_loc(s, lenp, is_utf8p, NULL);
2467 }
2468
2469 /*
2470 No = here because currently externally undocumented
2471 for apidoc bytes_from_utf8_loc
2472
2473 Like C<L</bytes_from_utf8>()>, but takes an extra parameter, a pointer to where
2474 to store the location of the first character in C<"s"> that cannot be
2475 converted to non-UTF8.
2476
2477 If that parameter is C<NULL>, this function behaves identically to
2478 C<bytes_from_utf8>.
2479
2480 Otherwise if C<*is_utf8p> is 0 on input, the function behaves identically to
2481 C<bytes_from_utf8>, except it also sets C<*first_non_downgradable> to C<NULL>.
2482
2483 Otherwise, the function returns a newly created C<NUL>-terminated string
2484 containing the non-UTF8 equivalent of the convertible first portion of
2485 C<"s">.  C<*lenp> is set to its length, not including the terminating C<NUL>.
2486 If the entire input string was converted, C<*is_utf8p> is set to a FALSE value,
2487 and C<*first_non_downgradable> is set to C<NULL>.
2488
2489 Otherwise, C<*first_non_downgradable> set to point to the first byte of the
2490 first character in the original string that wasn't converted.  C<*is_utf8p> is
2491 unchanged.  Note that the new string may have length 0.
2492
2493 Another way to look at it is, if C<*first_non_downgradable> is non-C<NULL> and
2494 C<*is_utf8p> is TRUE, this function starts at the beginning of C<"s"> and
2495 converts as many characters in it as possible stopping at the first one it
2496 finds that can't be converted to non-UTF-8.  C<*first_non_downgradable> is
2497 set to point to that.  The function returns the portion that could be converted
2498 in a newly created C<NUL>-terminated string, and C<*lenp> is set to its length,
2499 not including the terminating C<NUL>.  If the very first character in the
2500 original could not be converted, C<*lenp> will be 0, and the new string will
2501 contain just a single C<NUL>.  If the entire input string was converted,
2502 C<*is_utf8p> is set to FALSE and C<*first_non_downgradable> is set to C<NULL>.
2503
2504 Upon successful return, the number of variants in the converted portion of the
2505 string can be computed by having saved the value of C<*lenp> before the call,
2506 and subtracting the after-call value of C<*lenp> from it.
2507
2508 =cut
2509
2510
2511 */
2512
2513 U8 *
2514 Perl_bytes_from_utf8_loc(const U8 *s, STRLEN *lenp, bool *is_utf8p, const U8** first_unconverted)
2515 {
2516     U8 *d;
2517     const U8 *original = s;
2518     U8 *converted_start;
2519     const U8 *send = s + *lenp;
2520
2521     PERL_ARGS_ASSERT_BYTES_FROM_UTF8_LOC;
2522
2523     if (! *is_utf8p) {
2524         if (first_unconverted) {
2525             *first_unconverted = NULL;
2526         }
2527
2528         return (U8 *) original;
2529     }
2530
2531     Newx(d, (*lenp) + 1, U8);
2532
2533     converted_start = d;
2534     while (s < send) {
2535         U8 c = *s++;
2536         if (! UTF8_IS_INVARIANT(c)) {
2537
2538             /* Then it is multi-byte encoded.  If the code point is above 0xFF,
2539              * have to stop now */
2540             if (UNLIKELY (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s - 1, send))) {
2541                 if (first_unconverted) {
2542                     *first_unconverted = s - 1;
2543                     goto finish_and_return;
2544                 }
2545                 else {
2546                     Safefree(converted_start);
2547                     return (U8 *) original;
2548                 }
2549             }
2550
2551             c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
2552             s++;
2553         }
2554         *d++ = c;
2555     }
2556
2557     /* Here, converted the whole of the input */
2558     *is_utf8p = FALSE;
2559     if (first_unconverted) {
2560         *first_unconverted = NULL;
2561     }
2562
2563   finish_and_return:
2564     *d = '\0';
2565     *lenp = d - converted_start;
2566
2567     /* Trim unused space */
2568     Renew(converted_start, *lenp + 1, U8);
2569
2570     return converted_start;
2571 }
2572
2573 /*
2574 =for apidoc bytes_to_utf8
2575
2576 Converts a string C<s> of length C<*lenp> bytes from the native encoding into
2577 UTF-8.
2578 Returns a pointer to the newly-created string, and sets C<*lenp> to
2579 reflect the new length in bytes.
2580
2581 Upon successful return, the number of variants in the string can be computed by
2582 having saved the value of C<*lenp> before the call, and subtracting it from the
2583 after-call value of C<*lenp>.
2584
2585 A C<NUL> character will be written after the end of the string.
2586
2587 If you want to convert to UTF-8 from encodings other than
2588 the native (Latin1 or EBCDIC),
2589 see L</sv_recode_to_utf8>().
2590
2591 =cut
2592 */
2593
2594 U8*
2595 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *lenp)
2596 {
2597     const U8 * const send = s + (*lenp);
2598     U8 *d;
2599     U8 *dst;
2600
2601     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
2602     PERL_UNUSED_CONTEXT;
2603
2604     Newx(d, (*lenp) * 2 + 1, U8);
2605     dst = d;
2606
2607     while (s < send) {
2608         append_utf8_from_native_byte(*s, &d);
2609         s++;
2610     }
2611
2612     *d = '\0';
2613     *lenp = d-dst;
2614
2615     /* Trim unused space */
2616     Renew(dst, *lenp + 1, U8);
2617
2618     return dst;
2619 }
2620
2621 /*
2622  * Convert native (big-endian) UTF-16 to UTF-8.  For reversed (little-endian),
2623  * use utf16_to_utf8_reversed().
2624  *
2625  * UTF-16 requires 2 bytes for every code point below 0x10000; otherwise 4 bytes.
2626  * UTF-8 requires 1-3 bytes for every code point below 0x1000; otherwise 4 bytes.
2627  * UTF-EBCDIC requires 1-4 bytes for every code point below 0x1000; otherwise 4-5 bytes.
2628  *
2629  * These functions don't check for overflow.  The worst case is every code
2630  * point in the input is 2 bytes, and requires 4 bytes on output.  (If the code
2631  * is never going to run in EBCDIC, it is 2 bytes requiring 3 on output.)  Therefore the
2632  * destination must be pre-extended to 2 times the source length.
2633  *
2634  * Do not use in-place.  We optimize for native, for obvious reasons. */
2635
2636 U8*
2637 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
2638 {
2639     U8* pend;
2640     U8* dstart = d;
2641
2642     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
2643
2644     if (bytelen & 1)
2645         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %" UVuf,
2646                                                                (UV)bytelen);
2647
2648     pend = p + bytelen;
2649
2650     while (p < pend) {
2651         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
2652         p += 2;
2653         if (OFFUNI_IS_INVARIANT(uv)) {
2654             *d++ = LATIN1_TO_NATIVE((U8) uv);
2655             continue;
2656         }
2657         if (uv <= MAX_UTF8_TWO_BYTE) {
2658             *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv));
2659             *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv));
2660             continue;
2661         }
2662
2663 #define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
2664 #define LAST_HIGH_SURROGATE  0xDBFF
2665 #define FIRST_LOW_SURROGATE  0xDC00
2666 #define LAST_LOW_SURROGATE   UNICODE_SURROGATE_LAST
2667 #define FIRST_IN_PLANE1      0x10000
2668
2669         /* This assumes that most uses will be in the first Unicode plane, not
2670          * needing surrogates */
2671         if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST
2672                   && uv <= UNICODE_SURROGATE_LAST))
2673         {
2674             if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) {
2675                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
2676             }
2677             else {
2678                 UV low = (p[0] << 8) + p[1];
2679                 if (   UNLIKELY(low < FIRST_LOW_SURROGATE)
2680                     || UNLIKELY(low > LAST_LOW_SURROGATE))
2681                 {
2682                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
2683                 }
2684                 p += 2;
2685                 uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
2686                                 + (low - FIRST_LOW_SURROGATE) + FIRST_IN_PLANE1;
2687             }
2688         }
2689 #ifdef EBCDIC
2690         d = uvoffuni_to_utf8_flags(d, uv, 0);
2691 #else
2692         if (uv < FIRST_IN_PLANE1) {
2693             *d++ = (U8)(( uv >> 12)         | 0xe0);
2694             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
2695             *d++ = (U8)(( uv        & 0x3f) | 0x80);
2696             continue;
2697         }
2698         else {
2699             *d++ = (U8)(( uv >> 18)         | 0xf0);
2700             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
2701             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
2702             *d++ = (U8)(( uv        & 0x3f) | 0x80);
2703             continue;
2704         }
2705 #endif
2706     }
2707     *newlen = d - dstart;
2708     return d;
2709 }
2710
2711 /* Note: this one is slightly destructive of the source. */
2712
2713 U8*
2714 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
2715 {
2716     U8* s = (U8*)p;
2717     U8* const send = s + bytelen;
2718
2719     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
2720
2721     if (bytelen & 1)
2722         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %" UVuf,
2723                    (UV)bytelen);
2724
2725     while (s < send) {
2726         const U8 tmp = s[0];
2727         s[0] = s[1];
2728         s[1] = tmp;
2729         s += 2;
2730     }
2731     return utf16_to_utf8(p, d, bytelen, newlen);
2732 }
2733
2734 bool
2735 Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
2736 {
2737     U8 tmpbuf[UTF8_MAXBYTES+1];
2738     uvchr_to_utf8(tmpbuf, c);
2739     return _is_utf8_FOO_with_len(classnum, tmpbuf, tmpbuf + sizeof(tmpbuf));
2740 }
2741
2742 /* Internal function so we can deprecate the external one, and call
2743    this one from other deprecated functions in this file */
2744
2745 bool
2746 Perl__is_utf8_idstart(pTHX_ const U8 *p)
2747 {
2748     PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
2749
2750     if (*p == '_')
2751         return TRUE;
2752     return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
2753 }
2754
2755 bool
2756 Perl__is_uni_perl_idcont(pTHX_ UV c)
2757 {
2758     U8 tmpbuf[UTF8_MAXBYTES+1];
2759     uvchr_to_utf8(tmpbuf, c);
2760     return _is_utf8_perl_idcont_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
2761 }
2762
2763 bool
2764 Perl__is_uni_perl_idstart(pTHX_ UV c)
2765 {
2766     U8 tmpbuf[UTF8_MAXBYTES+1];
2767     uvchr_to_utf8(tmpbuf, c);
2768     return _is_utf8_perl_idstart_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
2769 }
2770
2771 UV
2772 Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp,
2773                                   const char S_or_s)
2774 {
2775     /* We have the latin1-range values compiled into the core, so just use
2776      * those, converting the result to UTF-8.  The only difference between upper
2777      * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
2778      * either "SS" or "Ss".  Which one to use is passed into the routine in
2779      * 'S_or_s' to avoid a test */
2780
2781     UV converted = toUPPER_LATIN1_MOD(c);
2782
2783     PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
2784
2785     assert(S_or_s == 'S' || S_or_s == 's');
2786
2787     if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for
2788                                              characters in this range */
2789         *p = (U8) converted;
2790         *lenp = 1;
2791         return converted;
2792     }
2793
2794     /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
2795      * which it maps to one of them, so as to only have to have one check for
2796      * it in the main case */
2797     if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
2798         switch (c) {
2799             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
2800                 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
2801                 break;
2802             case MICRO_SIGN:
2803                 converted = GREEK_CAPITAL_LETTER_MU;
2804                 break;
2805 #if    UNICODE_MAJOR_VERSION > 2                                        \
2806    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
2807                                   && UNICODE_DOT_DOT_VERSION >= 8)
2808             case LATIN_SMALL_LETTER_SHARP_S:
2809                 *(p)++ = 'S';
2810                 *p = S_or_s;
2811                 *lenp = 2;
2812                 return 'S';
2813 #endif
2814             default:
2815                 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect"
2816                                  " '%c' to map to '%c'",
2817                                  c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
2818                 NOT_REACHED; /* NOTREACHED */
2819         }
2820     }
2821
2822     *(p)++ = UTF8_TWO_BYTE_HI(converted);
2823     *p = UTF8_TWO_BYTE_LO(converted);
2824     *lenp = 2;
2825
2826     return converted;
2827 }
2828
2829 /* Call the function to convert a UTF-8 encoded character to the specified case.
2830  * Note that there may be more than one character in the result.
2831  * INP is a pointer to the first byte of the input character
2832  * OUTP will be set to the first byte of the string of changed characters.  It
2833  *      needs to have space for UTF8_MAXBYTES_CASE+1 bytes
2834  * LENP will be set to the length in bytes of the string of changed characters
2835  *
2836  * The functions return the ordinal of the first character in the string of
2837  * OUTP */
2838 #define CALL_UPPER_CASE(uv, s, d, lenp)                                     \
2839                 _to_utf8_case(uv, s, d, lenp, &PL_utf8_toupper, "ToUc", "")
2840 #define CALL_TITLE_CASE(uv, s, d, lenp)                                     \
2841                 _to_utf8_case(uv, s, d, lenp, &PL_utf8_totitle, "ToTc", "")
2842 #define CALL_LOWER_CASE(uv, s, d, lenp)                                     \
2843                 _to_utf8_case(uv, s, d, lenp, &PL_utf8_tolower, "ToLc", "")
2844
2845 /* This additionally has the input parameter 'specials', which if non-zero will
2846  * cause this to use the specials hash for folding (meaning get full case
2847  * folding); otherwise, when zero, this implies a simple case fold */
2848 #define CALL_FOLD_CASE(uv, s, d, lenp, specials)                            \
2849 _to_utf8_case(uv, s, d, lenp, &PL_utf8_tofold, "ToCf", (specials) ? "" : NULL)
2850
2851 UV
2852 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
2853 {
2854     /* Convert the Unicode character whose ordinal is <c> to its uppercase
2855      * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
2856      * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
2857      * the changed version may be longer than the original character.
2858      *
2859      * The ordinal of the first character of the changed version is returned
2860      * (but note, as explained above, that there may be more.) */
2861
2862     PERL_ARGS_ASSERT_TO_UNI_UPPER;
2863
2864     if (c < 256) {
2865         return _to_upper_title_latin1((U8) c, p, lenp, 'S');
2866     }
2867
2868     uvchr_to_utf8(p, c);
2869     return CALL_UPPER_CASE(c, p, p, lenp);
2870 }
2871
2872 UV
2873 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
2874 {
2875     PERL_ARGS_ASSERT_TO_UNI_TITLE;
2876
2877     if (c < 256) {
2878         return _to_upper_title_latin1((U8) c, p, lenp, 's');
2879     }
2880
2881     uvchr_to_utf8(p, c);
2882     return CALL_TITLE_CASE(c, p, p, lenp);
2883 }
2884
2885 STATIC U8
2886 S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp, const char dummy)
2887 {
2888     /* We have the latin1-range values compiled into the core, so just use
2889      * those, converting the result to UTF-8.  Since the result is always just
2890      * one character, we allow <p> to be NULL */
2891
2892     U8 converted = toLOWER_LATIN1(c);
2893
2894     PERL_UNUSED_ARG(dummy);
2895
2896     if (p != NULL) {
2897         if (NATIVE_BYTE_IS_INVARIANT(converted)) {
2898             *p = converted;
2899             *lenp = 1;
2900         }
2901         else {
2902             /* Result is known to always be < 256, so can use the EIGHT_BIT
2903              * macros */
2904             *p = UTF8_EIGHT_BIT_HI(converted);
2905             *(p+1) = UTF8_EIGHT_BIT_LO(converted);
2906             *lenp = 2;
2907         }
2908     }
2909     return converted;
2910 }
2911
2912 UV
2913 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
2914 {
2915     PERL_ARGS_ASSERT_TO_UNI_LOWER;
2916
2917     if (c < 256) {
2918         return to_lower_latin1((U8) c, p, lenp, 0 /* 0 is a dummy arg */ );
2919     }
2920
2921     uvchr_to_utf8(p, c);
2922     return CALL_LOWER_CASE(c, p, p, lenp);
2923 }
2924
2925 UV
2926 Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp,
2927                            const unsigned int flags)
2928 {
2929     /* Corresponds to to_lower_latin1(); <flags> bits meanings:
2930      *      FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
2931      *      FOLD_FLAGS_FULL  iff full folding is to be used;
2932      *
2933      *  Not to be used for locale folds
2934      */
2935
2936     UV converted;
2937
2938     PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
2939     PERL_UNUSED_CONTEXT;
2940
2941     assert (! (flags & FOLD_FLAGS_LOCALE));
2942
2943     if (UNLIKELY(c == MICRO_SIGN)) {
2944         converted = GREEK_SMALL_LETTER_MU;
2945     }
2946 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
2947    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
2948                                       || UNICODE_DOT_DOT_VERSION > 0)
2949     else if (   (flags & FOLD_FLAGS_FULL)
2950              && UNLIKELY(c == LATIN_SMALL_LETTER_SHARP_S))
2951     {
2952         /* If can't cross 127/128 boundary, can't return "ss"; instead return
2953          * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}")
2954          * under those circumstances. */
2955         if (flags & FOLD_FLAGS_NOMIX_ASCII) {
2956             *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
2957             Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
2958                  p, *lenp, U8);
2959             return LATIN_SMALL_LETTER_LONG_S;
2960         }
2961         else {
2962             *(p)++ = 's';
2963             *p = 's';
2964             *lenp = 2;
2965             return 's';
2966         }
2967     }
2968 #endif
2969     else { /* In this range the fold of all other characters is their lower
2970               case */
2971         converted = toLOWER_LATIN1(c);
2972     }
2973
2974     if (UVCHR_IS_INVARIANT(converted)) {
2975         *p = (U8) converted;
2976         *lenp = 1;
2977     }
2978     else {
2979         *(p)++ = UTF8_TWO_BYTE_HI(converted);
2980         *p = UTF8_TWO_BYTE_LO(converted);
2981         *lenp = 2;
2982     }
2983
2984     return converted;
2985 }
2986
2987 UV
2988 Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
2989 {
2990
2991     /* Not currently externally documented, and subject to change
2992      *  <flags> bits meanings:
2993      *      FOLD_FLAGS_FULL  iff full folding is to be used;
2994      *      FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
2995      *                        locale are to be used.
2996      *      FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
2997      */
2998
2999     PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
3000
3001     if (flags & FOLD_FLAGS_LOCALE) {
3002         /* Treat a UTF-8 locale as not being in locale at all */
3003         if (IN_UTF8_CTYPE_LOCALE) {
3004             flags &= ~FOLD_FLAGS_LOCALE;
3005         }
3006         else {
3007             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3008             goto needs_full_generality;
3009         }
3010     }
3011
3012     if (c < 256) {
3013         return _to_fold_latin1((U8) c, p, lenp,
3014                             flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
3015     }
3016
3017     /* Here, above 255.  If no special needs, just use the macro */
3018     if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
3019         uvchr_to_utf8(p, c);
3020         return CALL_FOLD_CASE(c, p, p, lenp, flags & FOLD_FLAGS_FULL);
3021     }
3022     else {  /* Otherwise, _toFOLD_utf8_flags has the intelligence to deal with
3023                the special flags. */
3024         U8 utf8_c[UTF8_MAXBYTES + 1];
3025
3026       needs_full_generality:
3027         uvchr_to_utf8(utf8_c, c);
3028         return _toFOLD_utf8_flags(utf8_c, utf8_c + sizeof(utf8_c),
3029                                   p, lenp, flags);
3030     }
3031 }
3032
3033 PERL_STATIC_INLINE bool
3034 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
3035                  const char *const swashname, SV* const invlist)
3036 {
3037     /* returns a boolean giving whether or not the UTF8-encoded character that
3038      * starts at <p> is in the swash indicated by <swashname>.  <swash>
3039      * contains a pointer to where the swash indicated by <swashname>
3040      * is to be stored; which this routine will do, so that future calls will
3041      * look at <*swash> and only generate a swash if it is not null.  <invlist>
3042      * is NULL or an inversion list that defines the swash.  If not null, it
3043      * saves time during initialization of the swash.
3044      *
3045      * Note that it is assumed that the buffer length of <p> is enough to
3046      * contain all the bytes that comprise the character.  Thus, <*p> should
3047      * have been checked before this call for mal-formedness enough to assure
3048      * that. */
3049
3050     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
3051
3052     /* The API should have included a length for the UTF-8 character in <p>,
3053      * but it doesn't.  We therefore assume that p has been validated at least
3054      * as far as there being enough bytes available in it to accommodate the
3055      * character without reading beyond the end, and pass that number on to the
3056      * validating routine */
3057     if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
3058         _force_out_malformed_utf8_message(p, p + UTF8SKIP(p),
3059                                           _UTF8_NO_CONFIDENCE_IN_CURLEN,
3060                                           1 /* Die */ );
3061         NOT_REACHED; /* NOTREACHED */
3062     }
3063
3064     if (!*swash) {
3065         U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
3066         *swash = _core_swash_init("utf8",
3067
3068                                   /* Only use the name if there is no inversion
3069                                    * list; otherwise will go out to disk */
3070                                   (invlist) ? "" : swashname,
3071
3072                                   &PL_sv_undef, 1, 0, invlist, &flags);
3073     }
3074
3075     return swash_fetch(*swash, p, TRUE) != 0;
3076 }
3077
3078 PERL_STATIC_INLINE bool
3079 S_is_utf8_common_with_len(pTHX_ const U8 *const p, const U8 * const e,
3080                           SV **swash, const char *const swashname,
3081                           SV* const invlist)
3082 {
3083     /* returns a boolean giving whether or not the UTF8-encoded character that
3084      * starts at <p>, and extending no further than <e - 1> is in the swash
3085      * indicated by <swashname>.  <swash> contains a pointer to where the swash
3086      * indicated by <swashname> is to be stored; which this routine will do, so
3087      * that future calls will look at <*swash> and only generate a swash if it
3088      * is not null.  <invlist> is NULL or an inversion list that defines the
3089      * swash.  If not null, it saves time during initialization of the swash.
3090      */
3091
3092     PERL_ARGS_ASSERT_IS_UTF8_COMMON_WITH_LEN;
3093
3094     if (! isUTF8_CHAR(p, e)) {
3095         _force_out_malformed_utf8_message(p, e, 0, 1);
3096         NOT_REACHED; /* NOTREACHED */
3097     }
3098
3099     if (!*swash) {
3100         U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
3101         *swash = _core_swash_init("utf8",
3102
3103                                   /* Only use the name if there is no inversion
3104                                    * list; otherwise will go out to disk */
3105                                   (invlist) ? "" : swashname,
3106
3107                                   &PL_sv_undef, 1, 0, invlist, &flags);
3108     }
3109
3110     return swash_fetch(*swash, p, TRUE) != 0;
3111 }
3112
3113 STATIC void
3114 S_warn_on_first_deprecated_use(pTHX_ const char * const name,
3115                                      const char * const alternative,
3116                                      const bool use_locale,
3117                                      const char * const file,
3118                                      const unsigned line)
3119 {
3120     const char * key;
3121
3122     PERL_ARGS_ASSERT_WARN_ON_FIRST_DEPRECATED_USE;
3123
3124     if (ckWARN_d(WARN_DEPRECATED)) {
3125
3126         key = Perl_form(aTHX_ "%s;%d;%s;%d", name, use_locale, file, line);
3127         if (! hv_fetch(PL_seen_deprecated_macro, key, strlen(key), 0)) {
3128             if (! PL_seen_deprecated_macro) {
3129                 PL_seen_deprecated_macro = newHV();
3130             }
3131             if (! hv_store(PL_seen_deprecated_macro, key,
3132                            strlen(key), &PL_sv_undef, 0))
3133             {
3134                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3135             }
3136
3137             if (instr(file, "mathoms.c")) {
3138                 Perl_warner(aTHX_ WARN_DEPRECATED,
3139                             "In %s, line %d, starting in Perl v5.30, %s()"
3140                             " will be removed.  Avoid this message by"
3141                             " converting to use %s().\n",
3142                             file, line, name, alternative);
3143             }
3144             else {
3145                 Perl_warner(aTHX_ WARN_DEPRECATED,
3146                             "In %s, line %d, starting in Perl v5.30, %s() will"
3147                             " require an additional parameter.  Avoid this"
3148                             " message by converting to use %s().\n",
3149                             file, line, name, alternative);
3150             }
3151         }
3152     }
3153 }
3154
3155 bool
3156 Perl__is_utf8_FOO(pTHX_       U8   classnum,
3157                         const U8   * const p,
3158                         const char * const name,
3159                         const char * const alternative,
3160                         const bool use_utf8,
3161                         const bool use_locale,
3162                         const char * const file,
3163                         const unsigned line)
3164 {
3165     PERL_ARGS_ASSERT__IS_UTF8_FOO;
3166
3167     warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
3168
3169     if (use_utf8 && UTF8_IS_ABOVE_LATIN1(*p)) {
3170
3171         switch (classnum) {
3172             case _CC_WORDCHAR:
3173             case _CC_DIGIT:
3174             case _CC_ALPHA:
3175             case _CC_LOWER:
3176             case _CC_UPPER:
3177             case _CC_PUNCT:
3178             case _CC_PRINT:
3179             case _CC_ALPHANUMERIC:
3180             case _CC_GRAPH:
3181             case _CC_CASED:
3182
3183                 return is_utf8_common(p,
3184                                       &PL_utf8_swash_ptrs[classnum],
3185                                       swash_property_names[classnum],
3186                                       PL_XPosix_ptrs[classnum]);
3187
3188             case _CC_SPACE:
3189                 return is_XPERLSPACE_high(p);
3190             case _CC_BLANK:
3191                 return is_HORIZWS_high(p);
3192             case _CC_XDIGIT:
3193                 return is_XDIGIT_high(p);
3194             case _CC_CNTRL:
3195                 return 0;
3196             case _CC_ASCII:
3197                 return 0;
3198             case _CC_VERTSPACE:
3199                 return is_VERTWS_high(p);
3200             case _CC_IDFIRST:
3201                 if (! PL_utf8_perl_idstart) {
3202                     PL_utf8_perl_idstart
3203                                 = _new_invlist_C_array(_Perl_IDStart_invlist);
3204                 }
3205                 return is_utf8_common(p, &PL_utf8_perl_idstart,
3206                                       "_Perl_IDStart", NULL);
3207             case _CC_IDCONT:
3208                 if (! PL_utf8_perl_idcont) {
3209                     PL_utf8_perl_idcont
3210                                 = _new_invlist_C_array(_Perl_IDCont_invlist);
3211                 }
3212                 return is_utf8_common(p, &PL_utf8_perl_idcont,
3213                                       "_Perl_IDCont", NULL);
3214         }
3215     }
3216
3217     /* idcont is the same as wordchar below 256 */
3218     if (classnum == _CC_IDCONT) {
3219         classnum = _CC_WORDCHAR;
3220     }
3221     else if (classnum == _CC_IDFIRST) {
3222         if (*p == '_') {
3223             return TRUE;
3224         }
3225         classnum = _CC_ALPHA;
3226     }
3227
3228     if (! use_locale) {
3229         if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
3230             return _generic_isCC(*p, classnum);
3231         }
3232
3233         return _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )), classnum);
3234     }
3235     else {
3236         if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
3237             return isFOO_lc(classnum, *p);
3238         }
3239
3240         return isFOO_lc(classnum, EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )));
3241     }
3242
3243     NOT_REACHED; /* NOTREACHED */
3244 }
3245
3246 bool
3247 Perl__is_utf8_FOO_with_len(pTHX_ const U8 classnum, const U8 *p,
3248                                                             const U8 * const e)
3249 {
3250     PERL_ARGS_ASSERT__IS_UTF8_FOO_WITH_LEN;
3251
3252     assert(classnum < _FIRST_NON_SWASH_CC);
3253
3254     return is_utf8_common_with_len(p,
3255                                    e,
3256                                    &PL_utf8_swash_ptrs[classnum],
3257                                    swash_property_names[classnum],
3258                                    PL_XPosix_ptrs[classnum]);
3259 }
3260
3261 bool
3262 Perl__is_utf8_perl_idstart_with_len(pTHX_ const U8 *p, const U8 * const e)
3263 {
3264     SV* invlist = NULL;
3265
3266     PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART_WITH_LEN;
3267
3268     if (! PL_utf8_perl_idstart) {
3269         invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
3270     }
3271     return is_utf8_common_with_len(p, e, &PL_utf8_perl_idstart,
3272                                       "_Perl_IDStart", invlist);
3273 }
3274
3275 bool
3276 Perl__is_utf8_xidstart(pTHX_ const U8 *p)
3277 {
3278     PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
3279
3280     if (*p == '_')
3281         return TRUE;
3282     return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
3283 }
3284
3285 bool
3286 Perl__is_utf8_perl_idcont_with_len(pTHX_ const U8 *p, const U8 * const e)
3287 {
3288     SV* invlist = NULL;
3289
3290     PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT_WITH_LEN;
3291
3292     if (! PL_utf8_perl_idcont) {
3293         invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
3294     }
3295     return is_utf8_common_with_len(p, e, &PL_utf8_perl_idcont,
3296                                    "_Perl_IDCont", invlist);
3297 }
3298
3299 bool
3300 Perl__is_utf8_idcont(pTHX_ const U8 *p)
3301 {
3302     PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
3303
3304     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
3305 }
3306
3307 bool
3308 Perl__is_utf8_xidcont(pTHX_ const U8 *p)
3309 {
3310     PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
3311
3312     return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
3313 }
3314
3315 bool
3316 Perl__is_utf8_mark(pTHX_ const U8 *p)
3317 {
3318     PERL_ARGS_ASSERT__IS_UTF8_MARK;
3319
3320     return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
3321 }
3322
3323     /* change namve uv1 to 'from' */
3324 STATIC UV
3325 S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
3326                 SV **swashp, const char *normal, const char *special)
3327 {
3328     STRLEN len = 0;
3329
3330     PERL_ARGS_ASSERT__TO_UTF8_CASE;
3331
3332     /* For code points that don't change case, we already know that the output
3333      * of this function is the unchanged input, so we can skip doing look-ups
3334      * for them.  Unfortunately the case-changing code points are scattered
3335      * around.  But there are some long consecutive ranges where there are no
3336      * case changing code points.  By adding tests, we can eliminate the lookup
3337      * for all the ones in such ranges.  This is currently done here only for
3338      * just a few cases where the scripts are in common use in modern commerce
3339      * (and scripts adjacent to those which can be included without additional
3340      * tests). */
3341
3342     if (uv1 >= 0x0590) {
3343         /* This keeps from needing further processing the code points most
3344          * likely to be used in the following non-cased scripts: Hebrew,
3345          * Arabic, Syriac, Thaana, NKo, Samaritan, Mandaic, Devanagari,
3346          * Bengali, Gurmukhi, Gujarati, Oriya, Tamil, Telugu, Kannada,
3347          * Malayalam, Sinhala, Thai, Lao, Tibetan, Myanmar */
3348         if (uv1 < 0x10A0) {
3349             goto cases_to_self;
3350         }
3351
3352         /* The following largish code point ranges also don't have case
3353          * changes, but khw didn't think they warranted extra tests to speed
3354          * them up (which would slightly slow down everything else above them):
3355          * 1100..139F   Hangul Jamo, Ethiopic
3356          * 1400..1CFF   Unified Canadian Aboriginal Syllabics, Ogham, Runic,
3357          *              Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Mongolian,
3358          *              Limbu, Tai Le, New Tai Lue, Buginese, Tai Tham,
3359          *              Combining Diacritical Marks Extended, Balinese,
3360          *              Sundanese, Batak, Lepcha, Ol Chiki
3361          * 2000..206F   General Punctuation
3362          */
3363
3364         if (uv1 >= 0x2D30) {
3365
3366             /* This keeps the from needing further processing the code points
3367              * most likely to be used in the following non-cased major scripts:
3368              * CJK, Katakana, Hiragana, plus some less-likely scripts.
3369              *
3370              * (0x2D30 above might have to be changed to 2F00 in the unlikely
3371              * event that Unicode eventually allocates the unused block as of
3372              * v8.0 2FE0..2FEF to code points that are cased.  khw has verified
3373              * that the test suite will start having failures to alert you
3374              * should that happen) */
3375             if (uv1 < 0xA640) {
3376                 goto cases_to_self;
3377             }
3378
3379             if (uv1 >= 0xAC00) {
3380                 if (UNLIKELY(UNICODE_IS_SURROGATE(uv1))) {
3381                     if (ckWARN_d(WARN_SURROGATE)) {
3382                         const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
3383                         Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
3384                             "Operation \"%s\" returns its argument for"
3385                             " UTF-16 surrogate U+%04" UVXf, desc, uv1);
3386                     }
3387                     goto cases_to_self;
3388                 }
3389
3390                 /* AC00..FAFF Catches Hangul syllables and private use, plus
3391                  * some others */
3392                 if (uv1 < 0xFB00) {
3393                     goto cases_to_self;
3394
3395                 }
3396
3397                 if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
3398                     if (UNLIKELY(uv1 > MAX_EXTERNALLY_LEGAL_CP)) {
3399                         Perl_croak(aTHX_ cp_above_legal_max, uv1,
3400                                          MAX_EXTERNALLY_LEGAL_CP);
3401                     }
3402                     if (ckWARN_d(WARN_NON_UNICODE)) {
3403                         const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
3404                         Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
3405                             "Operation \"%s\" returns its argument for"
3406                             " non-Unicode code point 0x%04" UVXf, desc, uv1);
3407                     }
3408                     goto cases_to_self;
3409                 }
3410 #ifdef HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C
3411                 if (UNLIKELY(uv1
3412                     > HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C))
3413                 {
3414
3415                     /* As of Unicode 10.0, this means we avoid swash creation
3416                      * for anything beyond high Plane 1 (below emojis)  */
3417                     goto cases_to_self;
3418                 }
3419 #endif
3420             }
3421         }
3422
3423         /* Note that non-characters are perfectly legal, so no warning should
3424          * be given.  There are so few of them, that it isn't worth the extra
3425          * tests to avoid swash creation */
3426     }
3427
3428     if (!*swashp) /* load on-demand */
3429          *swashp = _core_swash_init("utf8", normal, &PL_sv_undef,
3430                                     4, 0, NULL, NULL);
3431
3432     if (special) {
3433          /* It might be "special" (sometimes, but not always,
3434           * a multicharacter mapping) */
3435          HV *hv = NULL;
3436          SV **svp;
3437
3438          /* If passed in the specials name, use that; otherwise use any
3439           * given in the swash */
3440          if (*special != '\0') {
3441             hv = get_hv(special, 0);
3442         }
3443         else {
3444             svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0);
3445             if (svp) {
3446                 hv = MUTABLE_HV(SvRV(*svp));
3447             }
3448         }
3449
3450          if (hv
3451              && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
3452              && (*svp))
3453          {
3454              const char *s;
3455
3456               s = SvPV_const(*svp, len);
3457               if (len == 1)
3458                   /* EIGHTBIT */
3459                    len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp;
3460               else {
3461                    Copy(s, ustrp, len, U8);
3462               }
3463          }
3464     }
3465
3466     if (!len && *swashp) {
3467         const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
3468
3469          if (uv2) {
3470               /* It was "normal" (a single character mapping). */
3471               len = uvchr_to_utf8(ustrp, uv2) - ustrp;
3472          }
3473     }
3474
3475     if (len) {
3476         if (lenp) {
3477             *lenp = len;
3478         }
3479         return valid_utf8_to_uvchr(ustrp, 0);
3480     }
3481
3482     /* Here, there was no mapping defined, which means that the code point maps
3483      * to itself.  Return the inputs */
3484   cases_to_self:
3485     len = UTF8SKIP(p);
3486     if (p != ustrp) {   /* Don't copy onto itself */
3487         Copy(p, ustrp, len, U8);
3488     }
3489
3490     if (lenp)
3491          *lenp = len;
3492
3493     return uv1;
3494
3495 }
3496
3497 STATIC UV
3498 S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result,
3499                                        U8* const ustrp, STRLEN *lenp)
3500 {
3501     /* This is called when changing the case of a UTF-8-encoded character above
3502      * the Latin1 range, and the operation is in a non-UTF-8 locale.  If the
3503      * result contains a character that crosses the 255/256 boundary, disallow
3504      * the change, and return the original code point.  See L<perlfunc/lc> for
3505      * why;
3506      *
3507      * p        points to the original string whose case was changed; assumed
3508      *          by this routine to be well-formed
3509      * result   the code point of the first character in the changed-case string
3510      * ustrp    points to the changed-case string (<result> represents its
3511      *          first char)
3512      * lenp     points to the length of <ustrp> */
3513
3514     UV original;    /* To store the first code point of <p> */
3515
3516     PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
3517
3518     assert(UTF8_IS_ABOVE_LATIN1(*p));
3519
3520     /* We know immediately if the first character in the string crosses the
3521      * boundary, so can skip */
3522     if (result > 255) {
3523
3524         /* Look at every character in the result; if any cross the
3525         * boundary, the whole thing is disallowed */
3526         U8* s = ustrp + UTF8SKIP(ustrp);
3527         U8* e = ustrp + *lenp;
3528         while (s < e) {
3529             if (! UTF8_IS_ABOVE_LATIN1(*s)) {
3530                 goto bad_crossing;
3531             }
3532             s += UTF8SKIP(s);
3533         }
3534
3535         /* Here, no characters crossed, result is ok as-is, but we warn. */
3536         _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p));
3537         return result;
3538     }
3539
3540   bad_crossing:
3541
3542     /* Failed, have to return the original */
3543     original = valid_utf8_to_uvchr(p, lenp);
3544
3545     /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3546     Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3547                            "Can't do %s(\"\\x{%" UVXf "}\") on non-UTF-8"
3548                            " locale; resolved to \"\\x{%" UVXf "}\".",
3549                            OP_DESC(PL_op),
3550                            original,
3551                            original);
3552     Copy(p, ustrp, *lenp, char);
3553     return original;
3554 }
3555
3556 STATIC U32
3557 S_check_and_deprecate(pTHX_ const U8 *p,
3558                             const U8 **e,
3559                             const unsigned int type,    /* See below */
3560                             const bool use_locale,      /* Is this a 'LC_'
3561                                                            macro call? */
3562                             const char * const file,
3563                             const unsigned line)
3564 {
3565     /* This is a temporary function to deprecate the unsafe calls to the case
3566      * changing macros and functions.  It keeps all the special stuff in just
3567      * one place.
3568      *
3569      * It updates *e with the pointer to the end of the input string.  If using
3570      * the old-style macros, *e is NULL on input, and so this function assumes
3571      * the input string is long enough to hold the entire UTF-8 sequence, and
3572      * sets *e accordingly, but it then returns a flag to pass the
3573      * utf8n_to_uvchr(), to tell it that this size is a guess, and to avoid
3574      * using the full length if possible.
3575      *
3576      * It also does the assert that *e > p when *e is not NULL.  This should be
3577      * migrated to the callers when this function gets deleted.
3578      *
3579      * The 'type' parameter is used for the caller to specify which case
3580      * changing function this is called from: */
3581
3582 #       define DEPRECATE_TO_UPPER 0
3583 #       define DEPRECATE_TO_TITLE 1
3584 #       define DEPRECATE_TO_LOWER 2
3585 #       define DEPRECATE_TO_FOLD  3
3586
3587     U32 utf8n_flags = 0;
3588     const char * name;
3589     const char * alternative;
3590
3591     PERL_ARGS_ASSERT_CHECK_AND_DEPRECATE;
3592
3593     if (*e == NULL) {
3594         utf8n_flags = _UTF8_NO_CONFIDENCE_IN_CURLEN;
3595         *e = p + UTF8SKIP(p);
3596
3597         /* For mathoms.c calls, we use the function name we know is stored
3598          * there.  It could be part of a larger path */
3599         if (type == DEPRECATE_TO_UPPER) {
3600             name = instr(file, "mathoms.c")
3601                    ? "to_utf8_upper"
3602                    : "toUPPER_utf8";
3603             alternative = "toUPPER_utf8_safe";
3604         }
3605         else if (type == DEPRECATE_TO_TITLE) {
3606             name = instr(file, "mathoms.c")
3607                    ? "to_utf8_title"
3608                    : "toTITLE_utf8";
3609             alternative = "toTITLE_utf8_safe";
3610         }
3611         else if (type == DEPRECATE_TO_LOWER) {
3612             name = instr(file, "mathoms.c")
3613                    ? "to_utf8_lower"
3614                    : "toLOWER_utf8";
3615             alternative = "toLOWER_utf8_safe";
3616         }
3617         else if (type == DEPRECATE_TO_FOLD) {
3618             name = instr(file, "mathoms.c")
3619                    ? "to_utf8_fold"
3620                    : "toFOLD_utf8";
3621             alternative = "toFOLD_utf8_safe";
3622         }
3623         else Perl_croak(aTHX_ "panic: Unexpected case change type");
3624
3625         warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
3626     }
3627     else {
3628         assert (p < *e);
3629     }
3630
3631     return utf8n_flags;
3632 }
3633
3634 /* The process for changing the case is essentially the same for the four case
3635  * change types, except there are complications for folding.  Otherwise the
3636  * difference is only which case to change to.  To make sure that they all do
3637  * the same thing, the bodies of the functions are extracted out into the
3638  * following two macros.  The functions are written with the same variable
3639  * names, and these are known and used inside these macros.  It would be
3640  * better, of course, to have inline functions to do it, but since different
3641  * macros are called, depending on which case is being changed to, this is not
3642  * feasible in C (to khw's knowledge).  Two macros are created so that the fold
3643  * function can start with the common start macro, then finish with its special
3644  * handling; while the other three cases can just use the common end macro.
3645  *
3646  * The algorithm is to use the proper (passed in) macro or function to change
3647  * the case for code points that are below 256.  The macro is used if using
3648  * locale rules for the case change; the function if not.  If the code point is
3649  * above 255, it is computed from the input UTF-8, and another macro is called
3650  * to do the conversion.  If necessary, the output is converted to UTF-8.  If
3651  * using a locale, we have to check that the change did not cross the 255/256
3652  * boundary, see check_locale_boundary_crossing() for further details.
3653  *
3654  * The macros are split with the correct case change for the below-256 case
3655  * stored into 'result', and in the middle of an else clause for the above-255
3656  * case.  At that point in the 'else', 'result' is not the final result, but is
3657  * the input code point calculated from the UTF-8.  The fold code needs to
3658  * realize all this and take it from there.
3659  *
3660  * If you read the two macros as sequential, it's easier to understand what's
3661  * going on. */
3662 #define CASE_CHANGE_BODY_START(locale_flags, LC_L1_change_macro, L1_func,    \
3663                                L1_func_extra_param)                          \
3664                                                                              \
3665     if (flags & (locale_flags)) {                                            \
3666         /* Treat a UTF-8 locale as not being in locale at all */             \
3667         if (IN_UTF8_CTYPE_LOCALE) {                                          \
3668             flags &= ~(locale_flags);                                        \
3669         }                                                                    \
3670         else {                                                               \
3671             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;                              \
3672         }                                                                    \
3673     }                                                                        \
3674                                                                              \
3675     if (UTF8_IS_INVARIANT(*p)) {                                             \
3676         if (flags & (locale_flags)) {                                        \
3677             result = LC_L1_change_macro(*p);                                 \
3678         }                                                                    \
3679         else {                                                               \
3680             return L1_func(*p, ustrp, lenp, L1_func_extra_param);            \
3681         }                                                                    \
3682     }                                                                        \
3683     else if UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e) {                          \
3684         if (flags & (locale_flags)) {                                        \
3685             result = LC_L1_change_macro(EIGHT_BIT_UTF8_TO_NATIVE(*p,         \
3686                                                                  *(p+1)));   \
3687         }                                                                    \
3688         else {                                                               \
3689             return L1_func(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),             \
3690                            ustrp, lenp,  L1_func_extra_param);               \
3691         }                                                                    \
3692     }                                                                        \
3693     else {  /* malformed UTF-8 or ord above 255 */                           \
3694         STRLEN len_result;                                                   \
3695         result = utf8n_to_uvchr(p, e - p, &len_result, UTF8_CHECK_ONLY);     \
3696         if (len_result == (STRLEN) -1) {                                     \
3697             _force_out_malformed_utf8_message(p, e, utf8n_flags,             \
3698                                                             1 /* Die */ );   \
3699         }
3700
3701 #define CASE_CHANGE_BODY_END(locale_flags, change_macro)                     \
3702         result = change_macro(result, p, ustrp, lenp);                       \
3703                                                                              \
3704         if (flags & (locale_flags)) {                                        \
3705             result = check_locale_boundary_crossing(p, result, ustrp, lenp); \
3706         }                                                                    \
3707         return result;                                                       \
3708     }                                                                        \
3709                                                                              \
3710     /* Here, used locale rules.  Convert back to UTF-8 */                    \
3711     if (UTF8_IS_INVARIANT(result)) {                                         \
3712         *ustrp = (U8) result;                                                \
3713         *lenp = 1;                                                           \
3714     }                                                                        \
3715     else {                                                                   \
3716         *ustrp = UTF8_EIGHT_BIT_HI((U8) result);                             \
3717         *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);                       \
3718         *lenp = 2;                                                           \
3719     }                                                                        \
3720                                                                              \
3721     return result;
3722
3723 /*
3724 =for apidoc to_utf8_upper
3725
3726 Instead use L</toUPPER_utf8_safe>.
3727
3728 =cut */
3729
3730 /* Not currently externally documented, and subject to change:
3731  * <flags> is set iff iff the rules from the current underlying locale are to
3732  *         be used. */
3733
3734 UV
3735 Perl__to_utf8_upper_flags(pTHX_ const U8 *p,
3736                                 const U8 *e,
3737                                 U8* ustrp,
3738                                 STRLEN *lenp,
3739                                 bool flags,
3740                                 const char * const file,
3741                                 const int line)
3742 {
3743     UV result;
3744     const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_UPPER,
3745                                                 cBOOL(flags), file, line);
3746
3747     PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
3748
3749     /* ~0 makes anything non-zero in 'flags' mean we are using locale rules */
3750     /* 2nd char of uc(U+DF) is 'S' */
3751     CASE_CHANGE_BODY_START(~0, toUPPER_LC, _to_upper_title_latin1, 'S');
3752     CASE_CHANGE_BODY_END  (~0, CALL_UPPER_CASE);
3753 }
3754
3755 /*
3756 =for apidoc to_utf8_title
3757
3758 Instead use L</toTITLE_utf8_safe>.
3759
3760 =cut */
3761
3762 /* Not currently externally documented, and subject to change:
3763  * <flags> is set iff the rules from the current underlying locale are to be
3764  *         used.  Since titlecase is not defined in POSIX, for other than a
3765  *         UTF-8 locale, uppercase is used instead for code points < 256.
3766  */
3767
3768 UV
3769 Perl__to_utf8_title_flags(pTHX_ const U8 *p,
3770                                 const U8 *e,
3771                                 U8* ustrp,
3772                                 STRLEN *lenp,
3773                                 bool flags,
3774                                 const char * const file,
3775                                 const int line)
3776 {
3777     UV result;
3778     const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_TITLE,
3779                                                 cBOOL(flags), file, line);
3780
3781     PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
3782
3783     /* 2nd char of ucfirst(U+DF) is 's' */
3784     CASE_CHANGE_BODY_START(~0, toUPPER_LC, _to_upper_title_latin1, 's');
3785     CASE_CHANGE_BODY_END  (~0, CALL_TITLE_CASE);
3786 }
3787
3788 /*
3789 =for apidoc to_utf8_lower
3790
3791 Instead use L</toLOWER_utf8_safe>.
3792
3793 =cut */
3794
3795 /* Not currently externally documented, and subject to change:
3796  * <flags> is set iff iff the rules from the current underlying locale are to
3797  *         be used.
3798  */
3799
3800 UV
3801 Perl__to_utf8_lower_flags(pTHX_ const U8 *p,
3802                                 const U8 *e,
3803                                 U8* ustrp,
3804                                 STRLEN *lenp,
3805                                 bool flags,
3806                                 const char * const file,
3807                                 const int line)
3808 {
3809     UV result;
3810     const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_LOWER,
3811                                                 cBOOL(flags), file, line);
3812
3813     PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
3814
3815     CASE_CHANGE_BODY_START(~0, toLOWER_LC, to_lower_latin1, 0 /* 0 is dummy */)
3816     CASE_CHANGE_BODY_END  (~0, CALL_LOWER_CASE)
3817 }
3818
3819 /*
3820 =for apidoc to_utf8_fold
3821
3822 Instead use L</toFOLD_utf8_safe>.
3823
3824 =cut */
3825
3826 /* Not currently externally documented, and subject to change,
3827  * in <flags>
3828  *      bit FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
3829  *                            locale are to be used.
3830  *      bit FOLD_FLAGS_FULL   is set iff full case folds are to be used;
3831  *                            otherwise simple folds
3832  *      bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are
3833  *                            prohibited
3834  */
3835
3836 UV
3837 Perl__to_utf8_fold_flags(pTHX_ const U8 *p,
3838                                const U8 *e,
3839                                U8* ustrp,
3840                                STRLEN *lenp,
3841                                U8 flags,
3842                                const char * const file,
3843                                const int line)
3844 {
3845     UV result;
3846     const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_FOLD,
3847                                                 cBOOL(flags), file, line);
3848
3849     PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
3850
3851     /* These are mutually exclusive */
3852     assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
3853
3854     assert(p != ustrp); /* Otherwise overwrites */
3855
3856     CASE_CHANGE_BODY_START(FOLD_FLAGS_LOCALE, toFOLD_LC, _to_fold_latin1,
3857                  ((flags) & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)));
3858
3859         result = CALL_FOLD_CASE(result, p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
3860
3861         if (flags & FOLD_FLAGS_LOCALE) {
3862
3863 #           define LONG_S_T      LATIN_SMALL_LIGATURE_LONG_S_T_UTF8
3864 #         ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8
3865 #           define CAP_SHARP_S   LATIN_CAPITAL_LETTER_SHARP_S_UTF8
3866
3867             /* Special case these two characters, as what normally gets
3868              * returned under locale doesn't work */
3869             if (memEQs((char *) p, UTF8SKIP(p), CAP_SHARP_S))
3870             {
3871                 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3872                 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3873                               "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
3874                               "resolved to \"\\x{17F}\\x{17F}\".");
3875                 goto return_long_s;
3876             }
3877             else
3878 #endif
3879                  if (memEQs((char *) p, UTF8SKIP(p), LONG_S_T))
3880             {
3881                 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3882                 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3883                               "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
3884                               "resolved to \"\\x{FB06}\".");
3885                 goto return_ligature_st;
3886             }
3887
3888 #if    UNICODE_MAJOR_VERSION   == 3         \
3889     && UNICODE_DOT_VERSION     == 0         \
3890     && UNICODE_DOT_DOT_VERSION == 1
3891 #           define DOTTED_I   LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE_UTF8
3892
3893             /* And special case this on this Unicode version only, for the same
3894              * reaons the other two are special cased.  They would cross the
3895              * 255/256 boundary which is forbidden under /l, and so the code
3896              * wouldn't catch that they are equivalent (which they are only in
3897              * this release) */
3898             else if (memEQs((char *) p, UTF8SKIP(p), DOTTED_I)) {
3899                 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3900                 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3901                               "Can't do fc(\"\\x{0130}\") on non-UTF-8 locale; "
3902                               "resolved to \"\\x{0131}\".");
3903                 goto return_dotless_i;
3904             }
3905 #endif
3906
3907             return check_locale_boundary_crossing(p, result, ustrp, lenp);
3908         }
3909         else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
3910             return result;
3911         }
3912         else {
3913             /* This is called when changing the case of a UTF-8-encoded
3914              * character above the ASCII range, and the result should not
3915              * contain an ASCII character. */
3916
3917             UV original;    /* To store the first code point of <p> */
3918
3919             /* Look at every character in the result; if any cross the
3920             * boundary, the whole thing is disallowed */
3921             U8* s = ustrp;
3922             U8* e = ustrp + *lenp;
3923             while (s < e) {
3924                 if (isASCII(*s)) {
3925                     /* Crossed, have to return the original */
3926                     original = valid_utf8_to_uvchr(p, lenp);
3927
3928                     /* But in these instances, there is an alternative we can
3929                      * return that is valid */
3930                     if (original == LATIN_SMALL_LETTER_SHARP_S
3931 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
3932                         || original == LATIN_CAPITAL_LETTER_SHARP_S
3933 #endif
3934                     ) {
3935                         goto return_long_s;
3936                     }
3937                     else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) {
3938                         goto return_ligature_st;
3939                     }
3940 #if    UNICODE_MAJOR_VERSION   == 3         \
3941     && UNICODE_DOT_VERSION     == 0         \
3942     && UNICODE_DOT_DOT_VERSION == 1
3943
3944                     else if (original == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
3945                         goto return_dotless_i;
3946                     }
3947 #endif
3948                     Copy(p, ustrp, *lenp, char);
3949                     return original;
3950                 }
3951                 s += UTF8SKIP(s);
3952             }
3953
3954             /* Here, no characters crossed, result is ok as-is */
3955             return result;
3956         }
3957     }
3958
3959     /* Here, used locale rules.  Convert back to UTF-8 */
3960     if (UTF8_IS_INVARIANT(result)) {
3961         *ustrp = (U8) result;
3962         *lenp = 1;
3963     }
3964     else {
3965         *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
3966         *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
3967         *lenp = 2;
3968     }
3969
3970     return result;
3971
3972   return_long_s:
3973     /* Certain folds to 'ss' are prohibited by the options, but they do allow
3974      * folds to a string of two of these characters.  By returning this
3975      * instead, then, e.g.,
3976      *      fc("\x{1E9E}") eq fc("\x{17F}\x{17F}")
3977      * works. */
3978
3979     *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
3980     Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
3981         ustrp, *lenp, U8);
3982     return LATIN_SMALL_LETTER_LONG_S;
3983
3984   return_ligature_st:
3985     /* Two folds to 'st' are prohibited by the options; instead we pick one and
3986      * have the other one fold to it */
3987
3988     *lenp = sizeof(LATIN_SMALL_LIGATURE_ST_UTF8) - 1;
3989     Copy(LATIN_SMALL_LIGATURE_ST_UTF8, ustrp, *lenp, U8);
3990     return LATIN_SMALL_LIGATURE_ST;
3991
3992 #if    UNICODE_MAJOR_VERSION   == 3         \
3993     && UNICODE_DOT_VERSION     == 0         \
3994     && UNICODE_DOT_DOT_VERSION == 1
3995
3996   return_dotless_i:
3997     *lenp = sizeof(LATIN_SMALL_LETTER_DOTLESS_I_UTF8) - 1;
3998     Copy(LATIN_SMALL_LETTER_DOTLESS_I_UTF8, ustrp, *lenp, U8);
3999     return LATIN_SMALL_LETTER_DOTLESS_I;
4000
4001 #endif
4002
4003 }
4004
4005 /* Note:
4006  * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().
4007  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
4008  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
4009  */
4010
4011 SV*
4012 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv,
4013                       I32 minbits, I32 none)
4014 {
4015     PERL_ARGS_ASSERT_SWASH_INIT;
4016
4017     /* Returns a copy of a swash initiated by the called function.  This is the
4018      * public interface, and returning a copy prevents others from doing
4019      * mischief on the original */
4020
4021     return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none,
4022                                     NULL, NULL));
4023 }
4024
4025 SV*
4026 Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv,
4027                             I32 minbits, I32 none, SV* invlist,
4028                             U8* const flags_p)
4029 {
4030
4031     /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
4032      * use the following define */
4033
4034 #define CORE_SWASH_INIT_RETURN(x)   \
4035     PL_curpm= old_PL_curpm;         \
4036     return x
4037
4038     /* Initialize and return a swash, creating it if necessary.  It does this
4039      * by calling utf8_heavy.pl in the general case.  The returned value may be
4040      * the swash's inversion list instead if the input parameters allow it.
4041      * Which is returned should be immaterial to callers, as the only
4042      * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
4043      * and swash_to_invlist() handle both these transparently.
4044      *
4045      * This interface should only be used by functions that won't destroy or
4046      * adversely change the swash, as doing so affects all other uses of the
4047      * swash in the program; the general public should use 'Perl_swash_init'
4048      * instead.
4049      *
4050      * pkg  is the name of the package that <name> should be in.
4051      * name is the name of the swash to find.  Typically it is a Unicode
4052      *      property name, including user-defined ones
4053      * listsv is a string to initialize the swash with.  It must be of the form
4054      *      documented as the subroutine return value in
4055      *      L<perlunicode/User-Defined Character Properties>
4056      * minbits is the number of bits required to represent each data element.
4057      *      It is '1' for binary properties.
4058      * none I (khw) do not understand this one, but it is used only in tr///.
4059      * invlist is an inversion list to initialize the swash with (or NULL)
4060      * flags_p if non-NULL is the address of various input and output flag bits
4061      *      to the routine, as follows:  ('I' means is input to the routine;
4062      *      'O' means output from the routine.  Only flags marked O are
4063      *      meaningful on return.)
4064      *  _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
4065      *      came from a user-defined property.  (I O)
4066      *  _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
4067      *      when the swash cannot be located, to simply return NULL. (I)
4068      *  _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
4069      *      return of an inversion list instead of a swash hash if this routine
4070      *      thinks that would result in faster execution of swash_fetch() later
4071      *      on. (I)
4072      *
4073      * Thus there are three possible inputs to find the swash: <name>,
4074      * <listsv>, and <invlist>.  At least one must be specified.  The result
4075      * will be the union of the specified ones, although <listsv>'s various
4076      * actions can intersect, etc. what <name> gives.  To avoid going out to
4077      * disk at all, <invlist> should specify completely what the swash should
4078      * have, and <listsv> should be &PL_sv_undef and <name> should be "".
4079      *
4080      * <invlist> is only valid for binary properties */
4081
4082     PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
4083
4084     SV* retval = &PL_sv_undef;
4085     HV* swash_hv = NULL;
4086     const int invlist_swash_boundary =
4087         (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
4088         ? 512    /* Based on some benchmarking, but not extensive, see commit
4089                     message */
4090         : -1;   /* Never return just an inversion list */
4091
4092     assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
4093     assert(! invlist || minbits == 1);
4094
4095     PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the
4096                        regex that triggered the swash init and the swash init
4097                        perl logic itself.  See perl #122747 */
4098
4099     /* If data was passed in to go out to utf8_heavy to find the swash of, do
4100      * so */
4101     if (listsv != &PL_sv_undef || strNE(name, "")) {
4102         dSP;
4103         const size_t pkg_len = strlen(pkg);
4104         const size_t name_len = strlen(name);
4105         HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
4106         SV* errsv_save;
4107         GV *method;
4108
4109         PERL_ARGS_ASSERT__CORE_SWASH_INIT;
4110
4111         PUSHSTACKi(PERLSI_MAGIC);
4112         ENTER;
4113         SAVEHINTS();
4114         save_re_context();
4115         /* We might get here via a subroutine signature which uses a utf8
4116          * parameter name, at which point PL_subname will have been set
4117          * but not yet used. */
4118         save_item(PL_subname);
4119         if (PL_parser && PL_parser->error_count)
4120             SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
4121         method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
4122         if (!method) {  /* demand load UTF-8 */
4123             ENTER;
4124             if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
4125             GvSV(PL_errgv) = NULL;
4126 #ifndef NO_TAINT_SUPPORT
4127             /* It is assumed that callers of this routine are not passing in
4128              * any user derived data.  */
4129             /* Need to do this after save_re_context() as it will set
4130              * PL_tainted to 1 while saving $1 etc (see the code after getrx:
4131              * in Perl_magic_get).  Even line to create errsv_save can turn on
4132              * PL_tainted.  */
4133             SAVEBOOL(TAINT_get);
4134             TAINT_NOT;
4135 #endif
4136             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
4137                              NULL);
4138             {
4139                 /* Not ERRSV, as there is no need to vivify a scalar we are
4140                    about to discard. */
4141                 SV * const errsv = GvSV(PL_errgv);
4142                 if (!SvTRUE(errsv)) {
4143                     GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
4144                     SvREFCNT_dec(errsv);
4145                 }
4146             }
4147             LEAVE;
4148         }
4149         SPAGAIN;
4150         PUSHMARK(SP);
4151         EXTEND(SP,5);
4152         mPUSHp(pkg, pkg_len);
4153         mPUSHp(name, name_len);
4154         PUSHs(listsv);
4155         mPUSHi(minbits);
4156         mPUSHi(none);
4157         PUTBACK;
4158         if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
4159         GvSV(PL_errgv) = NULL;
4160         /* If we already have a pointer to the method, no need to use
4161          * call_method() to repeat the lookup.  */
4162         if (method
4163             ? call_sv(MUTABLE_SV(method), G_SCALAR)
4164             : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
4165         {
4166             retval = *PL_stack_sp--;
4167             SvREFCNT_inc(retval);
4168         }
4169         {
4170             /* Not ERRSV.  See above. */
4171             SV * const errsv = GvSV(PL_errgv);
4172             if (!SvTRUE(errsv)) {
4173                 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
4174                 SvREFCNT_dec(errsv);
4175             }
4176         }
4177         LEAVE;
4178         POPSTACK;
4179         if (IN_PERL_COMPILETIME) {
4180             CopHINTS_set(PL_curcop, PL_hints);
4181         }
4182         if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
4183             if (SvPOK(retval)) {
4184
4185                 /* If caller wants to handle missing properties, let them */
4186                 if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
4187                     CORE_SWASH_INIT_RETURN(NULL);
4188                 }
4189                 Perl_croak(aTHX_
4190                            "Can't find Unicode property definition \"%" SVf "\"",
4191                            SVfARG(retval));
4192                 NOT_REACHED; /* NOTREACHED */
4193             }
4194         }
4195     } /* End of calling the module to find the swash */
4196
4197     /* If this operation fetched a swash, and we will need it later, get it */
4198     if (retval != &PL_sv_undef
4199         && (minbits == 1 || (flags_p
4200                             && ! (*flags_p
4201                                   & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
4202     {
4203         swash_hv = MUTABLE_HV(SvRV(retval));
4204
4205         /* If we don't already know that there is a user-defined component to
4206          * this swash, and the user has indicated they wish to know if there is
4207          * one (by passing <flags_p>), find out */
4208         if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
4209             SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
4210             if (user_defined && SvUV(*user_defined)) {
4211                 *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
4212             }
4213         }
4214     }
4215
4216     /* Make sure there is an inversion list for binary properties */
4217     if (minbits == 1) {
4218         SV** swash_invlistsvp = NULL;
4219         SV* swash_invlist = NULL;
4220         bool invlist_in_swash_is_valid = FALSE;
4221         bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
4222                                             an unclaimed reference count */
4223
4224         /* If this operation fetched a swash, get its already existing
4225          * inversion list, or create one for it */
4226
4227         if (swash_hv) {
4228             swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
4229             if (swash_invlistsvp) {
4230                 swash_invlist = *swash_invlistsvp;
4231                 invlist_in_swash_is_valid = TRUE;
4232             }
4233             else {
4234                 swash_invlist = _swash_to_invlist(retval);
4235                 swash_invlist_unclaimed = TRUE;
4236             }
4237         }
4238
4239         /* If an inversion list was passed in, have to include it */
4240         if (invlist) {
4241
4242             /* Any fetched swash will by now have an inversion list in it;
4243              * otherwise <swash_invlist>  will be NULL, indicating that we
4244              * didn't fetch a swash */
4245             if (swash_invlist) {
4246
4247                 /* Add the passed-in inversion list, which invalidates the one
4248                  * already stored in the swash */
4249                 invlist_in_swash_is_valid = FALSE;
4250                 SvREADONLY_off(swash_invlist);  /* Turned on again below */
4251                 _invlist_union(invlist, swash_invlist, &swash_invlist);
4252             }
4253             else {
4254
4255                 /* Here, there is no swash already.  Set up a minimal one, if
4256                  * we are going to return a swash */
4257                 if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
4258                     swash_hv = newHV();
4259                     retval = newRV_noinc(MUTABLE_SV(swash_hv));
4260                 }
4261                 swash_invlist = invlist;
4262             }
4263         }
4264
4265         /* Here, we have computed the union of all the passed-in data.  It may
4266          * be that there was an inversion list in the swash which didn't get
4267          * touched; otherwise save the computed one */
4268         if (! invlist_in_swash_is_valid
4269             && (int) _invlist_len(swash_invlist) > invlist_swash_boundary)
4270         {
4271             if (! hv_stores(MUTABLE_HV(SvRV(retval)), "V", swash_invlist))
4272             {
4273                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
4274             }
4275             /* We just stole a reference count. */
4276             if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
4277             else SvREFCNT_inc_simple_void_NN(swash_invlist);
4278         }
4279
4280         /* The result is immutable.  Forbid attempts to change it. */
4281         SvREADONLY_on(swash_invlist);
4282
4283         /* Use the inversion list stand-alone if small enough */
4284         if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
4285             SvREFCNT_dec(retval);
4286             if (!swash_invlist_unclaimed)
4287                 SvREFCNT_inc_simple_void_NN(swash_invlist);
4288             retval = newRV_noinc(swash_invlist);
4289         }
4290     }
4291
4292     CORE_SWASH_INIT_RETURN(retval);
4293 #undef CORE_SWASH_INIT_RETURN
4294 }
4295
4296
4297 /* This API is wrong for special case conversions since we may need to
4298  * return several Unicode characters for a single Unicode character
4299  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
4300  * the lower-level routine, and it is similarly broken for returning
4301  * multiple values.  --jhi