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