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