This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Whitespace only
[perl5.git] / utf8.c
1 /*    utf8.c
2  *
3  *    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'What a fix!' said Sam.  'That's the one place in all the lands we've ever
13  *  heard of that we don't want to see any closer; and that's the one place
14  *  we're trying to get to!  And that's just where we can't get, nohow.'
15  *
16  *     [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
17  *
18  * 'Well do I understand your speech,' he answered in the same language;
19  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
20  *  as is the custom in the West, if you wish to be answered?'
21  *                           --Gandalf, addressing Théoden's door wardens
22  *
23  *     [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
24  *
25  * ...the travellers perceived that the floor was paved with stones of many
26  * hues; branching runes and strange devices intertwined beneath their feet.
27  *
28  *     [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
29  */
30
31 #include "EXTERN.h"
32 #define PERL_IN_UTF8_C
33 #include "perl.h"
34
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_warner(aTHX_ packWARN(WARN_UTF8),
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_warner(aTHX_ packWARN(WARN_UTF8),
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_warner(aTHX_ packWARN(WARN_UTF8),
165                  "Unicode non-character U+%04"UVXf" is illegal for open interchange",
166                  uv);
167             }
168             if (flags & UNICODE_DISALLOW_NONCHAR) {
169                 return NULL;
170             }
171         }
172     }
173     if (UNI_IS_INVARIANT(uv)) {
174         *d++ = (U8)UTF_TO_NATIVE(uv);
175         return d;
176     }
177 #if defined(EBCDIC)
178     else {
179         STRLEN len  = UNISKIP(uv);
180         U8 *p = d+len-1;
181         while (p > d) {
182             *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
183             uv >>= UTF_ACCUMULATION_SHIFT;
184         }
185         *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
186         return d+len;
187     }
188 #else /* Non loop style */
189     if (uv < 0x800) {
190         *d++ = (U8)(( uv >>  6)         | 0xc0);
191         *d++ = (U8)(( uv        & 0x3f) | 0x80);
192         return d;
193     }
194     if (uv < 0x10000) {
195         *d++ = (U8)(( uv >> 12)         | 0xe0);
196         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
197         *d++ = (U8)(( uv        & 0x3f) | 0x80);
198         return d;
199     }
200     if (uv < 0x200000) {
201         *d++ = (U8)(( uv >> 18)         | 0xf0);
202         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
203         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
204         *d++ = (U8)(( uv        & 0x3f) | 0x80);
205         return d;
206     }
207     if (uv < 0x4000000) {
208         *d++ = (U8)(( uv >> 24)         | 0xf8);
209         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
210         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
211         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
212         *d++ = (U8)(( uv        & 0x3f) | 0x80);
213         return d;
214     }
215     if (uv < 0x80000000) {
216         *d++ = (U8)(( uv >> 30)         | 0xfc);
217         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
218         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
219         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
220         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
221         *d++ = (U8)(( uv        & 0x3f) | 0x80);
222         return d;
223     }
224 #ifdef HAS_QUAD
225     if (uv < UTF8_QUAD_MAX)
226 #endif
227     {
228         *d++ =                            0xfe; /* Can't match U+FEFF! */
229         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
230         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
231         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
232         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
233         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
234         *d++ = (U8)(( uv        & 0x3f) | 0x80);
235         return d;
236     }
237 #ifdef HAS_QUAD
238     {
239         *d++ =                            0xff;         /* Can't match U+FFFE! */
240         *d++ =                            0x80;         /* 6 Reserved bits */
241         *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80);        /* 2 Reserved bits */
242         *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
243         *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
244         *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
245         *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
246         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
247         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
248         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
249         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
250         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
251         *d++ = (U8)(( uv        & 0x3f) | 0x80);
252         return d;
253     }
254 #endif
255 #endif /* Loop style */
256 }
257
258 /*
259
260 Tests if some arbitrary number of bytes begins in a valid UTF-8
261 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
262 UTF-8 character.  The actual number of bytes in the UTF-8 character
263 will be returned if it is valid, otherwise 0.
264
265 This is the "slow" version as opposed to the "fast" version which is
266 the "unrolled" IS_UTF8_CHAR().  E.g. for t/uni/class.t the speed
267 difference is a factor of 2 to 3.  For lengths (UTF8SKIP(s)) of four
268 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
269 you should use the _slow().  In practice this means that the _slow()
270 will be used very rarely, since the maximum Unicode code point (as of
271 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes.  Only
272 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
273 five bytes or more.
274
275 =cut */
276 STATIC STRLEN
277 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
278 {
279     U8 u = *s;
280     STRLEN slen;
281     UV uv, ouv;
282
283     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
284
285     if (UTF8_IS_INVARIANT(u))
286         return 1;
287
288     if (!UTF8_IS_START(u))
289         return 0;
290
291     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
292         return 0;
293
294     slen = len - 1;
295     s++;
296 #ifdef EBCDIC
297     u = NATIVE_TO_UTF(u);
298 #endif
299     u &= UTF_START_MASK(len);
300     uv  = u;
301     ouv = uv;
302     while (slen--) {
303         if (!UTF8_IS_CONTINUATION(*s))
304             return 0;
305         uv = UTF8_ACCUMULATE(uv, *s);
306         if (uv < ouv)
307             return 0;
308         ouv = uv;
309         s++;
310     }
311
312     if ((STRLEN)UNISKIP(uv) < len)
313         return 0;
314
315     return len;
316 }
317
318 /*
319 =for apidoc is_utf8_char
320
321 Tests if some arbitrary number of bytes begins in a valid UTF-8
322 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
323 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
324 character will be returned if it is valid, otherwise 0.
325
326 =cut */
327 STRLEN
328 Perl_is_utf8_char(const U8 *s)
329 {
330     const STRLEN len = UTF8SKIP(s);
331
332     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
333 #ifdef IS_UTF8_CHAR
334     if (IS_UTF8_CHAR_FAST(len))
335         return IS_UTF8_CHAR(s, len) ? len : 0;
336 #endif /* #ifdef IS_UTF8_CHAR */
337     return is_utf8_char_slow(s, len);
338 }
339
340
341 /*
342 =for apidoc is_utf8_string
343
344 Returns true if first C<len> bytes of the given string form a valid
345 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated
346 using C<strlen(s)>.  Note that 'a valid UTF-8 string' does not mean 'a
347 string that contains code points above 0x7F encoded in UTF-8' because a
348 valid ASCII string is a valid UTF-8 string.
349
350 See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
351
352 =cut
353 */
354
355 bool
356 Perl_is_utf8_string(const U8 *s, STRLEN len)
357 {
358     const U8* const send = s + (len ? len : strlen((const char *)s));
359     const U8* x = s;
360
361     PERL_ARGS_ASSERT_IS_UTF8_STRING;
362
363     while (x < send) {
364         STRLEN c;
365          /* Inline the easy bits of is_utf8_char() here for speed... */
366          if (UTF8_IS_INVARIANT(*x))
367               c = 1;
368          else if (!UTF8_IS_START(*x))
369              goto out;
370          else {
371               /* ... and call is_utf8_char() only if really needed. */
372 #ifdef IS_UTF8_CHAR
373              c = UTF8SKIP(x);
374              if (IS_UTF8_CHAR_FAST(c)) {
375                  if (!IS_UTF8_CHAR(x, c))
376                      c = 0;
377              }
378              else
379                 c = is_utf8_char_slow(x, c);
380 #else
381              c = is_utf8_char(x);
382 #endif /* #ifdef IS_UTF8_CHAR */
383               if (!c)
384                   goto out;
385          }
386         x += c;
387     }
388
389  out:
390     if (x != send)
391         return FALSE;
392
393     return TRUE;
394 }
395
396 /*
397 Implemented as a macro in utf8.h
398
399 =for apidoc is_utf8_string_loc
400
401 Like is_utf8_string() but stores the location of the failure (in the
402 case of "utf8ness failure") or the location s+len (in the case of
403 "utf8ness success") in the C<ep>.
404
405 See also is_utf8_string_loclen() and is_utf8_string().
406
407 =for apidoc is_utf8_string_loclen
408
409 Like is_utf8_string() but stores the location of the failure (in the
410 case of "utf8ness failure") or the location s+len (in the case of
411 "utf8ness success") in the C<ep>, and the number of UTF-8
412 encoded characters in the C<el>.
413
414 See also is_utf8_string_loc() and is_utf8_string().
415
416 =cut
417 */
418
419 bool
420 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
421 {
422     const U8* const send = s + (len ? len : strlen((const char *)s));
423     const U8* x = s;
424     STRLEN c;
425     STRLEN outlen = 0;
426
427     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
428
429     while (x < send) {
430          /* Inline the easy bits of is_utf8_char() here for speed... */
431          if (UTF8_IS_INVARIANT(*x))
432              c = 1;
433          else if (!UTF8_IS_START(*x))
434              goto out;
435          else {
436              /* ... and call is_utf8_char() only if really needed. */
437 #ifdef IS_UTF8_CHAR
438              c = UTF8SKIP(x);
439              if (IS_UTF8_CHAR_FAST(c)) {
440                  if (!IS_UTF8_CHAR(x, c))
441                      c = 0;
442              } else
443                  c = is_utf8_char_slow(x, c);
444 #else
445              c = is_utf8_char(x);
446 #endif /* #ifdef IS_UTF8_CHAR */
447              if (!c)
448                  goto out;
449          }
450          x += c;
451          outlen++;
452     }
453
454  out:
455     if (el)
456         *el = outlen;
457
458     if (ep)
459         *ep = x;
460     return (x == send);
461 }
462
463 /*
464
465 =for apidoc utf8n_to_uvuni
466
467 Bottom level UTF-8 decode routine.
468 Returns the code point value of the first character in the string C<s>
469 which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding and no longer than
470 C<curlen> bytes; C<retlen> will be set to the length, in bytes, of that
471 character.
472
473 The value of C<flags> determines the behavior when C<s> does not point to a
474 well-formed UTF-8 character.  If C<flags> is 0, when a malformation is found,
475 C<retlen> is set to the expected length of the UTF-8 character in bytes, zero
476 is returned, and if UTF-8 warnings haven't been lexically disabled, a warning
477 is raised.
478
479 Various ALLOW flags can be set in C<flags> to allow (and not warn on)
480 individual types of malformations, such as the sequence being overlong (that
481 is, when there is a shorter sequence that can express the same code point;
482 overlong sequences are expressly forbidden in the UTF-8 standard due to
483 potential security issues).  Another malformation example is the first byte of
484 a character not being a legal first byte.  See F<utf8.h> for the list of such
485 flags.  Of course, the value returned by this function under such conditions is
486 not reliable.
487
488 The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
489 flags) malformation is found.  If this flag is set, the routine assumes that
490 the caller will raise a warning, and this function will silently just set
491 C<retlen> to C<-1> and return zero.
492
493 Certain code points are considered problematic.  These are Unicode surrogates,
494 Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
495 By default these are considered regular code points, but certain situations
496 warrant special handling for them.  if C<flags> contains
497 UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
498 malformations and handled as such.  The flags UTF8_DISALLOW_SURROGATE,
499 UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
500 maximum) can be set to disallow these categories individually.
501
502 The flags UTF8_WARN_ILLEGAL_INTERCHANGE, UTF8_WARN_SURROGATE,
503 UTF8_WARN_NONCHAR, and UTF8_WARN_SUPER will cause warning messages to be raised
504 for their respective categories, but otherwise the code points are considered
505 valid (not malformations).  To get a category to both be treated as a
506 malformation and raise a warning, specify both the WARN and DISALLOW flags.
507 (But note that warnings are not raised if lexically disabled nor if
508 UTF8_CHECK_ONLY is also specified.)
509
510 Very large code points (above 0x7FFF_FFFF) are considered more problematic than
511 the others that are above the Unicode legal maximum.  There are several
512 reasons, one of which is that the original UTF-8 specification never went above
513 this number (the current 0x10FFF limit was imposed later).  The UTF-8 encoding
514 on ASCII platforms for these large code point begins with a byte containing
515 0xFE or 0xFF.  The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
516 malformations, while allowing smaller above-Unicode code points.  (Of course
517 UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,
518 as malformations.) Similarly, UTF8_WARN_FE_FF acts just like the other WARN
519 flags, but applies just to these code points.
520
521 All other code points corresponding to Unicode characters, including private
522 use and those yet to be assigned, are never considered malformed and never
523 warn.
524
525 Most code should use utf8_to_uvchr() rather than call this directly.
526
527 =cut
528 */
529
530 UV
531 Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
532 {
533     dVAR;
534     const U8 * const s0 = s;
535     UV uv = *s, ouv = 0;
536     STRLEN len = 1;
537     bool dowarn = ckWARN_d(WARN_UTF8);
538     const UV startbyte = *s;
539     STRLEN expectlen = 0;
540     U32 warning = 0;
541     SV* sv = NULL;
542
543     PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
544
545 /* This list is a superset of the UTF8_ALLOW_XXX. */
546
547 #define UTF8_WARN_EMPTY                          1
548 #define UTF8_WARN_CONTINUATION                   2
549 #define UTF8_WARN_NON_CONTINUATION               3
550 #define UTF8_WARN_SHORT                          5
551 #define UTF8_WARN_OVERFLOW                       6
552 #define UTF8_WARN_LONG                           8
553
554     if (curlen == 0 &&
555         !(flags & UTF8_ALLOW_EMPTY)) {
556         warning = UTF8_WARN_EMPTY;
557         goto malformed;
558     }
559
560     if (UTF8_IS_INVARIANT(uv)) {
561         if (retlen)
562             *retlen = 1;
563         return (UV) (NATIVE_TO_UTF(*s));
564     }
565
566     if (UTF8_IS_CONTINUATION(uv) &&
567         !(flags & UTF8_ALLOW_CONTINUATION)) {
568         warning = UTF8_WARN_CONTINUATION;
569         goto malformed;
570     }
571
572     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
573         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
574         warning = UTF8_WARN_NON_CONTINUATION;
575         goto malformed;
576     }
577
578 #ifdef EBCDIC
579     uv = NATIVE_TO_UTF(uv);
580 #else
581     if (uv == 0xfe || uv == 0xff) {
582         if (flags & (UTF8_WARN_SUPER|UTF8_WARN_FE_FF)) {
583             sv = sv_2mortal(newSVpvf_nocontext("Code point beginning with byte 0x%02"UVXf" is not Unicode, and not portable", uv));
584             flags &= ~UTF8_WARN_SUPER;  /* Only warn once on this problem */
585         }
586         if (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_FE_FF)) {
587             goto malformed;
588         }
589     }
590 #endif
591
592     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
593     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
594     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
595     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
596 #ifdef EBCDIC
597     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
598     else                        { len =  7; uv &= 0x01; }
599 #else
600     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
601     else if (!(uv & 0x01))      { len =  7; uv = 0; }
602     else                        { len = 13; uv = 0; } /* whoa! */
603 #endif
604
605     if (retlen)
606         *retlen = len;
607
608     expectlen = len;
609
610     if ((curlen < expectlen) &&
611         !(flags & UTF8_ALLOW_SHORT)) {
612         warning = UTF8_WARN_SHORT;
613         goto malformed;
614     }
615
616     len--;
617     s++;
618     ouv = uv;   /* ouv is the value from the previous iteration */
619
620     while (len--) {
621         if (!UTF8_IS_CONTINUATION(*s) &&
622             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
623             s--;
624             warning = UTF8_WARN_NON_CONTINUATION;
625             goto malformed;
626         }
627         else
628             uv = UTF8_ACCUMULATE(uv, *s);
629         if (!(uv > ouv)) {  /* If the value didn't grow from the previous
630                                iteration, something is horribly wrong */
631             /* These cannot be allowed. */
632             if (uv == ouv) {
633                 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
634                     warning = UTF8_WARN_LONG;
635                     goto malformed;
636                 }
637             }
638             else { /* uv < ouv */
639                 /* This cannot be allowed. */
640                 warning = UTF8_WARN_OVERFLOW;
641                 goto malformed;
642             }
643         }
644         s++;
645         ouv = uv;
646     }
647
648     if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) {
649         warning = UTF8_WARN_LONG;
650         goto malformed;
651     } else if (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE)) {
652         if (UNICODE_IS_SURROGATE(uv)) {
653             if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE) {
654                 sv = sv_2mortal(newSVpvf_nocontext("UTF-16 surrogate U+%04"UVXf"", uv));
655             }
656             if (flags & UTF8_DISALLOW_SURROGATE) {
657                 goto disallowed;
658             }
659         }
660         else if (UNICODE_IS_NONCHAR(uv)) {
661             if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR ) {
662                 sv = sv_2mortal(newSVpvf_nocontext("Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
663             }
664             if (flags & UTF8_DISALLOW_NONCHAR) {
665                 goto disallowed;
666             }
667         }
668         else if ((uv > PERL_UNICODE_MAX)) {
669             if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER) {
670                 sv = sv_2mortal(newSVpvf_nocontext("Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
671             }
672             if (flags & UTF8_DISALLOW_SUPER) {
673                 goto disallowed;
674             }
675         }
676
677         /* Here, this is not considered a malformed character, so drop through
678          * to return it */
679     }
680
681     return uv;
682
683 disallowed: /* Is disallowed, but otherwise not malformed.  'sv' will have been
684                set if there is to be a warning. */
685     if (!sv) {
686         dowarn = 0;
687     }
688
689 malformed:
690
691     if (flags & UTF8_CHECK_ONLY) {
692         if (retlen)
693             *retlen = ((STRLEN) -1);
694         return 0;
695     }
696
697     if (dowarn) {
698         if (! sv) {
699             sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
700         }
701
702         switch (warning) {
703             case 0: /* Intentionally empty. */ break;
704             case UTF8_WARN_EMPTY:
705                 sv_catpvs(sv, "(empty string)");
706                 break;
707             case UTF8_WARN_CONTINUATION:
708                 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
709                 break;
710             case UTF8_WARN_NON_CONTINUATION:
711                 if (s == s0)
712                     Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
713                                 (UV)s[1], startbyte);
714                 else {
715                     const int len = (int)(s-s0);
716                     Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
717                                 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
718                 }
719
720                 break;
721             case UTF8_WARN_SHORT:
722                 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
723                                 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
724                 expectlen = curlen;             /* distance for caller to skip */
725                 break;
726             case UTF8_WARN_OVERFLOW:
727                 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
728                                 ouv, *s, startbyte);
729                 break;
730             case UTF8_WARN_LONG:
731                 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
732                                 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
733                 break;
734             default:
735                 sv_catpvs(sv, "(unknown reason)");
736                 break;
737         }
738         
739         if (sv) {
740             const char * const s = SvPVX_const(sv);
741
742             if (PL_op)
743                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
744                             "%s in %s", s,  OP_DESC(PL_op));
745             else
746                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
747         }
748     }
749
750     if (retlen)
751         *retlen = expectlen ? expectlen : len;
752
753     return 0;
754 }
755
756 /*
757 =for apidoc utf8_to_uvchr
758
759 Returns the native code point of the first character in the string C<s>
760 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
761 length, in bytes, of that character.
762
763 If C<s> does not point to a well-formed UTF-8 character, zero is
764 returned and retlen is set, if possible, to -1.
765
766 =cut
767 */
768
769 UV
770 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
771 {
772     PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
773
774     return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
775                           ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
776 }
777
778 /*
779 =for apidoc utf8_to_uvuni
780
781 Returns the Unicode code point of the first character in the string C<s>
782 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
783 length, in bytes, of that character.
784
785 This function should only be used when the returned UV is considered
786 an index into the Unicode semantic tables (e.g. swashes).
787
788 If C<s> does not point to a well-formed UTF-8 character, zero is
789 returned and retlen is set, if possible, to -1.
790
791 =cut
792 */
793
794 UV
795 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
796 {
797     PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
798
799     /* Call the low level routine asking for checks */
800     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
801                                ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
802 }
803
804 /*
805 =for apidoc utf8_length
806
807 Return the length of the UTF-8 char encoded string C<s> in characters.
808 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
809 up past C<e>, croaks.
810
811 =cut
812 */
813
814 STRLEN
815 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
816 {
817     dVAR;
818     STRLEN len = 0;
819
820     PERL_ARGS_ASSERT_UTF8_LENGTH;
821
822     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
823      * the bitops (especially ~) can create illegal UTF-8.
824      * In other words: in Perl UTF-8 is not just for Unicode. */
825
826     if (e < s)
827         goto warn_and_return;
828     while (s < e) {
829         if (!UTF8_IS_INVARIANT(*s))
830             s += UTF8SKIP(s);
831         else
832             s++;
833         len++;
834     }
835
836     if (e != s) {
837         len--;
838         warn_and_return:
839         if (PL_op)
840             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
841                              "%s in %s", unees, OP_DESC(PL_op));
842         else
843             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
844     }
845
846     return len;
847 }
848
849 /*
850 =for apidoc utf8_distance
851
852 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
853 and C<b>.
854
855 WARNING: use only if you *know* that the pointers point inside the
856 same UTF-8 buffer.
857
858 =cut
859 */
860
861 IV
862 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
863 {
864     PERL_ARGS_ASSERT_UTF8_DISTANCE;
865
866     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
867 }
868
869 /*
870 =for apidoc utf8_hop
871
872 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
873 forward or backward.
874
875 WARNING: do not use the following unless you *know* C<off> is within
876 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
877 on the first byte of character or just after the last byte of a character.
878
879 =cut
880 */
881
882 U8 *
883 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
884 {
885     PERL_ARGS_ASSERT_UTF8_HOP;
886
887     PERL_UNUSED_CONTEXT;
888     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
889      * the bitops (especially ~) can create illegal UTF-8.
890      * In other words: in Perl UTF-8 is not just for Unicode. */
891
892     if (off >= 0) {
893         while (off--)
894             s += UTF8SKIP(s);
895     }
896     else {
897         while (off++) {
898             s--;
899             while (UTF8_IS_CONTINUATION(*s))
900                 s--;
901         }
902     }
903     return (U8 *)s;
904 }
905
906 /*
907 =for apidoc bytes_cmp_utf8
908
909 Compares the sequence of characters (stored as octets) in b, blen with the
910 sequence of characters (stored as UTF-8) in u, ulen. Returns 0 if they are
911 equal, -1 or -2 if the first string is less than the second string, +1 or +2
912 if the first string is greater than the second string.
913
914 -1 or +1 is returned if the shorter string was identical to the start of the
915 longer string. -2 or +2 is returned if the was a difference between characters
916 within the strings.
917
918 =cut
919 */
920
921 int
922 Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
923 {
924     const U8 *const bend = b + blen;
925     const U8 *const uend = u + ulen;
926
927     PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
928
929     PERL_UNUSED_CONTEXT;
930
931     while (b < bend && u < uend) {
932         U8 c = *u++;
933         if (!UTF8_IS_INVARIANT(c)) {
934             if (UTF8_IS_DOWNGRADEABLE_START(c)) {
935                 if (u < uend) {
936                     U8 c1 = *u++;
937                     if (UTF8_IS_CONTINUATION(c1)) {
938                         c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1));
939                     } else {
940                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
941                                          "Malformed UTF-8 character "
942                                          "(unexpected non-continuation byte 0x%02x"
943                                          ", immediately after start byte 0x%02x)"
944                                          /* Dear diag.t, it's in the pod.  */
945                                          "%s%s", c1, c,
946                                          PL_op ? " in " : "",
947                                          PL_op ? OP_DESC(PL_op) : "");
948                         return -2;
949                     }
950                 } else {
951                     if (PL_op)
952                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
953                                          "%s in %s", unees, OP_DESC(PL_op));
954                     else
955                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
956                     return -2; /* Really want to return undef :-)  */
957                 }
958             } else {
959                 return -2;
960             }
961         }
962         if (*b != c) {
963             return *b < c ? -2 : +2;
964         }
965         ++b;
966     }
967
968     if (b == bend && u == uend)
969         return 0;
970
971     return b < bend ? +1 : -1;
972 }
973
974 /*
975 =for apidoc utf8_to_bytes
976
977 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
978 Unlike C<bytes_to_utf8>, this over-writes the original string, and
979 updates len to contain the new length.
980 Returns zero on failure, setting C<len> to -1.
981
982 If you need a copy of the string, see C<bytes_from_utf8>.
983
984 =cut
985 */
986
987 U8 *
988 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
989 {
990     U8 * const save = s;
991     U8 * const send = s + *len;
992     U8 *d;
993
994     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
995
996     /* ensure valid UTF-8 and chars < 256 before updating string */
997     while (s < send) {
998         U8 c = *s++;
999
1000         if (!UTF8_IS_INVARIANT(c) &&
1001             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
1002              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
1003             *len = ((STRLEN) -1);
1004             return 0;
1005         }
1006     }
1007
1008     d = s = save;
1009     while (s < send) {
1010         STRLEN ulen;
1011         *d++ = (U8)utf8_to_uvchr(s, &ulen);
1012         s += ulen;
1013     }
1014     *d = '\0';
1015     *len = d - save;
1016     return save;
1017 }
1018
1019 /*
1020 =for apidoc bytes_from_utf8
1021
1022 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
1023 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
1024 the newly-created string, and updates C<len> to contain the new
1025 length.  Returns the original string if no conversion occurs, C<len>
1026 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
1027 0 if C<s> is converted or consisted entirely of characters that are invariant
1028 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
1029
1030 =cut
1031 */
1032
1033 U8 *
1034 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
1035 {
1036     U8 *d;
1037     const U8 *start = s;
1038     const U8 *send;
1039     I32 count = 0;
1040
1041     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
1042
1043     PERL_UNUSED_CONTEXT;
1044     if (!*is_utf8)
1045         return (U8 *)start;
1046
1047     /* ensure valid UTF-8 and chars < 256 before converting string */
1048     for (send = s + *len; s < send;) {
1049         U8 c = *s++;
1050         if (!UTF8_IS_INVARIANT(c)) {
1051             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
1052                 (c = *s++) && UTF8_IS_CONTINUATION(c))
1053                 count++;
1054             else
1055                 return (U8 *)start;
1056         }
1057     }
1058
1059     *is_utf8 = FALSE;
1060
1061     Newx(d, (*len) - count + 1, U8);
1062     s = start; start = d;
1063     while (s < send) {
1064         U8 c = *s++;
1065         if (!UTF8_IS_INVARIANT(c)) {
1066             /* Then it is two-byte encoded */
1067             c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, *s++));
1068         }
1069         *d++ = c;
1070     }
1071     *d = '\0';
1072     *len = d - start;
1073     return (U8 *)start;
1074 }
1075
1076 /*
1077 =for apidoc bytes_to_utf8
1078
1079 Converts a string C<s> of length C<len> bytes from the native encoding into
1080 UTF-8.
1081 Returns a pointer to the newly-created string, and sets C<len> to
1082 reflect the new length in bytes.
1083
1084 A NUL character will be written after the end of the string.
1085
1086 If you want to convert to UTF-8 from encodings other than
1087 the native (Latin1 or EBCDIC),
1088 see sv_recode_to_utf8().
1089
1090 =cut
1091 */
1092
1093 U8*
1094 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
1095 {
1096     const U8 * const send = s + (*len);
1097     U8 *d;
1098     U8 *dst;
1099
1100     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
1101     PERL_UNUSED_CONTEXT;
1102
1103     Newx(d, (*len) * 2 + 1, U8);
1104     dst = d;
1105
1106     while (s < send) {
1107         const UV uv = NATIVE_TO_ASCII(*s++);
1108         if (UNI_IS_INVARIANT(uv))
1109             *d++ = (U8)UTF_TO_NATIVE(uv);
1110         else {
1111             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1112             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
1113         }
1114     }
1115     *d = '\0';
1116     *len = d-dst;
1117     return dst;
1118 }
1119
1120 /*
1121  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
1122  *
1123  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
1124  * We optimize for native, for obvious reasons. */
1125
1126 U8*
1127 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1128 {
1129     U8* pend;
1130     U8* dstart = d;
1131
1132     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1133
1134     if (bytelen & 1)
1135         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
1136
1137     pend = p + bytelen;
1138
1139     while (p < pend) {
1140         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1141         p += 2;
1142         if (uv < 0x80) {
1143 #ifdef EBCDIC
1144             *d++ = UNI_TO_NATIVE(uv);
1145 #else
1146             *d++ = (U8)uv;
1147 #endif
1148             continue;
1149         }
1150         if (uv < 0x800) {
1151             *d++ = (U8)(( uv >>  6)         | 0xc0);
1152             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1153             continue;
1154         }
1155         if (uv >= 0xd800 && uv <= 0xdbff) {     /* surrogates */
1156             if (p >= pend) {
1157                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1158             } else {
1159                 UV low = (p[0] << 8) + p[1];
1160                 p += 2;
1161                 if (low < 0xdc00 || low > 0xdfff)
1162                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1163                 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
1164             }
1165         } else if (uv >= 0xdc00 && uv <= 0xdfff) {
1166             Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1167         }
1168         if (uv < 0x10000) {
1169             *d++ = (U8)(( uv >> 12)         | 0xe0);
1170             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1171             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1172             continue;
1173         }
1174         else {
1175             *d++ = (U8)(( uv >> 18)         | 0xf0);
1176             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1177             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1178             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1179             continue;
1180         }
1181     }
1182     *newlen = d - dstart;
1183     return d;
1184 }
1185
1186 /* Note: this one is slightly destructive of the source. */
1187
1188 U8*
1189 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1190 {
1191     U8* s = (U8*)p;
1192     U8* const send = s + bytelen;
1193
1194     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1195
1196     if (bytelen & 1)
1197         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1198                    (UV)bytelen);
1199
1200     while (s < send) {
1201         const U8 tmp = s[0];
1202         s[0] = s[1];
1203         s[1] = tmp;
1204         s += 2;
1205     }
1206     return utf16_to_utf8(p, d, bytelen, newlen);
1207 }
1208
1209 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1210
1211 bool
1212 Perl_is_uni_alnum(pTHX_ UV c)
1213 {
1214     U8 tmpbuf[UTF8_MAXBYTES+1];
1215     uvchr_to_utf8(tmpbuf, c);
1216     return is_utf8_alnum(tmpbuf);
1217 }
1218
1219 bool
1220 Perl_is_uni_idfirst(pTHX_ UV c)
1221 {
1222     U8 tmpbuf[UTF8_MAXBYTES+1];
1223     uvchr_to_utf8(tmpbuf, c);
1224     return is_utf8_idfirst(tmpbuf);
1225 }
1226
1227 bool
1228 Perl_is_uni_alpha(pTHX_ UV c)
1229 {
1230     U8 tmpbuf[UTF8_MAXBYTES+1];
1231     uvchr_to_utf8(tmpbuf, c);
1232     return is_utf8_alpha(tmpbuf);
1233 }
1234
1235 bool
1236 Perl_is_uni_ascii(pTHX_ UV c)
1237 {
1238     U8 tmpbuf[UTF8_MAXBYTES+1];
1239     uvchr_to_utf8(tmpbuf, c);
1240     return is_utf8_ascii(tmpbuf);
1241 }
1242
1243 bool
1244 Perl_is_uni_space(pTHX_ UV c)
1245 {
1246     U8 tmpbuf[UTF8_MAXBYTES+1];
1247     uvchr_to_utf8(tmpbuf, c);
1248     return is_utf8_space(tmpbuf);
1249 }
1250
1251 bool
1252 Perl_is_uni_digit(pTHX_ UV c)
1253 {
1254     U8 tmpbuf[UTF8_MAXBYTES+1];
1255     uvchr_to_utf8(tmpbuf, c);
1256     return is_utf8_digit(tmpbuf);
1257 }
1258
1259 bool
1260 Perl_is_uni_upper(pTHX_ UV c)
1261 {
1262     U8 tmpbuf[UTF8_MAXBYTES+1];
1263     uvchr_to_utf8(tmpbuf, c);
1264     return is_utf8_upper(tmpbuf);
1265 }
1266
1267 bool
1268 Perl_is_uni_lower(pTHX_ UV c)
1269 {
1270     U8 tmpbuf[UTF8_MAXBYTES+1];
1271     uvchr_to_utf8(tmpbuf, c);
1272     return is_utf8_lower(tmpbuf);
1273 }
1274
1275 bool
1276 Perl_is_uni_cntrl(pTHX_ UV c)
1277 {
1278     U8 tmpbuf[UTF8_MAXBYTES+1];
1279     uvchr_to_utf8(tmpbuf, c);
1280     return is_utf8_cntrl(tmpbuf);
1281 }
1282
1283 bool
1284 Perl_is_uni_graph(pTHX_ UV c)
1285 {
1286     U8 tmpbuf[UTF8_MAXBYTES+1];
1287     uvchr_to_utf8(tmpbuf, c);
1288     return is_utf8_graph(tmpbuf);
1289 }
1290
1291 bool
1292 Perl_is_uni_print(pTHX_ UV c)
1293 {
1294     U8 tmpbuf[UTF8_MAXBYTES+1];
1295     uvchr_to_utf8(tmpbuf, c);
1296     return is_utf8_print(tmpbuf);
1297 }
1298
1299 bool
1300 Perl_is_uni_punct(pTHX_ UV c)
1301 {
1302     U8 tmpbuf[UTF8_MAXBYTES+1];
1303     uvchr_to_utf8(tmpbuf, c);
1304     return is_utf8_punct(tmpbuf);
1305 }
1306
1307 bool
1308 Perl_is_uni_xdigit(pTHX_ UV c)
1309 {
1310     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1311     uvchr_to_utf8(tmpbuf, c);
1312     return is_utf8_xdigit(tmpbuf);
1313 }
1314
1315 UV
1316 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1317 {
1318     PERL_ARGS_ASSERT_TO_UNI_UPPER;
1319
1320     uvchr_to_utf8(p, c);
1321     return to_utf8_upper(p, p, lenp);
1322 }
1323
1324 UV
1325 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1326 {
1327     PERL_ARGS_ASSERT_TO_UNI_TITLE;
1328
1329     uvchr_to_utf8(p, c);
1330     return to_utf8_title(p, p, lenp);
1331 }
1332
1333 UV
1334 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1335 {
1336     PERL_ARGS_ASSERT_TO_UNI_LOWER;
1337
1338     uvchr_to_utf8(p, c);
1339     return to_utf8_lower(p, p, lenp);
1340 }
1341
1342 UV
1343 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1344 {
1345     PERL_ARGS_ASSERT_TO_UNI_FOLD;
1346
1347     uvchr_to_utf8(p, c);
1348     return to_utf8_fold(p, p, lenp);
1349 }
1350
1351 /* for now these all assume no locale info available for Unicode > 255 */
1352
1353 bool
1354 Perl_is_uni_alnum_lc(pTHX_ UV c)
1355 {
1356     return is_uni_alnum(c);     /* XXX no locale support yet */
1357 }
1358
1359 bool
1360 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1361 {
1362     return is_uni_idfirst(c);   /* XXX no locale support yet */
1363 }
1364
1365 bool
1366 Perl_is_uni_alpha_lc(pTHX_ UV c)
1367 {
1368     return is_uni_alpha(c);     /* XXX no locale support yet */
1369 }
1370
1371 bool
1372 Perl_is_uni_ascii_lc(pTHX_ UV c)
1373 {
1374     return is_uni_ascii(c);     /* XXX no locale support yet */
1375 }
1376
1377 bool
1378 Perl_is_uni_space_lc(pTHX_ UV c)
1379 {
1380     return is_uni_space(c);     /* XXX no locale support yet */
1381 }
1382
1383 bool
1384 Perl_is_uni_digit_lc(pTHX_ UV c)
1385 {
1386     return is_uni_digit(c);     /* XXX no locale support yet */
1387 }
1388
1389 bool
1390 Perl_is_uni_upper_lc(pTHX_ UV c)
1391 {
1392     return is_uni_upper(c);     /* XXX no locale support yet */
1393 }
1394
1395 bool
1396 Perl_is_uni_lower_lc(pTHX_ UV c)
1397 {
1398     return is_uni_lower(c);     /* XXX no locale support yet */
1399 }
1400
1401 bool
1402 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1403 {
1404     return is_uni_cntrl(c);     /* XXX no locale support yet */
1405 }
1406
1407 bool
1408 Perl_is_uni_graph_lc(pTHX_ UV c)
1409 {
1410     return is_uni_graph(c);     /* XXX no locale support yet */
1411 }
1412
1413 bool
1414 Perl_is_uni_print_lc(pTHX_ UV c)
1415 {
1416     return is_uni_print(c);     /* XXX no locale support yet */
1417 }
1418
1419 bool
1420 Perl_is_uni_punct_lc(pTHX_ UV c)
1421 {
1422     return is_uni_punct(c);     /* XXX no locale support yet */
1423 }
1424
1425 bool
1426 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1427 {
1428     return is_uni_xdigit(c);    /* XXX no locale support yet */
1429 }
1430
1431 U32
1432 Perl_to_uni_upper_lc(pTHX_ U32 c)
1433 {
1434     /* XXX returns only the first character -- do not use XXX */
1435     /* XXX no locale support yet */
1436     STRLEN len;
1437     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1438     return (U32)to_uni_upper(c, tmpbuf, &len);
1439 }
1440
1441 U32
1442 Perl_to_uni_title_lc(pTHX_ U32 c)
1443 {
1444     /* XXX returns only the first character XXX -- do not use XXX */
1445     /* XXX no locale support yet */
1446     STRLEN len;
1447     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1448     return (U32)to_uni_title(c, tmpbuf, &len);
1449 }
1450
1451 U32
1452 Perl_to_uni_lower_lc(pTHX_ U32 c)
1453 {
1454     /* XXX returns only the first character -- do not use XXX */
1455     /* XXX no locale support yet */
1456     STRLEN len;
1457     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1458     return (U32)to_uni_lower(c, tmpbuf, &len);
1459 }
1460
1461 static bool
1462 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1463                  const char *const swashname)
1464 {
1465     dVAR;
1466
1467     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1468
1469     if (!is_utf8_char(p))
1470         return FALSE;
1471     if (!*swash)
1472         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1473     return swash_fetch(*swash, p, TRUE) != 0;
1474 }
1475
1476 bool
1477 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1478 {
1479     dVAR;
1480
1481     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1482
1483     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1484      * descendant of isalnum(3), in other words, it doesn't
1485      * contain the '_'. --jhi */
1486     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1487 }
1488
1489 bool
1490 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1491 {
1492     dVAR;
1493
1494     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1495
1496     if (*p == '_')
1497         return TRUE;
1498     /* is_utf8_idstart would be more logical. */
1499     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1500 }
1501
1502 bool
1503 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1504 {
1505     dVAR;
1506
1507     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1508
1509     if (*p == '_')
1510         return TRUE;
1511     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1512 }
1513
1514 bool
1515 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1516 {
1517     dVAR;
1518
1519     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1520
1521     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1522 }
1523
1524 bool
1525 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1526 {
1527     dVAR;
1528
1529     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1530
1531     return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1532 }
1533
1534 bool
1535 Perl_is_utf8_space(pTHX_ const U8 *p)
1536 {
1537     dVAR;
1538
1539     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1540
1541     return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1542 }
1543
1544 bool
1545 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1546 {
1547     dVAR;
1548
1549     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1550
1551     return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
1552 }
1553
1554 bool
1555 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1556 {
1557     dVAR;
1558
1559     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1560
1561     return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
1562 }
1563
1564 bool
1565 Perl_is_utf8_digit(pTHX_ const U8 *p)
1566 {
1567     dVAR;
1568
1569     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1570
1571     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1572 }
1573
1574 bool
1575 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1576 {
1577     dVAR;
1578
1579     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1580
1581     return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
1582 }
1583
1584 bool
1585 Perl_is_utf8_upper(pTHX_ const U8 *p)
1586 {
1587     dVAR;
1588
1589     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1590
1591     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1592 }
1593
1594 bool
1595 Perl_is_utf8_lower(pTHX_ const U8 *p)
1596 {
1597     dVAR;
1598
1599     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1600
1601     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1602 }
1603
1604 bool
1605 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1606 {
1607     dVAR;
1608
1609     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1610
1611     return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1612 }
1613
1614 bool
1615 Perl_is_utf8_graph(pTHX_ const U8 *p)
1616 {
1617     dVAR;
1618
1619     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1620
1621     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1622 }
1623
1624 bool
1625 Perl_is_utf8_print(pTHX_ const U8 *p)
1626 {
1627     dVAR;
1628
1629     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1630
1631     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1632 }
1633
1634 bool
1635 Perl_is_utf8_punct(pTHX_ const U8 *p)
1636 {
1637     dVAR;
1638
1639     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1640
1641     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1642 }
1643
1644 bool
1645 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1646 {
1647     dVAR;
1648
1649     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1650
1651     return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
1652 }
1653
1654 bool
1655 Perl_is_utf8_mark(pTHX_ const U8 *p)
1656 {
1657     dVAR;
1658
1659     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1660
1661     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1662 }
1663
1664 bool
1665 Perl_is_utf8_X_begin(pTHX_ const U8 *p)
1666 {
1667     dVAR;
1668
1669     PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
1670
1671     return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
1672 }
1673
1674 bool
1675 Perl_is_utf8_X_extend(pTHX_ const U8 *p)
1676 {
1677     dVAR;
1678
1679     PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
1680
1681     return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
1682 }
1683
1684 bool
1685 Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
1686 {
1687     dVAR;
1688
1689     PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
1690
1691     return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
1692 }
1693
1694 bool
1695 Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
1696 {
1697     dVAR;
1698
1699     PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
1700
1701     return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
1702 }
1703
1704 bool
1705 Perl_is_utf8_X_L(pTHX_ const U8 *p)
1706 {
1707     dVAR;
1708
1709     PERL_ARGS_ASSERT_IS_UTF8_X_L;
1710
1711     return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
1712 }
1713
1714 bool
1715 Perl_is_utf8_X_LV(pTHX_ const U8 *p)
1716 {
1717     dVAR;
1718
1719     PERL_ARGS_ASSERT_IS_UTF8_X_LV;
1720
1721     return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
1722 }
1723
1724 bool
1725 Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
1726 {
1727     dVAR;
1728
1729     PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
1730
1731     return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
1732 }
1733
1734 bool
1735 Perl_is_utf8_X_T(pTHX_ const U8 *p)
1736 {
1737     dVAR;
1738
1739     PERL_ARGS_ASSERT_IS_UTF8_X_T;
1740
1741     return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
1742 }
1743
1744 bool
1745 Perl_is_utf8_X_V(pTHX_ const U8 *p)
1746 {
1747     dVAR;
1748
1749     PERL_ARGS_ASSERT_IS_UTF8_X_V;
1750
1751     return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
1752 }
1753
1754 bool
1755 Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
1756 {
1757     dVAR;
1758
1759     PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
1760
1761     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
1762 }
1763
1764 /*
1765 =for apidoc to_utf8_case
1766
1767 The "p" contains the pointer to the UTF-8 string encoding
1768 the character that is being converted.
1769
1770 The "ustrp" is a pointer to the character buffer to put the
1771 conversion result to.  The "lenp" is a pointer to the length
1772 of the result.
1773
1774 The "swashp" is a pointer to the swash to use.
1775
1776 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1777 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1778 but not always, a multicharacter mapping), is tried first.
1779
1780 The "special" is a string like "utf8::ToSpecLower", which means the
1781 hash %utf8::ToSpecLower.  The access to the hash is through
1782 Perl_to_utf8_case().
1783
1784 The "normal" is a string like "ToLower" which means the swash
1785 %utf8::ToLower.
1786
1787 =cut */
1788
1789 UV
1790 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1791                         SV **swashp, const char *normal, const char *special)
1792 {
1793     dVAR;
1794     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1795     STRLEN len = 0;
1796     const UV uv0 = utf8_to_uvchr(p, NULL);
1797     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1798      * are necessary in EBCDIC, they are redundant no-ops
1799      * in ASCII-ish platforms, and hopefully optimized away. */
1800     const UV uv1 = NATIVE_TO_UNI(uv0);
1801
1802     PERL_ARGS_ASSERT_TO_UTF8_CASE;
1803
1804     uvuni_to_utf8(tmpbuf, uv1);
1805
1806     if (!*swashp) /* load on-demand */
1807          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1808     /* This is the beginnings of a skeleton of code to read the info section
1809      * that is in all the swashes in case we ever want to do that, so one can
1810      * read things whose maps aren't code points, and whose default if missing
1811      * is not to the code point itself.  This was just to see if it actually
1812      * worked.  Details on what the possibilities are are in perluniprops.pod
1813         HV * const hv = get_hv("utf8::SwashInfo", 0);
1814         if (hv) {
1815          SV **svp;
1816          svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE);
1817              const char *s;
1818
1819               HV * const this_hash = SvRV(*svp);
1820                 svp = hv_fetch(this_hash, "type", strlen("type"), FALSE);
1821               s = SvPV_const(*svp, len);
1822         }
1823     }*/
1824
1825     if (special) {
1826          /* It might be "special" (sometimes, but not always,
1827           * a multicharacter mapping) */
1828          HV * const hv = get_hv(special, 0);
1829          SV **svp;
1830
1831          if (hv &&
1832              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1833              (*svp)) {
1834              const char *s;
1835
1836               s = SvPV_const(*svp, len);
1837               if (len == 1)
1838                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1839               else {
1840 #ifdef EBCDIC
1841                    /* If we have EBCDIC we need to remap the characters
1842                     * since any characters in the low 256 are Unicode
1843                     * code points, not EBCDIC. */
1844                    U8 *t = (U8*)s, *tend = t + len, *d;
1845                 
1846                    d = tmpbuf;
1847                    if (SvUTF8(*svp)) {
1848                         STRLEN tlen = 0;
1849                         
1850                         while (t < tend) {
1851                              const UV c = utf8_to_uvchr(t, &tlen);
1852                              if (tlen > 0) {
1853                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1854                                   t += tlen;
1855                              }
1856                              else
1857                                   break;
1858                         }
1859                    }
1860                    else {
1861                         while (t < tend) {
1862                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1863                              t++;
1864                         }
1865                    }
1866                    len = d - tmpbuf;
1867                    Copy(tmpbuf, ustrp, len, U8);
1868 #else
1869                    Copy(s, ustrp, len, U8);
1870 #endif
1871               }
1872          }
1873     }
1874
1875     if (!len && *swashp) {
1876         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1877
1878          if (uv2) {
1879               /* It was "normal" (a single character mapping). */
1880               const UV uv3 = UNI_TO_NATIVE(uv2);
1881               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1882          }
1883     }
1884
1885     if (!len) /* Neither: just copy.  In other words, there was no mapping
1886                  defined, which means that the code point maps to itself */
1887          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1888
1889     if (lenp)
1890          *lenp = len;
1891
1892     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1893 }
1894
1895 /*
1896 =for apidoc to_utf8_upper
1897
1898 Convert the UTF-8 encoded character at p to its uppercase version and
1899 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1900 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1901 the uppercase version may be longer than the original character.
1902
1903 The first character of the uppercased version is returned
1904 (but note, as explained above, that there may be more.)
1905
1906 =cut */
1907
1908 UV
1909 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1910 {
1911     dVAR;
1912
1913     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1914
1915     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1916                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1917 }
1918
1919 /*
1920 =for apidoc to_utf8_title
1921
1922 Convert the UTF-8 encoded character at p to its titlecase version and
1923 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1924 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1925 titlecase version may be longer than the original character.
1926
1927 The first character of the titlecased version is returned
1928 (but note, as explained above, that there may be more.)
1929
1930 =cut */
1931
1932 UV
1933 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1934 {
1935     dVAR;
1936
1937     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1938
1939     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1940                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1941 }
1942
1943 /*
1944 =for apidoc to_utf8_lower
1945
1946 Convert the UTF-8 encoded character at p to its lowercase version and
1947 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1948 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1949 lowercase version may be longer than the original character.
1950
1951 The first character of the lowercased version is returned
1952 (but note, as explained above, that there may be more.)
1953
1954 =cut */
1955
1956 UV
1957 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1958 {
1959     dVAR;
1960
1961     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1962
1963     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1964                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1965 }
1966
1967 /*
1968 =for apidoc to_utf8_fold
1969
1970 Convert the UTF-8 encoded character at p to its foldcase version and
1971 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1972 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1973 foldcase version may be longer than the original character (up to
1974 three characters).
1975
1976 The first character of the foldcased version is returned
1977 (but note, as explained above, that there may be more.)
1978
1979 =cut */
1980
1981 UV
1982 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1983 {
1984     dVAR;
1985
1986     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1987
1988     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1989                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1990 }
1991
1992 /* Note:
1993  * A "swash" is a swatch hash.
1994  * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1995  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1996  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1997  */
1998 SV*
1999 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
2000 {
2001     dVAR;
2002     SV* retval;
2003     dSP;
2004     const size_t pkg_len = strlen(pkg);
2005     const size_t name_len = strlen(name);
2006     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
2007     SV* errsv_save;
2008     GV *method;
2009
2010     PERL_ARGS_ASSERT_SWASH_INIT;
2011
2012     PUSHSTACKi(PERLSI_MAGIC);
2013     ENTER;
2014     SAVEHINTS();
2015     save_re_context();
2016     method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
2017     if (!method) {      /* demand load utf8 */
2018         ENTER;
2019         errsv_save = newSVsv(ERRSV);
2020         /* It is assumed that callers of this routine are not passing in any
2021            user derived data.  */
2022         /* Need to do this after save_re_context() as it will set PL_tainted to
2023            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
2024            Even line to create errsv_save can turn on PL_tainted.  */
2025         SAVEBOOL(PL_tainted);
2026         PL_tainted = 0;
2027         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
2028                          NULL);
2029         if (!SvTRUE(ERRSV))
2030             sv_setsv(ERRSV, errsv_save);
2031         SvREFCNT_dec(errsv_save);
2032         LEAVE;
2033     }
2034     SPAGAIN;
2035     PUSHMARK(SP);
2036     EXTEND(SP,5);
2037     mPUSHp(pkg, pkg_len);
2038     mPUSHp(name, name_len);
2039     PUSHs(listsv);
2040     mPUSHi(minbits);
2041     mPUSHi(none);
2042     PUTBACK;
2043     errsv_save = newSVsv(ERRSV);
2044     /* If we already have a pointer to the method, no need to use call_method()
2045        to repeat the lookup.  */
2046     if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
2047         : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
2048         retval = newSVsv(*PL_stack_sp--);
2049     else
2050         retval = &PL_sv_undef;
2051     if (!SvTRUE(ERRSV))
2052         sv_setsv(ERRSV, errsv_save);
2053     SvREFCNT_dec(errsv_save);
2054     LEAVE;
2055     POPSTACK;
2056     if (IN_PERL_COMPILETIME) {
2057         CopHINTS_set(PL_curcop, PL_hints);
2058     }
2059     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
2060         if (SvPOK(retval))
2061             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
2062                        SVfARG(retval));
2063         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
2064     }
2065     return retval;
2066 }
2067
2068
2069 /* This API is wrong for special case conversions since we may need to
2070  * return several Unicode characters for a single Unicode character
2071  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
2072  * the lower-level routine, and it is similarly broken for returning
2073  * multiple values.  --jhi
2074  * For those, you should use to_utf8_case() instead */
2075 /* Now SWASHGET is recasted into S_swash_get in this file. */
2076
2077 /* Note:
2078  * Returns the value of property/mapping C<swash> for the first character
2079  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
2080  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
2081  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
2082  */
2083 UV
2084 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
2085 {
2086     dVAR;
2087     HV *const hv = MUTABLE_HV(SvRV(swash));
2088     U32 klen;
2089     U32 off;
2090     STRLEN slen;
2091     STRLEN needents;
2092     const U8 *tmps = NULL;
2093     U32 bit;
2094     SV *swatch;
2095     U8 tmputf8[2];
2096     const UV c = NATIVE_TO_ASCII(*ptr);
2097
2098     PERL_ARGS_ASSERT_SWASH_FETCH;
2099
2100     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
2101         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
2102         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
2103         ptr = tmputf8;
2104     }
2105     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
2106      * then the "swatch" is a vec() for all the chars which start
2107      * with 0xAA..0xYY
2108      * So the key in the hash (klen) is length of encoded char -1
2109      */
2110     klen = UTF8SKIP(ptr) - 1;
2111     off  = ptr[klen];
2112
2113     if (klen == 0) {
2114       /* If char is invariant then swatch is for all the invariant chars
2115        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
2116        */
2117         needents = UTF_CONTINUATION_MARK;
2118         off      = NATIVE_TO_UTF(ptr[klen]);
2119     }
2120     else {
2121       /* If char is encoded then swatch is for the prefix */
2122         needents = (1 << UTF_ACCUMULATION_SHIFT);
2123         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
2124     }
2125
2126     /*
2127      * This single-entry cache saves about 1/3 of the utf8 overhead in test
2128      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
2129      * it's nothing to sniff at.)  Pity we usually come through at least
2130      * two function calls to get here...
2131      *
2132      * NB: this code assumes that swatches are never modified, once generated!
2133      */
2134
2135     if (hv   == PL_last_swash_hv &&
2136         klen == PL_last_swash_klen &&
2137         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
2138     {
2139         tmps = PL_last_swash_tmps;
2140         slen = PL_last_swash_slen;
2141     }
2142     else {
2143         /* Try our second-level swatch cache, kept in a hash. */
2144         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
2145
2146         /* If not cached, generate it via swash_get */
2147         if (!svp || !SvPOK(*svp)
2148                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2149             /* We use utf8n_to_uvuni() as we want an index into
2150                Unicode tables, not a native character number.
2151              */
2152             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
2153                                            ckWARN(WARN_UTF8) ?
2154                                            0 : UTF8_ALLOW_ANY);
2155             swatch = swash_get(swash,
2156                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
2157                                 (klen) ? (code_point & ~(needents - 1)) : 0,
2158                                 needents);
2159
2160             if (IN_PERL_COMPILETIME)
2161                 CopHINTS_set(PL_curcop, PL_hints);
2162
2163             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
2164
2165             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2166                      || (slen << 3) < needents)
2167                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
2168         }
2169
2170         PL_last_swash_hv = hv;
2171         assert(klen <= sizeof(PL_last_swash_key));
2172         PL_last_swash_klen = (U8)klen;
2173         /* FIXME change interpvar.h?  */
2174         PL_last_swash_tmps = (U8 *) tmps;
2175         PL_last_swash_slen = slen;
2176         if (klen)
2177             Copy(ptr, PL_last_swash_key, klen, U8);
2178     }
2179
2180     switch ((int)((slen << 3) / needents)) {
2181     case 1:
2182         bit = 1 << (off & 7);
2183         off >>= 3;
2184         return (tmps[off] & bit) != 0;
2185     case 8:
2186         return tmps[off];
2187     case 16:
2188         off <<= 1;
2189         return (tmps[off] << 8) + tmps[off + 1] ;
2190     case 32:
2191         off <<= 2;
2192         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
2193     }
2194     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
2195     NORETURN_FUNCTION_END;
2196 }
2197
2198 /* Read a single line of the main body of the swash input text.  These are of
2199  * the form:
2200  * 0053 0056    0073
2201  * where each number is hex.  The first two numbers form the minimum and
2202  * maximum of a range, and the third is the value associated with the range.
2203  * Not all swashes should have a third number
2204  *
2205  * On input: l    points to the beginning of the line to be examined; it points
2206  *                to somewhere in the string of the whole input text, and is
2207  *                terminated by a \n or the null string terminator.
2208  *           lend   points to the null terminator of that string
2209  *           wants_value    is non-zero if the swash expects a third number
2210  *           typestr is the name of the swash's mapping, like 'ToLower'
2211  * On output: *min, *max, and *val are set to the values read from the line.
2212  *            returns a pointer just beyond the line examined.  If there was no
2213  *            valid min number on the line, returns lend+1
2214  */
2215
2216 STATIC U8*
2217 S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2218                              const bool wants_value, const U8* const typestr)
2219 {
2220     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
2221     STRLEN numlen;          /* Length of the number */
2222     I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2223
2224     /* nl points to the next \n in the scan */
2225     U8* const nl = (U8*)memchr(l, '\n', lend - l);
2226
2227     /* Get the first number on the line: the range minimum */
2228     numlen = lend - l;
2229     *min = grok_hex((char *)l, &numlen, &flags, NULL);
2230     if (numlen)     /* If found a hex number, position past it */
2231         l += numlen;
2232     else if (nl) {          /* Else, go handle next line, if any */
2233         return nl + 1;  /* 1 is length of "\n" */
2234     }
2235     else {              /* Else, no next line */
2236         return lend + 1;        /* to LIST's end at which \n is not found */
2237     }
2238
2239     /* The max range value follows, separated by a BLANK */
2240     if (isBLANK(*l)) {
2241         ++l;
2242         flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2243         numlen = lend - l;
2244         *max = grok_hex((char *)l, &numlen, &flags, NULL);
2245         if (numlen)
2246             l += numlen;
2247         else    /* If no value here, it is a single element range */
2248             *max = *min;
2249
2250         /* Non-binary tables have a third entry: what the first element of the
2251          * range maps to */
2252         if (wants_value) {
2253             if (isBLANK(*l)) {
2254                 ++l;
2255                 flags = PERL_SCAN_SILENT_ILLDIGIT |
2256                         PERL_SCAN_DISALLOW_PREFIX;
2257                 numlen = lend - l;
2258                 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2259                 if (numlen)
2260                     l += numlen;
2261                 else
2262                     *val = 0;
2263             }
2264             else {
2265                 *val = 0;
2266                 if (typeto) {
2267                     Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2268                                      typestr, l);
2269                 }
2270             }
2271         }
2272         else
2273             *val = 0; /* bits == 1, then any val should be ignored */
2274     }
2275     else { /* Nothing following range min, should be single element with no
2276               mapping expected */
2277         *max = *min;
2278         if (wants_value) {
2279             *val = 0;
2280             if (typeto) {
2281                 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2282             }
2283         }
2284         else
2285             *val = 0; /* bits == 1, then val should be ignored */
2286     }
2287
2288     /* Position to next line if any, or EOF */
2289     if (nl)
2290         l = nl + 1;
2291     else
2292         l = lend;
2293
2294     return l;
2295 }
2296
2297 /* Note:
2298  * Returns a swatch (a bit vector string) for a code point sequence
2299  * that starts from the value C<start> and comprises the number C<span>.
2300  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2301  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2302  */
2303 STATIC SV*
2304 S_swash_get(pTHX_ SV* swash, UV start, UV span)
2305 {
2306     SV *swatch;
2307     U8 *l, *lend, *x, *xend, *s;
2308     STRLEN lcur, xcur, scur;
2309     HV *const hv = MUTABLE_HV(SvRV(swash));
2310
2311     /* The string containing the main body of the table */
2312     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2313
2314     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2315     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2316     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2317     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2318     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2319     const STRLEN bits  = SvUV(*bitssvp);
2320     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2321     const UV     none  = SvUV(*nonesvp);
2322     const UV     end   = start + span;
2323
2324     PERL_ARGS_ASSERT_SWASH_GET;
2325
2326     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
2327         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
2328                                                  (UV)bits);
2329     }
2330
2331     /* create and initialize $swatch */
2332     scur   = octets ? (span * octets) : (span + 7) / 8;
2333     swatch = newSV(scur);
2334     SvPOK_on(swatch);
2335     s = (U8*)SvPVX(swatch);
2336     if (octets && none) {
2337         const U8* const e = s + scur;
2338         while (s < e) {
2339             if (bits == 8)
2340                 *s++ = (U8)(none & 0xff);
2341             else if (bits == 16) {
2342                 *s++ = (U8)((none >>  8) & 0xff);
2343                 *s++ = (U8)( none        & 0xff);
2344             }
2345             else if (bits == 32) {
2346                 *s++ = (U8)((none >> 24) & 0xff);
2347                 *s++ = (U8)((none >> 16) & 0xff);
2348                 *s++ = (U8)((none >>  8) & 0xff);
2349                 *s++ = (U8)( none        & 0xff);
2350             }
2351         }
2352         *s = '\0';
2353     }
2354     else {
2355         (void)memzero((U8*)s, scur + 1);
2356     }
2357     SvCUR_set(swatch, scur);
2358     s = (U8*)SvPVX(swatch);
2359
2360     /* read $swash->{LIST} */
2361     l = (U8*)SvPV(*listsvp, lcur);
2362     lend = l + lcur;
2363     while (l < lend) {
2364         UV min, max, val;
2365         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2366                                          cBOOL(octets), typestr);
2367         if (l > lend) {
2368             break;
2369         }
2370
2371         /* If looking for something beyond this range, go try the next one */
2372         if (max < start)
2373             continue;
2374
2375         if (octets) {
2376             UV key;
2377             if (min < start) {
2378                 if (!none || val < none) {
2379                     val += start - min;
2380                 }
2381                 min = start;
2382             }
2383             for (key = min; key <= max; key++) {
2384                 STRLEN offset;
2385                 if (key >= end)
2386                     goto go_out_list;
2387                 /* offset must be non-negative (start <= min <= key < end) */
2388                 offset = octets * (key - start);
2389                 if (bits == 8)
2390                     s[offset] = (U8)(val & 0xff);
2391                 else if (bits == 16) {
2392                     s[offset    ] = (U8)((val >>  8) & 0xff);
2393                     s[offset + 1] = (U8)( val        & 0xff);
2394                 }
2395                 else if (bits == 32) {
2396                     s[offset    ] = (U8)((val >> 24) & 0xff);
2397                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2398                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2399                     s[offset + 3] = (U8)( val        & 0xff);
2400                 }
2401
2402                 if (!none || val < none)
2403                     ++val;
2404             }
2405         }
2406         else { /* bits == 1, then val should be ignored */
2407             UV key;
2408             if (min < start)
2409                 min = start;
2410             for (key = min; key <= max; key++) {
2411                 const STRLEN offset = (STRLEN)(key - start);
2412                 if (key >= end)
2413                     goto go_out_list;
2414                 s[offset >> 3] |= 1 << (offset & 7);
2415             }
2416         }
2417     } /* while */
2418   go_out_list:
2419
2420     /* read $swash->{EXTRAS} */
2421     x = (U8*)SvPV(*extssvp, xcur);
2422     xend = x + xcur;
2423     while (x < xend) {
2424         STRLEN namelen;
2425         U8 *namestr;
2426         SV** othersvp;
2427         HV* otherhv;
2428         STRLEN otherbits;
2429         SV **otherbitssvp, *other;
2430         U8 *s, *o, *nl;
2431         STRLEN slen, olen;
2432
2433         const U8 opc = *x++;
2434         if (opc == '\n')
2435             continue;
2436
2437         nl = (U8*)memchr(x, '\n', xend - x);
2438
2439         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2440             if (nl) {
2441                 x = nl + 1; /* 1 is length of "\n" */
2442                 continue;
2443             }
2444             else {
2445                 x = xend; /* to EXTRAS' end at which \n is not found */
2446                 break;
2447             }
2448         }
2449
2450         namestr = x;
2451         if (nl) {
2452             namelen = nl - namestr;
2453             x = nl + 1;
2454         }
2455         else {
2456             namelen = xend - namestr;
2457             x = xend;
2458         }
2459
2460         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2461         otherhv = MUTABLE_HV(SvRV(*othersvp));
2462         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2463         otherbits = (STRLEN)SvUV(*otherbitssvp);
2464         if (bits < otherbits)
2465             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2466
2467         /* The "other" swatch must be destroyed after. */
2468         other = swash_get(*othersvp, start, span);
2469         o = (U8*)SvPV(other, olen);
2470
2471         if (!olen)
2472             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2473
2474         s = (U8*)SvPV(swatch, slen);
2475         if (bits == 1 && otherbits == 1) {
2476             if (slen != olen)
2477                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2478
2479             switch (opc) {
2480             case '+':
2481                 while (slen--)
2482                     *s++ |= *o++;
2483                 break;
2484             case '!':
2485                 while (slen--)
2486                     *s++ |= ~*o++;
2487                 break;
2488             case '-':
2489                 while (slen--)
2490                     *s++ &= ~*o++;
2491                 break;
2492             case '&':
2493                 while (slen--)
2494                     *s++ &= *o++;
2495                 break;
2496             default:
2497                 break;
2498             }
2499         }
2500         else {
2501             STRLEN otheroctets = otherbits >> 3;
2502             STRLEN offset = 0;
2503             U8* const send = s + slen;
2504
2505             while (s < send) {
2506                 UV otherval = 0;
2507
2508                 if (otherbits == 1) {
2509                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2510                     ++offset;
2511                 }
2512                 else {
2513                     STRLEN vlen = otheroctets;
2514                     otherval = *o++;
2515                     while (--vlen) {
2516                         otherval <<= 8;
2517                         otherval |= *o++;
2518                     }
2519                 }
2520
2521                 if (opc == '+' && otherval)
2522                     NOOP;   /* replace with otherval */
2523                 else if (opc == '!' && !otherval)
2524                     otherval = 1;
2525                 else if (opc == '-' && otherval)
2526                     otherval = 0;
2527                 else if (opc == '&' && !otherval)
2528                     otherval = 0;
2529                 else {
2530                     s += octets; /* no replacement */
2531                     continue;
2532                 }
2533
2534                 if (bits == 8)
2535                     *s++ = (U8)( otherval & 0xff);
2536                 else if (bits == 16) {
2537                     *s++ = (U8)((otherval >>  8) & 0xff);
2538                     *s++ = (U8)( otherval        & 0xff);
2539                 }
2540                 else if (bits == 32) {
2541                     *s++ = (U8)((otherval >> 24) & 0xff);
2542                     *s++ = (U8)((otherval >> 16) & 0xff);
2543                     *s++ = (U8)((otherval >>  8) & 0xff);
2544                     *s++ = (U8)( otherval        & 0xff);
2545                 }
2546             }
2547         }
2548         sv_free(other); /* through with it! */
2549     } /* while */
2550     return swatch;
2551 }
2552
2553 HV*
2554 Perl__swash_inversion_hash(pTHX_ SV* swash)
2555 {
2556
2557    /* Subject to change or removal.  For use only in one place in regexec.c
2558     *
2559     * Returns a hash which is the inversion and closure of a swash mapping.
2560     * For example, consider the input lines:
2561     * 004B              006B
2562     * 004C              006C
2563     * 212A              006B
2564     *
2565     * The returned hash would have two keys, the utf8 for 006B and the utf8 for
2566     * 006C.  The value for each key is an array.  For 006C, the array would
2567     * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
2568     * would be three elements in its array, the utf8 for 006B, 004B and 212A.
2569     *
2570     * Essentially, for any code point, it gives all the code points that map to
2571     * it, or the list of 'froms' for that point.
2572     *
2573     * Currently it only looks at the main body of the swash, and ignores any
2574     * additions or deletions from other swashes */
2575
2576     U8 *l, *lend;
2577     STRLEN lcur;
2578     HV *const hv = MUTABLE_HV(SvRV(swash));
2579
2580     /* The string containing the main body of the table */
2581     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2582
2583     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2584     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2585     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2586     /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
2587     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2588     const STRLEN bits  = SvUV(*bitssvp);
2589     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2590     const UV     none  = SvUV(*nonesvp);
2591
2592     HV* ret = newHV();
2593
2594     PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
2595
2596     /* Must have at least 8 bits to get the mappings */
2597     if (bits != 8 && bits != 16 && bits != 32) {
2598         Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
2599                                                  (UV)bits);
2600     }
2601
2602     /* read $swash->{LIST} */
2603     l = (U8*)SvPV(*listsvp, lcur);
2604     lend = l + lcur;
2605
2606     /* Go through each input line */
2607     while (l < lend) {
2608         UV min, max, val;
2609         UV inverse;
2610         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2611                                          cBOOL(octets), typestr);
2612         if (l > lend) {
2613             break;
2614         }
2615
2616         /* Each element in the range is to be inverted */
2617         for (inverse = min; inverse <= max; inverse++) {
2618             AV* list;
2619             SV* element;
2620             SV** listp;
2621             IV i;
2622             bool found_key = FALSE;
2623
2624             /* The key is the inverse mapping */
2625             char key[UTF8_MAXBYTES+1];
2626             char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
2627             STRLEN key_len = key_end - key;
2628
2629             /* And the value is what the forward mapping is from. */
2630             char utf8_inverse[UTF8_MAXBYTES+1];
2631             char *utf8_inverse_end = (char *) uvuni_to_utf8((U8*) utf8_inverse, inverse);
2632
2633             /* Get the list for the map */
2634             if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
2635                 list = (AV*) *listp;
2636             }
2637             else { /* No entry yet for it: create one */
2638                 list = newAV();
2639                 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
2640                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2641                 }
2642             }
2643
2644             for (i = 0; i < av_len(list); i++) {
2645                 SV** entryp = av_fetch(list, i, FALSE);
2646                 SV* entry;
2647                 if (entryp == NULL) {
2648                     Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
2649                 }
2650                 entry = *entryp;
2651                 if (SvCUR(entry) != key_len) {
2652                     continue;
2653                 }
2654                 if (memEQ(key, SvPVX(entry), key_len)) {
2655                     found_key = TRUE;
2656                     break;
2657                 }
2658             }
2659             if (! found_key) {
2660                 element = newSVpvn_flags(key, key_len, SVf_UTF8);
2661                 av_push(list, element);
2662             }
2663
2664
2665             /* Simply add the value to the list */
2666             element = newSVpvn_flags(utf8_inverse, utf8_inverse_end - utf8_inverse, SVf_UTF8);
2667             av_push(list, element);
2668
2669             /* swash_get() increments the value of val for each element in the
2670              * range.  That makes more compact tables possible.  You can
2671              * express the capitalization, for example, of all consecutive
2672              * letters with a single line: 0061\t007A\t0041 This maps 0061 to
2673              * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
2674              * and it's not documented, and perhaps not even currently used,
2675              * but I copied the semantics from swash_get(), just in case */
2676             if (!none || val < none) {
2677                 ++val;
2678             }
2679         }
2680     }
2681
2682     return ret;
2683 }
2684
2685 /*
2686 =for apidoc uvchr_to_utf8
2687
2688 Adds the UTF-8 representation of the Native code point C<uv> to the end
2689 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2690 bytes available. The return value is the pointer to the byte after the
2691 end of the new character. In other words,
2692
2693     d = uvchr_to_utf8(d, uv);
2694
2695 is the recommended wide native character-aware way of saying
2696
2697     *(d++) = uv;
2698
2699 =cut
2700 */
2701
2702 /* On ASCII machines this is normally a macro but we want a
2703    real function in case XS code wants it
2704 */
2705 U8 *
2706 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2707 {
2708     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2709
2710     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2711 }
2712
2713 U8 *
2714 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2715 {
2716     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2717
2718     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2719 }
2720
2721 /*
2722 =for apidoc utf8n_to_uvchr
2723
2724 Returns the native character value of the first character in the string
2725 C<s>
2726 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2727 length, in bytes, of that character.
2728
2729 length and flags are the same as utf8n_to_uvuni().
2730
2731 =cut
2732 */
2733 /* On ASCII machines this is normally a macro but we want
2734    a real function in case XS code wants it
2735 */
2736 UV
2737 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2738 U32 flags)
2739 {
2740     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2741
2742     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2743
2744     return UNI_TO_NATIVE(uv);
2745 }
2746
2747 bool
2748 Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
2749 {
2750     /* May change: warns if surrogates, non-character code points, or
2751      * non-Unicode code points are in s which has length len.  Returns TRUE if
2752      * none found; FALSE otherwise.  The only other validity check is to make
2753      * sure that this won't exceed the string's length */
2754
2755     const U8* const e = s + len;
2756     bool ok = TRUE;
2757
2758     PERL_ARGS_ASSERT_CHECK_UTF8_PRINT;
2759
2760     while (s < e) {
2761         if (UTF8SKIP(s) > len) {
2762             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2763                            "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
2764             return FALSE;
2765         }
2766         if (*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE) {
2767             STRLEN char_len;
2768             if (UTF8_IS_SUPER(s)) {
2769                 UV uv = utf8_to_uvchr(s, &char_len);
2770                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
2771                     "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
2772                 ok = FALSE;
2773             }
2774             else if (UTF8_IS_SURROGATE(s)) {
2775                 UV uv = utf8_to_uvchr(s, &char_len);
2776                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
2777                     "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
2778                 ok = FALSE;
2779             }
2780             else if
2781                 (UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
2782             {
2783                 UV uv = utf8_to_uvchr(s, &char_len);
2784                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
2785                     "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
2786                 ok = FALSE;
2787             }
2788         }
2789         s += UTF8SKIP(s);
2790     }
2791
2792     return ok;
2793 }
2794
2795 /*
2796 =for apidoc pv_uni_display
2797
2798 Build to the scalar dsv a displayable version of the string spv,
2799 length len, the displayable version being at most pvlim bytes long
2800 (if longer, the rest is truncated and "..." will be appended).
2801
2802 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2803 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2804 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2805 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2806 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2807 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2808
2809 The pointer to the PV of the dsv is returned.
2810
2811 =cut */
2812 char *
2813 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2814 {
2815     int truncated = 0;
2816     const char *s, *e;
2817
2818     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2819
2820     sv_setpvs(dsv, "");
2821     SvUTF8_off(dsv);
2822     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2823          UV u;
2824           /* This serves double duty as a flag and a character to print after
2825              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2826           */
2827          char ok = 0;
2828
2829          if (pvlim && SvCUR(dsv) >= pvlim) {
2830               truncated++;
2831               break;
2832          }
2833          u = utf8_to_uvchr((U8*)s, 0);
2834          if (u < 256) {
2835              const unsigned char c = (unsigned char)u & 0xFF;
2836              if (flags & UNI_DISPLAY_BACKSLASH) {
2837                  switch (c) {
2838                  case '\n':
2839                      ok = 'n'; break;
2840                  case '\r':
2841                      ok = 'r'; break;
2842                  case '\t':
2843                      ok = 't'; break;
2844                  case '\f':
2845                      ok = 'f'; break;
2846                  case '\a':
2847                      ok = 'a'; break;
2848                  case '\\':
2849                      ok = '\\'; break;
2850                  default: break;
2851                  }
2852                  if (ok) {
2853                      const char string = ok;
2854                      sv_catpvs(dsv, "\\");
2855                      sv_catpvn(dsv, &string, 1);
2856                  }
2857              }
2858              /* isPRINT() is the locale-blind version. */
2859              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2860                  const char string = c;
2861                  sv_catpvn(dsv, &string, 1);
2862                  ok = 1;
2863              }
2864          }
2865          if (!ok)
2866              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2867     }
2868     if (truncated)
2869          sv_catpvs(dsv, "...");
2870
2871     return SvPVX(dsv);
2872 }
2873
2874 /*
2875 =for apidoc sv_uni_display
2876
2877 Build to the scalar dsv a displayable version of the scalar sv,
2878 the displayable version being at most pvlim bytes long
2879 (if longer, the rest is truncated and "..." will be appended).
2880
2881 The flags argument is as in pv_uni_display().
2882
2883 The pointer to the PV of the dsv is returned.
2884
2885 =cut
2886 */
2887 char *
2888 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2889 {
2890     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2891
2892      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2893                                 SvCUR(ssv), pvlim, flags);
2894 }
2895
2896 /*
2897 =for apidoc foldEQ_utf8
2898
2899 Returns true if the leading portions of the strings s1 and s2 (either or both
2900 of which may be in UTF-8) are the same case-insensitively; false otherwise.
2901 How far into the strings to compare is determined by other input parameters.
2902
2903 If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
2904 otherwise it is assumed to be in native 8-bit encoding.  Correspondingly for u2
2905 with respect to s2.
2906
2907 If the byte length l1 is non-zero, it says how far into s1 to check for fold
2908 equality.  In other words, s1+l1 will be used as a goal to reach.  The
2909 scan will not be considered to be a match unless the goal is reached, and
2910 scanning won't continue past that goal.  Correspondingly for l2 with respect to
2911 s2.
2912
2913 If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
2914 considered an end pointer beyond which scanning of s1 will not continue under
2915 any circumstances.  This means that if both l1 and pe1 are specified, and pe1
2916 is less than s1+l1, the match will never be successful because it can never
2917 get as far as its goal (and in fact is asserted against).  Correspondingly for
2918 pe2 with respect to s2.
2919
2920 At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
2921 non-zero), and if both do, both have to be
2922 reached for a successful match.   Also, if the fold of a character is multiple
2923 characters, all of them must be matched (see tr21 reference below for
2924 'folding').
2925
2926 Upon a successful match, if pe1 is non-NULL,
2927 it will be set to point to the beginning of the I<next> character of s1 beyond
2928 what was matched.  Correspondingly for pe2 and s2.
2929
2930 For case-insensitiveness, the "casefolding" of Unicode is used
2931 instead of upper/lowercasing both the characters, see
2932 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2933
2934 =cut */
2935 I32
2936 Perl_foldEQ_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2937 {
2938     dVAR;
2939     register const U8 *p1  = (const U8*)s1; /* Point to current char */
2940     register const U8 *p2  = (const U8*)s2;
2941     register const U8 *g1 = NULL;       /* goal for s1 */
2942     register const U8 *g2 = NULL;
2943     register const U8 *e1 = NULL;       /* Don't scan s1 past this */
2944     register U8 *f1 = NULL;             /* Point to current folded */
2945     register const U8 *e2 = NULL;
2946     register U8 *f2 = NULL;
2947     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
2948     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2949     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2950     U8 natbuf[2];               /* Holds native 8-bit char converted to utf8;
2951                                    these always fit in 2 bytes */
2952
2953     PERL_ARGS_ASSERT_FOLDEQ_UTF8;
2954
2955     if (pe1) {
2956         e1 = *(U8**)pe1;
2957     }
2958
2959     if (l1) {
2960         g1 = (const U8*)s1 + l1;
2961     }
2962
2963     if (pe2) {
2964         e2 = *(U8**)pe2;
2965     }
2966
2967     if (l2) {
2968         g2 = (const U8*)s2 + l2;
2969     }
2970
2971     /* Must have at least one goal */
2972     assert(g1 || g2);
2973
2974     if (g1) {
2975
2976         /* Will never match if goal is out-of-bounds */
2977         assert(! e1  || e1 >= g1);
2978
2979         /* Here, there isn't an end pointer, or it is beyond the goal.  We
2980         * only go as far as the goal */
2981         e1 = g1;
2982     }
2983     else {
2984         assert(e1);    /* Must have an end for looking at s1 */
2985     }
2986
2987     /* Same for goal for s2 */
2988     if (g2) {
2989         assert(! e2  || e2 >= g2);
2990         e2 = g2;
2991     }
2992     else {
2993         assert(e2);
2994     }
2995
2996     /* Look through both strings, a character at a time */
2997     while (p1 < e1 && p2 < e2) {
2998
2999         /* If at the beginning of a new character in s1, get its fold to use
3000          * and the length of the fold */
3001         if (n1 == 0) {
3002             if (u1) {
3003                 to_utf8_fold(p1, foldbuf1, &n1);
3004             }
3005             else {  /* Not utf8, convert to it first and then get fold */
3006                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
3007                 to_utf8_fold(natbuf, foldbuf1, &n1);
3008             }
3009             f1 = foldbuf1;
3010         }
3011
3012         if (n2 == 0) {    /* Same for s2 */
3013             if (u2) {
3014                 to_utf8_fold(p2, foldbuf2, &n2);
3015             }
3016             else {
3017                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
3018                 to_utf8_fold(natbuf, foldbuf2, &n2);
3019             }
3020             f2 = foldbuf2;
3021         }
3022
3023         /* While there is more to look for in both folds, see if they
3024         * continue to match */
3025         while (n1 && n2) {
3026             U8 fold_length = UTF8SKIP(f1);
3027             if (fold_length != UTF8SKIP(f2)
3028                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
3029                                                        function call for single
3030                                                        character */
3031                 || memNE((char*)f1, (char*)f2, fold_length))
3032             {
3033                 return 0; /* mismatch */
3034             }
3035
3036             /* Here, they matched, advance past them */
3037             n1 -= fold_length;
3038             f1 += fold_length;
3039             n2 -= fold_length;
3040             f2 += fold_length;
3041         }
3042
3043         /* When reach the end of any fold, advance the input past it */
3044         if (n1 == 0) {
3045             p1 += u1 ? UTF8SKIP(p1) : 1;
3046         }
3047         if (n2 == 0) {
3048             p2 += u2 ? UTF8SKIP(p2) : 1;
3049         }
3050     } /* End of loop through both strings */
3051
3052     /* A match is defined by each scan that specified an explicit length
3053     * reaching its final goal, and the other not having matched a partial
3054     * character (which can happen when the fold of a character is more than one
3055     * character). */
3056     if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
3057         return 0;
3058     }
3059
3060     /* Successful match.  Set output pointers */
3061     if (pe1) {
3062         *pe1 = (char*)p1;
3063     }
3064     if (pe2) {
3065         *pe2 = (char*)p2;
3066     }
3067     return 1;
3068 }
3069
3070 /*
3071  * Local variables:
3072  * c-indentation-style: bsd
3073  * c-basic-offset: 4
3074  * indent-tabs-mode: t
3075  * End:
3076  *
3077  * ex: set ts=8 sts=4 sw=4 noet:
3078  */