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