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