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