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