This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8258ef5330a2829454f8fa166a5d9a5e2952b67b
[perl5.git] / utf8.c
1 /*    utf8.c
2  *
3  *    Copyright (c) 1998-2001, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
12  * heard of that we don't want to see any closer; and that's the one place
13  * we're trying to get to!  And that's just where we can't get, nohow.'
14  *
15  * 'Well do I understand your speech,' he answered in the same language;
16  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
17  * as is the custom in the West, if you wish to be answered?'
18  *
19  * ...the travellers perceived that the floor was paved with stones of many
20  * hues; branching runes and strange devices intertwined beneath their feet.
21  */
22
23 #include "EXTERN.h"
24 #define PERL_IN_UTF8_C
25 #include "perl.h"
26
27 /* 
28 =head1 Unicode Support
29
30 =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
31
32 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
33 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
34 bytes available. The return value is the pointer to the byte after the
35 end of the new character. In other words,
36
37     d = uvuni_to_utf8_flags(d, uv, flags);
38
39 or, in most cases,
40
41     d = uvuni_to_utf8(d, uv);
42
43 (which is equivalent to)
44
45     d = uvuni_to_utf8_flags(d, uv, 0);
46
47 is the recommended Unicode-aware way of saying
48
49     *(d++) = uv;
50
51 =cut
52 */
53
54 U8 *
55 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
56 {
57     if (ckWARN_d(WARN_UTF8)) {
58          if (UNICODE_IS_SURROGATE(uv) &&
59              !(flags & UNICODE_ALLOW_SURROGATE))
60               Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv);
61          else if (
62                   ((uv >= 0xFDD0 && uv <= 0xFDEF &&
63                     !(flags & UNICODE_ALLOW_FDD0))
64                    ||
65                    ((uv & 0xFFFF) == 0xFFFE &&
66                     !(flags & UNICODE_ALLOW_FFFE))
67                    ||
68                    ((uv & 0xFFFF) == 0xFFFF &&
69                     !(flags & UNICODE_ALLOW_FFFF))) &&
70                   /* UNICODE_ALLOW_SUPER includes
71                    * FFFEs and FFFFs beyond 0x10FFFF. */
72                   ((uv <= PERL_UNICODE_MAX) ||
73                    !(flags & UNICODE_ALLOW_SUPER))
74                   )
75               Perl_warner(aTHX_ WARN_UTF8,
76                          "Unicode character 0x%04"UVxf" is illegal", uv);
77     }
78     if (UNI_IS_INVARIANT(uv)) {
79         *d++ = UTF_TO_NATIVE(uv);
80         return d;
81     }
82 #if defined(EBCDIC)
83     else {
84         STRLEN len  = UNISKIP(uv);
85         U8 *p = d+len-1;
86         while (p > d) {
87             *p-- = UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
88             uv >>= UTF_ACCUMULATION_SHIFT;
89         }
90         *p = UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
91         return d+len;
92     }
93 #else /* Non loop style */
94     if (uv < 0x800) {
95         *d++ = (( uv >>  6)         | 0xc0);
96         *d++ = (( uv        & 0x3f) | 0x80);
97         return d;
98     }
99     if (uv < 0x10000) {
100         *d++ = (( uv >> 12)         | 0xe0);
101         *d++ = (((uv >>  6) & 0x3f) | 0x80);
102         *d++ = (( uv        & 0x3f) | 0x80);
103         return d;
104     }
105     if (uv < 0x200000) {
106         *d++ = (( uv >> 18)         | 0xf0);
107         *d++ = (((uv >> 12) & 0x3f) | 0x80);
108         *d++ = (((uv >>  6) & 0x3f) | 0x80);
109         *d++ = (( uv        & 0x3f) | 0x80);
110         return d;
111     }
112     if (uv < 0x4000000) {
113         *d++ = (( uv >> 24)         | 0xf8);
114         *d++ = (((uv >> 18) & 0x3f) | 0x80);
115         *d++ = (((uv >> 12) & 0x3f) | 0x80);
116         *d++ = (((uv >>  6) & 0x3f) | 0x80);
117         *d++ = (( uv        & 0x3f) | 0x80);
118         return d;
119     }
120     if (uv < 0x80000000) {
121         *d++ = (( uv >> 30)         | 0xfc);
122         *d++ = (((uv >> 24) & 0x3f) | 0x80);
123         *d++ = (((uv >> 18) & 0x3f) | 0x80);
124         *d++ = (((uv >> 12) & 0x3f) | 0x80);
125         *d++ = (((uv >>  6) & 0x3f) | 0x80);
126         *d++ = (( uv        & 0x3f) | 0x80);
127         return d;
128     }
129 #ifdef HAS_QUAD
130     if (uv < UTF8_QUAD_MAX)
131 #endif
132     {
133         *d++ =                        0xfe;     /* Can't match U+FEFF! */
134         *d++ = (((uv >> 30) & 0x3f) | 0x80);
135         *d++ = (((uv >> 24) & 0x3f) | 0x80);
136         *d++ = (((uv >> 18) & 0x3f) | 0x80);
137         *d++ = (((uv >> 12) & 0x3f) | 0x80);
138         *d++ = (((uv >>  6) & 0x3f) | 0x80);
139         *d++ = (( uv        & 0x3f) | 0x80);
140         return d;
141     }
142 #ifdef HAS_QUAD
143     {
144         *d++ =                        0xff;     /* Can't match U+FFFE! */
145         *d++ =                        0x80;     /* 6 Reserved bits */
146         *d++ = (((uv >> 60) & 0x0f) | 0x80);    /* 2 Reserved bits */
147         *d++ = (((uv >> 54) & 0x3f) | 0x80);
148         *d++ = (((uv >> 48) & 0x3f) | 0x80);
149         *d++ = (((uv >> 42) & 0x3f) | 0x80);
150         *d++ = (((uv >> 36) & 0x3f) | 0x80);
151         *d++ = (((uv >> 30) & 0x3f) | 0x80);
152         *d++ = (((uv >> 24) & 0x3f) | 0x80);
153         *d++ = (((uv >> 18) & 0x3f) | 0x80);
154         *d++ = (((uv >> 12) & 0x3f) | 0x80);
155         *d++ = (((uv >>  6) & 0x3f) | 0x80);
156         *d++ = (( uv        & 0x3f) | 0x80);
157         return d;
158     }
159 #endif
160 #endif /* Loop style */
161 }
162  
163 U8 *
164 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
165 {
166     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
167 }
168
169
170 /*
171 =for apidoc A|STRLEN|is_utf8_char|U8 *s
172
173 Tests if some arbitrary number of bytes begins in a valid UTF-8
174 character.  Note that an INVARIANT (i.e. ASCII) character is a valid UTF-8 character.
175 The actual number of bytes in the UTF-8 character will be returned if
176 it is valid, otherwise 0.
177
178 =cut
179 */
180 STRLEN
181 Perl_is_utf8_char(pTHX_ U8 *s)
182 {
183     U8 u = *s;
184     STRLEN slen, len;
185     UV uv, ouv;
186
187     if (UTF8_IS_INVARIANT(u))
188         return 1;
189
190     if (!UTF8_IS_START(u))
191         return 0;
192
193     len = UTF8SKIP(s);
194
195     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
196         return 0;
197
198     slen = len - 1;
199     s++;
200     u &= UTF_START_MASK(len);
201     uv  = u;
202     ouv = uv;
203     while (slen--) {
204         if (!UTF8_IS_CONTINUATION(*s))
205             return 0;
206         uv = UTF8_ACCUMULATE(uv, *s);
207         if (uv < ouv) 
208             return 0;
209         ouv = uv;
210         s++;
211     }
212
213     if (UNISKIP(uv) < len)
214         return 0;
215
216     return len;
217 }
218
219 /*
220 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
221
222 Returns true if first C<len> bytes of the given string form a valid UTF8
223 string, false otherwise.  Note that 'a valid UTF8 string' does not mean
224 'a string that contains UTF8' because a valid ASCII string is a valid
225 UTF8 string.
226
227 =cut
228 */
229
230 bool
231 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
232 {
233     U8* x = s;
234     U8* send;
235     STRLEN c;
236
237     if (!len)
238         len = strlen((char *)s);
239     send = s + len;
240
241     while (x < send) {
242         c = is_utf8_char(x);
243         if (!c)
244             return FALSE;
245         x += c;
246     }
247     if (x != send)
248         return FALSE;
249
250     return TRUE;
251 }
252
253 /*
254 =for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
255
256 Bottom level UTF-8 decode routine.
257 Returns the unicode code point value of the first character in the string C<s>
258 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
259 C<retlen> will be set to the length, in bytes, of that character.
260
261 If C<s> does not point to a well-formed UTF8 character, the behaviour
262 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
263 it is assumed that the caller will raise a warning, and this function
264 will silently just set C<retlen> to C<-1> and return zero.  If the
265 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
266 malformations will be given, C<retlen> will be set to the expected
267 length of the UTF-8 character in bytes, and zero will be returned.
268
269 The C<flags> can also contain various flags to allow deviations from
270 the strict UTF-8 encoding (see F<utf8.h>).
271
272 Most code should use utf8_to_uvchr() rather than call this directly.
273
274 =cut
275 */
276
277 UV
278 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
279 {
280     U8 *s0 = s;
281     UV uv = *s, ouv = 0;
282     STRLEN len = 1;
283     bool dowarn = ckWARN_d(WARN_UTF8);
284     UV startbyte = *s;
285     STRLEN expectlen = 0;
286     U32 warning = 0;
287
288 /* This list is a superset of the UTF8_ALLOW_XXX. */
289
290 #define UTF8_WARN_EMPTY                          1
291 #define UTF8_WARN_CONTINUATION                   2
292 #define UTF8_WARN_NON_CONTINUATION               3
293 #define UTF8_WARN_FE_FF                          4
294 #define UTF8_WARN_SHORT                          5
295 #define UTF8_WARN_OVERFLOW                       6
296 #define UTF8_WARN_SURROGATE                      7
297 #define UTF8_WARN_BOM                            8
298 #define UTF8_WARN_LONG                           9
299 #define UTF8_WARN_FFFF                          10
300
301     if (curlen == 0 &&
302         !(flags & UTF8_ALLOW_EMPTY)) {
303         warning = UTF8_WARN_EMPTY;
304         goto malformed;
305     }
306
307     if (UTF8_IS_INVARIANT(uv)) {
308         if (retlen)
309             *retlen = 1;
310         return (UV) (NATIVE_TO_UTF(*s));
311     }
312
313     if (UTF8_IS_CONTINUATION(uv) &&
314         !(flags & UTF8_ALLOW_CONTINUATION)) {
315         warning = UTF8_WARN_CONTINUATION;
316         goto malformed;
317     }
318
319     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
320         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
321         warning = UTF8_WARN_NON_CONTINUATION;
322         goto malformed;
323     }
324
325 #ifdef EBCDIC
326     uv = NATIVE_TO_UTF(uv);
327 #else
328     if ((uv == 0xfe || uv == 0xff) &&
329         !(flags & UTF8_ALLOW_FE_FF)) {
330         warning = UTF8_WARN_FE_FF;
331         goto malformed;
332     }
333 #endif
334
335     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
336     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
337     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
338     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
339 #ifdef EBCDIC
340     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
341     else                        { len =  7; uv &= 0x01; }
342 #else
343     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
344     else if (!(uv & 0x01))      { len =  7; uv = 0; }
345     else                        { len = 13; uv = 0; } /* whoa! */
346 #endif
347
348     if (retlen)
349         *retlen = len;
350
351     expectlen = len;
352
353     if ((curlen < expectlen) &&
354         !(flags & UTF8_ALLOW_SHORT)) {
355         warning = UTF8_WARN_SHORT;
356         goto malformed;
357     }
358
359     len--;
360     s++;
361     ouv = uv;
362
363     while (len--) {
364         if (!UTF8_IS_CONTINUATION(*s) &&
365             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
366             s--;
367             warning = UTF8_WARN_NON_CONTINUATION;
368             goto malformed;
369         }
370         else
371             uv = UTF8_ACCUMULATE(uv, *s);
372         if (!(uv > ouv)) {
373             /* These cannot be allowed. */
374             if (uv == ouv) {
375                 if (!(flags & UTF8_ALLOW_LONG)) {
376                     warning = UTF8_WARN_LONG;
377                     goto malformed;
378                 }
379             }
380             else { /* uv < ouv */
381                 /* This cannot be allowed. */
382                 warning = UTF8_WARN_OVERFLOW;
383                 goto malformed;
384             }
385         }
386         s++;
387         ouv = uv;
388     }
389
390     if (UNICODE_IS_SURROGATE(uv) &&
391         !(flags & UTF8_ALLOW_SURROGATE)) {
392         warning = UTF8_WARN_SURROGATE;
393         goto malformed;
394     } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
395                !(flags & UTF8_ALLOW_BOM)) {
396         warning = UTF8_WARN_BOM;
397         goto malformed;
398     } else if ((expectlen > UNISKIP(uv)) &&
399                !(flags & UTF8_ALLOW_LONG)) {
400         warning = UTF8_WARN_LONG;
401         goto malformed;
402     } else if (UNICODE_IS_ILLEGAL(uv) &&
403                !(flags & UTF8_ALLOW_FFFF)) {
404         warning = UTF8_WARN_FFFF;
405         goto malformed;
406     }
407
408     return uv;
409
410 malformed:
411
412     if (flags & UTF8_CHECK_ONLY) {
413         if (retlen)
414             *retlen = -1;
415         return 0;
416     }
417
418     if (dowarn) {
419         SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
420
421         switch (warning) {
422         case 0: /* Intentionally empty. */ break;
423         case UTF8_WARN_EMPTY:
424             Perl_sv_catpvf(aTHX_ sv, "(empty string)");
425             break;
426         case UTF8_WARN_CONTINUATION:
427             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
428             break;
429         case UTF8_WARN_NON_CONTINUATION:
430             if (s == s0)
431                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
432                            (UV)s[1], startbyte);
433             else
434                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
435                            (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
436               
437             break;
438         case UTF8_WARN_FE_FF:
439             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
440             break;
441         case UTF8_WARN_SHORT:
442             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
443                            curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
444             expectlen = curlen;         /* distance for caller to skip */
445             break;
446         case UTF8_WARN_OVERFLOW:
447             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
448                            ouv, *s, startbyte);
449             break;
450         case UTF8_WARN_SURROGATE:
451             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
452             break;
453         case UTF8_WARN_BOM:
454             Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
455             break;
456         case UTF8_WARN_LONG:
457             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
458                            expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
459             break;
460         case UTF8_WARN_FFFF:
461             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
462             break;
463         default:
464             Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
465             break;
466         }
467         
468         if (warning) {
469             char *s = SvPVX(sv);
470
471             if (PL_op)
472                 Perl_warner(aTHX_ WARN_UTF8,
473                             "%s in %s", s,  OP_DESC(PL_op));
474             else
475                 Perl_warner(aTHX_ WARN_UTF8, "%s", s);
476         }
477     }
478
479     if (retlen)
480         *retlen = expectlen ? expectlen : len;
481
482     return 0;
483 }
484
485 /*
486 =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
487
488 Returns the native character value of the first character in the string C<s>
489 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
490 length, in bytes, of that character.
491
492 If C<s> does not point to a well-formed UTF8 character, zero is
493 returned and retlen is set, if possible, to -1.
494
495 =cut
496 */
497
498 UV
499 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
500 {
501     return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
502 }
503
504 /*
505 =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
506
507 Returns the Unicode code point of the first character in the string C<s>
508 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
509 length, in bytes, of that character.
510
511 This function should only be used when returned UV is considered
512 an index into the Unicode semantic tables (e.g. swashes).
513
514 If C<s> does not point to a well-formed UTF8 character, zero is
515 returned and retlen is set, if possible, to -1.
516
517 =cut
518 */
519
520 UV
521 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
522 {
523     /* Call the low level routine asking for checks */
524     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
525 }
526
527 /*
528 =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
529
530 Return the length of the UTF-8 char encoded string C<s> in characters.
531 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
532 up past C<e>, croaks.
533
534 =cut
535 */
536
537 STRLEN
538 Perl_utf8_length(pTHX_ U8 *s, U8 *e)
539 {
540     STRLEN len = 0;
541
542     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
543      * the bitops (especially ~) can create illegal UTF-8.
544      * In other words: in Perl UTF-8 is not just for Unicode. */
545
546     if (e < s)
547         Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
548     while (s < e) {
549         U8 t = UTF8SKIP(s);
550
551         if (e - s < t)
552             Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
553         s += t;
554         len++;
555     }
556
557     return len;
558 }
559
560 /*
561 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
562
563 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
564 and C<b>.
565
566 WARNING: use only if you *know* that the pointers point inside the
567 same UTF-8 buffer.
568
569 =cut
570 */
571
572 IV
573 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
574 {
575     IV off = 0;
576
577     /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
578      * the bitops (especially ~) can create illegal UTF-8.
579      * In other words: in Perl UTF-8 is not just for Unicode. */
580
581     if (a < b) {
582         while (a < b) {
583             U8 c = UTF8SKIP(a);
584
585             if (b - a < c)
586                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
587             a += c;
588             off--;
589         }
590     }
591     else {
592         while (b < a) {
593             U8 c = UTF8SKIP(b);
594
595             if (a - b < c)
596                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
597             b += c;
598             off++;
599         }
600     }
601
602     return off;
603 }
604
605 /*
606 =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
607
608 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
609 forward or backward.
610
611 WARNING: do not use the following unless you *know* C<off> is within
612 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
613 on the first byte of character or just after the last byte of a character.
614
615 =cut
616 */
617
618 U8 *
619 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
620 {
621     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
622      * the bitops (especially ~) can create illegal UTF-8.
623      * In other words: in Perl UTF-8 is not just for Unicode. */
624
625     if (off >= 0) {
626         while (off--)
627             s += UTF8SKIP(s);
628     }
629     else {
630         while (off++) {
631             s--;
632             while (UTF8_IS_CONTINUATION(*s))
633                 s--;
634         }
635     }
636     return s;
637 }
638
639 /*
640 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
641
642 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
643 Unlike C<bytes_to_utf8>, this over-writes the original string, and
644 updates len to contain the new length.
645 Returns zero on failure, setting C<len> to -1.
646
647 =cut
648 */
649
650 U8 *
651 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
652 {
653     U8 *send;
654     U8 *d;
655     U8 *save = s;
656
657     /* ensure valid UTF8 and chars < 256 before updating string */
658     for (send = s + *len; s < send; ) {
659         U8 c = *s++;
660
661         if (!UTF8_IS_INVARIANT(c) &&
662             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
663              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
664             *len = -1;
665             return 0;
666         }
667     }
668
669     d = s = save;
670     while (s < send) {
671         STRLEN ulen;
672         *d++ = (U8)utf8_to_uvchr(s, &ulen);
673         s += ulen;
674     }
675     *d = '\0';
676     *len = d - save;
677     return save;
678 }
679
680 /*
681 =for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
682
683 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
684 Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
685 the newly-created string, and updates C<len> to contain the new
686 length.  Returns the original string if no conversion occurs, C<len>
687 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
688 0 if C<s> is converted or contains all 7bit characters.
689
690 =cut
691 */
692
693 U8 *
694 Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
695 {
696     U8 *d;
697     U8 *start = s;
698     U8 *send;
699     I32 count = 0;
700
701     if (!*is_utf8)
702         return start;
703
704     /* ensure valid UTF8 and chars < 256 before converting string */
705     for (send = s + *len; s < send;) {
706         U8 c = *s++;
707         if (!UTF8_IS_INVARIANT(c)) {
708             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
709                 (c = *s++) && UTF8_IS_CONTINUATION(c))
710                 count++;
711             else
712                 return start;
713         }
714     }
715
716     *is_utf8 = 0;               
717
718     Newz(801, d, (*len) - count + 1, U8);
719     s = start; start = d;
720     while (s < send) {
721         U8 c = *s++;
722         if (!UTF8_IS_INVARIANT(c)) {
723             /* Then it is two-byte encoded */
724             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
725             c = ASCII_TO_NATIVE(c);
726         }
727         *d++ = c;
728     }
729     *d = '\0';
730     *len = d - start;
731     return start;
732 }
733
734 /*
735 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
736
737 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
738 Returns a pointer to the newly-created string, and sets C<len> to
739 reflect the new length.
740
741 =cut
742 */
743
744 U8*
745 Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
746 {
747     U8 *send;
748     U8 *d;
749     U8 *dst;
750     send = s + (*len);
751
752     Newz(801, d, (*len) * 2 + 1, U8);
753     dst = d;
754
755     while (s < send) {
756         UV uv = NATIVE_TO_ASCII(*s++);
757         if (UNI_IS_INVARIANT(uv))
758             *d++ = UTF_TO_NATIVE(uv);
759         else {
760             *d++ = UTF8_EIGHT_BIT_HI(uv);
761             *d++ = UTF8_EIGHT_BIT_LO(uv);
762         }
763     }
764     *d = '\0';
765     *len = d-dst;
766     return dst;
767 }
768
769 /*
770  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
771  *
772  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
773  * We optimize for native, for obvious reasons. */
774
775 U8*
776 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
777 {
778     U8* pend;
779     U8* dstart = d;
780
781     if (bytelen & 1)
782         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
783
784     pend = p + bytelen;
785
786     while (p < pend) {
787         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
788         p += 2;
789         if (uv < 0x80) {
790             *d++ = uv;
791             continue;
792         }
793         if (uv < 0x800) {
794             *d++ = (( uv >>  6)         | 0xc0);
795             *d++ = (( uv        & 0x3f) | 0x80);
796             continue;
797         }
798         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
799             UV low = *p++;
800             if (low < 0xdc00 || low >= 0xdfff)
801                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
802             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
803         }
804         if (uv < 0x10000) {
805             *d++ = (( uv >> 12)         | 0xe0);
806             *d++ = (((uv >>  6) & 0x3f) | 0x80);
807             *d++ = (( uv        & 0x3f) | 0x80);
808             continue;
809         }
810         else {
811             *d++ = (( uv >> 18)         | 0xf0);
812             *d++ = (((uv >> 12) & 0x3f) | 0x80);
813             *d++ = (((uv >>  6) & 0x3f) | 0x80);
814             *d++ = (( uv        & 0x3f) | 0x80);
815             continue;
816         }
817     }
818     *newlen = d - dstart;
819     return d;
820 }
821
822 /* Note: this one is slightly destructive of the source. */
823
824 U8*
825 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
826 {
827     U8* s = (U8*)p;
828     U8* send = s + bytelen;
829     while (s < send) {
830         U8 tmp = s[0];
831         s[0] = s[1];
832         s[1] = tmp;
833         s += 2;
834     }
835     return utf16_to_utf8(p, d, bytelen, newlen);
836 }
837
838 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
839
840 bool
841 Perl_is_uni_alnum(pTHX_ UV c)
842 {
843     U8 tmpbuf[UTF8_MAXLEN+1];
844     uvchr_to_utf8(tmpbuf, (UV)c);
845     return is_utf8_alnum(tmpbuf);
846 }
847
848 bool
849 Perl_is_uni_alnumc(pTHX_ UV c)
850 {
851     U8 tmpbuf[UTF8_MAXLEN+1];
852     uvchr_to_utf8(tmpbuf, (UV)c);
853     return is_utf8_alnumc(tmpbuf);
854 }
855
856 bool
857 Perl_is_uni_idfirst(pTHX_ UV c)
858 {
859     U8 tmpbuf[UTF8_MAXLEN+1];
860     uvchr_to_utf8(tmpbuf, (UV)c);
861     return is_utf8_idfirst(tmpbuf);
862 }
863
864 bool
865 Perl_is_uni_alpha(pTHX_ UV c)
866 {
867     U8 tmpbuf[UTF8_MAXLEN+1];
868     uvchr_to_utf8(tmpbuf, (UV)c);
869     return is_utf8_alpha(tmpbuf);
870 }
871
872 bool
873 Perl_is_uni_ascii(pTHX_ UV c)
874 {
875     U8 tmpbuf[UTF8_MAXLEN+1];
876     uvchr_to_utf8(tmpbuf, (UV)c);
877     return is_utf8_ascii(tmpbuf);
878 }
879
880 bool
881 Perl_is_uni_space(pTHX_ UV c)
882 {
883     U8 tmpbuf[UTF8_MAXLEN+1];
884     uvchr_to_utf8(tmpbuf, (UV)c);
885     return is_utf8_space(tmpbuf);
886 }
887
888 bool
889 Perl_is_uni_digit(pTHX_ UV c)
890 {
891     U8 tmpbuf[UTF8_MAXLEN+1];
892     uvchr_to_utf8(tmpbuf, (UV)c);
893     return is_utf8_digit(tmpbuf);
894 }
895
896 bool
897 Perl_is_uni_upper(pTHX_ UV c)
898 {
899     U8 tmpbuf[UTF8_MAXLEN+1];
900     uvchr_to_utf8(tmpbuf, (UV)c);
901     return is_utf8_upper(tmpbuf);
902 }
903
904 bool
905 Perl_is_uni_lower(pTHX_ UV c)
906 {
907     U8 tmpbuf[UTF8_MAXLEN+1];
908     uvchr_to_utf8(tmpbuf, (UV)c);
909     return is_utf8_lower(tmpbuf);
910 }
911
912 bool
913 Perl_is_uni_cntrl(pTHX_ UV c)
914 {
915     U8 tmpbuf[UTF8_MAXLEN+1];
916     uvchr_to_utf8(tmpbuf, (UV)c);
917     return is_utf8_cntrl(tmpbuf);
918 }
919
920 bool
921 Perl_is_uni_graph(pTHX_ UV c)
922 {
923     U8 tmpbuf[UTF8_MAXLEN+1];
924     uvchr_to_utf8(tmpbuf, (UV)c);
925     return is_utf8_graph(tmpbuf);
926 }
927
928 bool
929 Perl_is_uni_print(pTHX_ UV c)
930 {
931     U8 tmpbuf[UTF8_MAXLEN+1];
932     uvchr_to_utf8(tmpbuf, (UV)c);
933     return is_utf8_print(tmpbuf);
934 }
935
936 bool
937 Perl_is_uni_punct(pTHX_ UV c)
938 {
939     U8 tmpbuf[UTF8_MAXLEN+1];
940     uvchr_to_utf8(tmpbuf, (UV)c);
941     return is_utf8_punct(tmpbuf);
942 }
943
944 bool
945 Perl_is_uni_xdigit(pTHX_ UV c)
946 {
947     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
948     uvchr_to_utf8(tmpbuf, (UV)c);
949     return is_utf8_xdigit(tmpbuf);
950 }
951
952 UV
953 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
954 {
955     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
956     uvchr_to_utf8(tmpbuf, (UV)c);
957     return to_utf8_upper(tmpbuf, p, lenp);
958 }
959
960 UV
961 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
962 {
963     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
964     uvchr_to_utf8(tmpbuf, (UV)c);
965     return to_utf8_title(tmpbuf, p, lenp);
966 }
967
968 UV
969 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
970 {
971     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
972     uvchr_to_utf8(tmpbuf, (UV)c);
973     return to_utf8_lower(tmpbuf, p, lenp);
974 }
975
976 UV
977 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
978 {
979     U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
980     uvchr_to_utf8(tmpbuf, (UV)c);
981     return to_utf8_fold(tmpbuf, p, lenp);
982 }
983
984 /* for now these all assume no locale info available for Unicode > 255 */
985
986 bool
987 Perl_is_uni_alnum_lc(pTHX_ UV c)
988 {
989     return is_uni_alnum(c);     /* XXX no locale support yet */
990 }
991
992 bool
993 Perl_is_uni_alnumc_lc(pTHX_ UV c)
994 {
995     return is_uni_alnumc(c);    /* XXX no locale support yet */
996 }
997
998 bool
999 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1000 {
1001     return is_uni_idfirst(c);   /* XXX no locale support yet */
1002 }
1003
1004 bool
1005 Perl_is_uni_alpha_lc(pTHX_ UV c)
1006 {
1007     return is_uni_alpha(c);     /* XXX no locale support yet */
1008 }
1009
1010 bool
1011 Perl_is_uni_ascii_lc(pTHX_ UV c)
1012 {
1013     return is_uni_ascii(c);     /* XXX no locale support yet */
1014 }
1015
1016 bool
1017 Perl_is_uni_space_lc(pTHX_ UV c)
1018 {
1019     return is_uni_space(c);     /* XXX no locale support yet */
1020 }
1021
1022 bool
1023 Perl_is_uni_digit_lc(pTHX_ UV c)
1024 {
1025     return is_uni_digit(c);     /* XXX no locale support yet */
1026 }
1027
1028 bool
1029 Perl_is_uni_upper_lc(pTHX_ UV c)
1030 {
1031     return is_uni_upper(c);     /* XXX no locale support yet */
1032 }
1033
1034 bool
1035 Perl_is_uni_lower_lc(pTHX_ UV c)
1036 {
1037     return is_uni_lower(c);     /* XXX no locale support yet */
1038 }
1039
1040 bool
1041 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1042 {
1043     return is_uni_cntrl(c);     /* XXX no locale support yet */
1044 }
1045
1046 bool
1047 Perl_is_uni_graph_lc(pTHX_ UV c)
1048 {
1049     return is_uni_graph(c);     /* XXX no locale support yet */
1050 }
1051
1052 bool
1053 Perl_is_uni_print_lc(pTHX_ UV c)
1054 {
1055     return is_uni_print(c);     /* XXX no locale support yet */
1056 }
1057
1058 bool
1059 Perl_is_uni_punct_lc(pTHX_ UV c)
1060 {
1061     return is_uni_punct(c);     /* XXX no locale support yet */
1062 }
1063
1064 bool
1065 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1066 {
1067     return is_uni_xdigit(c);    /* XXX no locale support yet */
1068 }
1069
1070 U32
1071 Perl_to_uni_upper_lc(pTHX_ U32 c)
1072 {
1073     /* XXX returns only the first character -- do not use XXX */
1074     /* XXX no locale support yet */
1075     STRLEN len;
1076     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1077     return (U32)to_uni_upper(c, tmpbuf, &len);
1078 }
1079
1080 U32
1081 Perl_to_uni_title_lc(pTHX_ U32 c)
1082 {
1083     /* XXX returns only the first character XXX -- do not use XXX */
1084     /* XXX no locale support yet */
1085     STRLEN len;
1086     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1087     return (U32)to_uni_title(c, tmpbuf, &len);
1088 }
1089
1090 U32
1091 Perl_to_uni_lower_lc(pTHX_ U32 c)
1092 {
1093     /* XXX returns only the first character -- do not use XXX */
1094     /* XXX no locale support yet */
1095     STRLEN len;
1096     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1097     return (U32)to_uni_lower(c, tmpbuf, &len);
1098 }
1099
1100 bool
1101 Perl_is_utf8_alnum(pTHX_ U8 *p)
1102 {
1103     if (!is_utf8_char(p))
1104         return FALSE;
1105     if (!PL_utf8_alnum)
1106         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1107          * descendant of isalnum(3), in other words, it doesn't
1108          * contain the '_'. --jhi */
1109         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
1110     return swash_fetch(PL_utf8_alnum, p, TRUE);
1111 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1112 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1113     if (!PL_utf8_alnum)
1114         PL_utf8_alnum = swash_init("utf8", "",
1115             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1116     return swash_fetch(PL_utf8_alnum, p, TRUE);
1117 #endif
1118 }
1119
1120 bool
1121 Perl_is_utf8_alnumc(pTHX_ U8 *p)
1122 {
1123     if (!is_utf8_char(p))
1124         return FALSE;
1125     if (!PL_utf8_alnum)
1126         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1127     return swash_fetch(PL_utf8_alnum, p, TRUE);
1128 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
1129 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1130     if (!PL_utf8_alnum)
1131         PL_utf8_alnum = swash_init("utf8", "",
1132             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1133     return swash_fetch(PL_utf8_alnum, p, TRUE);
1134 #endif
1135 }
1136
1137 bool
1138 Perl_is_utf8_idfirst(pTHX_ U8 *p)
1139 {
1140     return *p == '_' || is_utf8_alpha(p);
1141 }
1142
1143 bool
1144 Perl_is_utf8_alpha(pTHX_ U8 *p)
1145 {
1146     if (!is_utf8_char(p))
1147         return FALSE;
1148     if (!PL_utf8_alpha)
1149         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
1150     return swash_fetch(PL_utf8_alpha, p, TRUE);
1151 }
1152
1153 bool
1154 Perl_is_utf8_ascii(pTHX_ U8 *p)
1155 {
1156     if (!is_utf8_char(p))
1157         return FALSE;
1158     if (!PL_utf8_ascii)
1159         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1160     return swash_fetch(PL_utf8_ascii, p, TRUE);
1161 }
1162
1163 bool
1164 Perl_is_utf8_space(pTHX_ U8 *p)
1165 {
1166     if (!is_utf8_char(p))
1167         return FALSE;
1168     if (!PL_utf8_space)
1169         PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1170     return swash_fetch(PL_utf8_space, p, TRUE);
1171 }
1172
1173 bool
1174 Perl_is_utf8_digit(pTHX_ U8 *p)
1175 {
1176     if (!is_utf8_char(p))
1177         return FALSE;
1178     if (!PL_utf8_digit)
1179         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1180     return swash_fetch(PL_utf8_digit, p, TRUE);
1181 }
1182
1183 bool
1184 Perl_is_utf8_upper(pTHX_ U8 *p)
1185 {
1186     if (!is_utf8_char(p))
1187         return FALSE;
1188     if (!PL_utf8_upper)
1189         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
1190     return swash_fetch(PL_utf8_upper, p, TRUE);
1191 }
1192
1193 bool
1194 Perl_is_utf8_lower(pTHX_ U8 *p)
1195 {
1196     if (!is_utf8_char(p))
1197         return FALSE;
1198     if (!PL_utf8_lower)
1199         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
1200     return swash_fetch(PL_utf8_lower, p, TRUE);
1201 }
1202
1203 bool
1204 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1205 {
1206     if (!is_utf8_char(p))
1207         return FALSE;
1208     if (!PL_utf8_cntrl)
1209         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1210     return swash_fetch(PL_utf8_cntrl, p, TRUE);
1211 }
1212
1213 bool
1214 Perl_is_utf8_graph(pTHX_ U8 *p)
1215 {
1216     if (!is_utf8_char(p))
1217         return FALSE;
1218     if (!PL_utf8_graph)
1219         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1220     return swash_fetch(PL_utf8_graph, p, TRUE);
1221 }
1222
1223 bool
1224 Perl_is_utf8_print(pTHX_ U8 *p)
1225 {
1226     if (!is_utf8_char(p))
1227         return FALSE;
1228     if (!PL_utf8_print)
1229         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1230     return swash_fetch(PL_utf8_print, p, TRUE);
1231 }
1232
1233 bool
1234 Perl_is_utf8_punct(pTHX_ U8 *p)
1235 {
1236     if (!is_utf8_char(p))
1237         return FALSE;
1238     if (!PL_utf8_punct)
1239         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1240     return swash_fetch(PL_utf8_punct, p, TRUE);
1241 }
1242
1243 bool
1244 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1245 {
1246     if (!is_utf8_char(p))
1247         return FALSE;
1248     if (!PL_utf8_xdigit)
1249         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1250     return swash_fetch(PL_utf8_xdigit, p, TRUE);
1251 }
1252
1253 bool
1254 Perl_is_utf8_mark(pTHX_ U8 *p)
1255 {
1256     if (!is_utf8_char(p))
1257         return FALSE;
1258     if (!PL_utf8_mark)
1259         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1260     return swash_fetch(PL_utf8_mark, p, TRUE);
1261 }
1262
1263 /*
1264 =for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1265
1266 The "p" contains the pointer to the UTF-8 string encoding
1267 the character that is being converted.
1268
1269 The "ustrp" is a pointer to the character buffer to put the
1270 conversion result to.  The "lenp" is a pointer to the length
1271 of the result.
1272
1273 The "swash" is a pointer to the swash to use.
1274
1275 The "normal" is a string like "ToLower" which means the swash
1276 $utf8::ToLower, which is stored in lib/unicore/To/Lower.pl,
1277 and loaded by SWASHGET, using lib/utf8_heavy.pl.
1278
1279 The "special" is a string like "utf8::ToSpecLower", which means
1280 the hash %utf8::ToSpecLower, which is stored in the same file,
1281 lib/unicore/To/Lower.pl, and also loaded by SWASHGET.  The access
1282 to the hash is by Perl_to_utf8_case().
1283
1284 =cut
1285  */
1286
1287 UV
1288 Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
1289 {
1290     UV uv;
1291
1292     if (!*swashp)
1293         *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1294     uv = swash_fetch(*swashp, p, TRUE);
1295     if (uv)
1296          uv = UNI_TO_NATIVE(uv);
1297     else {
1298          HV *hv;
1299          SV *keysv;
1300          HE *he;
1301
1302          uv = utf8_to_uvchr(p, 0);
1303
1304          if ((hv    = get_hv(special, FALSE)) &&
1305              (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv))) &&
1306              (he    = hv_fetch_ent(hv, keysv, FALSE, 0))) {
1307               SV *val = HeVAL(he);
1308               char *s = SvPV(val, *lenp);
1309               U8 c = *(U8*)s;
1310               if (*lenp > 1 || UNI_IS_INVARIANT(c))
1311                    Copy(s, ustrp, *lenp, U8);
1312               else {
1313                    /* something in the 0x80..0xFF range */
1314                    ustrp[0] = UTF8_EIGHT_BIT_HI(c);
1315                    ustrp[1] = UTF8_EIGHT_BIT_LO(c);
1316                    *lenp = 2;
1317               }
1318               return utf8_to_uvchr(ustrp, 0);
1319          }
1320     }
1321     if (lenp)
1322        *lenp = UNISKIP(uv);
1323     uvuni_to_utf8(ustrp, uv);
1324     return uv;
1325 }
1326
1327 /*
1328 =for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1329
1330 Convert the UTF-8 encoded character at p to its uppercase version and
1331 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1332 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1333 uppercase version may be longer than the original character (up to two
1334 characters).
1335
1336 The first character of the uppercased version is returned
1337 (but note, as explained above, that there may be more.)
1338
1339 =cut */
1340
1341 UV
1342 Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1343 {
1344     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1345                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1346 }
1347
1348 /*
1349 =for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1350
1351 Convert the UTF-8 encoded character at p to its titlecase version and
1352 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1353 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1354 titlecase version may be longer than the original character (up to two
1355 characters).
1356
1357 The first character of the titlecased version is returned
1358 (but note, as explained above, that there may be more.)
1359
1360 =cut */
1361
1362 UV
1363 Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1364 {
1365     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1366                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1367 }
1368
1369 /*
1370 =for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1371
1372 Convert the UTF-8 encoded character at p to its lowercase version and
1373 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1374 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1375 lowercase version may be longer than the original character (up to two
1376 characters).
1377
1378 The first character of the lowercased version is returned
1379 (but note, as explained above, that there may be more.)
1380
1381 =cut */
1382
1383 UV
1384 Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1385 {
1386     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1387                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1388 }
1389
1390 /*
1391 =for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1392
1393 Convert the UTF-8 encoded character at p to its foldcase version and
1394 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1395 that the ustrp needs to be at least UTF8_MAXLEN_FOLD+1 bytes since the
1396 foldcase version may be longer than the original character (up to
1397 three characters).
1398
1399 The first character of the foldcased version is returned
1400 (but note, as explained above, that there may be more.)
1401
1402 =cut */
1403
1404 UV
1405 Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1406 {
1407     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1408                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1409 }
1410
1411 /* a "swash" is a swatch hash */
1412
1413 SV*
1414 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1415 {
1416     SV* retval;
1417     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1418     dSP;
1419     HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
1420     SV* errsv_save;
1421
1422     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1423         ENTER;
1424         errsv_save = newSVsv(ERRSV);
1425         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1426         if (!SvTRUE(ERRSV))
1427             sv_setsv(ERRSV, errsv_save);
1428         SvREFCNT_dec(errsv_save);
1429         LEAVE;
1430     }
1431     SPAGAIN;
1432     PUSHSTACKi(PERLSI_MAGIC);
1433     PUSHMARK(SP);
1434     EXTEND(SP,5);
1435     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1436     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1437     PUSHs(listsv);
1438     PUSHs(sv_2mortal(newSViv(minbits)));
1439     PUSHs(sv_2mortal(newSViv(none)));
1440     PUTBACK;
1441     ENTER;
1442     SAVEI32(PL_hints);
1443     PL_hints = 0;
1444     save_re_context();
1445     if (PL_curcop == &PL_compiling)
1446         /* XXX ought to be handled by lex_start */
1447         sv_setpv(tokenbufsv, PL_tokenbuf);
1448     errsv_save = newSVsv(ERRSV);
1449     if (call_method("SWASHNEW", G_SCALAR))
1450         retval = newSVsv(*PL_stack_sp--);
1451     else
1452         retval = &PL_sv_undef;
1453     if (!SvTRUE(ERRSV))
1454         sv_setsv(ERRSV, errsv_save);
1455     SvREFCNT_dec(errsv_save);
1456     LEAVE;
1457     POPSTACK;
1458     if (PL_curcop == &PL_compiling) {
1459         STRLEN len;
1460         char* pv = SvPV(tokenbufsv, len);
1461
1462         Copy(pv, PL_tokenbuf, len+1, char);
1463         PL_curcop->op_private = PL_hints;
1464     }
1465     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
1466         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1467     return retval;
1468 }
1469
1470
1471 /* This API is wrong for special case conversions since we may need to
1472  * return several Unicode characters for a single Unicode character
1473  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1474  * the lower-level routine, and it is similarly broken for returning
1475  * multiple values.  --jhi */
1476 UV
1477 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
1478 {
1479     HV* hv = (HV*)SvRV(sv);
1480     U32 klen;
1481     U32 off;
1482     STRLEN slen;
1483     STRLEN needents;
1484     U8 *tmps = NULL;
1485     U32 bit;
1486     SV *retval;
1487     U8 tmputf8[2];
1488     UV c = NATIVE_TO_ASCII(*ptr);
1489
1490     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1491         tmputf8[0] = UTF8_EIGHT_BIT_HI(c);
1492         tmputf8[1] = UTF8_EIGHT_BIT_LO(c);
1493         ptr = tmputf8;
1494     }
1495     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1496      * then the "swatch" is a vec() for al the chars which start
1497      * with 0xAA..0xYY
1498      * So the key in the hash (klen) is length of encoded char -1
1499      */
1500     klen = UTF8SKIP(ptr) - 1;
1501     off  = ptr[klen];
1502
1503     if (klen == 0)
1504      {
1505       /* If char in invariant then swatch is for all the invariant chars
1506        * In both UTF-8 and UTF8-MOD that happens to be UTF_CONTINUATION_MARK
1507        */
1508       needents = UTF_CONTINUATION_MARK;
1509       off      = NATIVE_TO_UTF(ptr[klen]);
1510      }
1511     else
1512      {
1513       /* If char is encoded then swatch is for the prefix */
1514       needents = (1 << UTF_ACCUMULATION_SHIFT);
1515       off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1516      }
1517
1518     /*
1519      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1520      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1521      * it's nothing to sniff at.)  Pity we usually come through at least
1522      * two function calls to get here...
1523      *
1524      * NB: this code assumes that swatches are never modified, once generated!
1525      */
1526
1527     if (hv   == PL_last_swash_hv &&
1528         klen == PL_last_swash_klen &&
1529         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1530     {
1531         tmps = PL_last_swash_tmps;
1532         slen = PL_last_swash_slen;
1533     }
1534     else {
1535         /* Try our second-level swatch cache, kept in a hash. */
1536         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1537
1538         /* If not cached, generate it via utf8::SWASHGET */
1539         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1540             dSP;
1541             /* We use utf8n_to_uvuni() as we want an index into
1542                Unicode tables, not a native character number.
1543              */
1544             UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
1545             SV *errsv_save;
1546             ENTER;
1547             SAVETMPS;
1548             save_re_context();
1549             PUSHSTACKi(PERLSI_MAGIC);
1550             PUSHMARK(SP);
1551             EXTEND(SP,3);
1552             PUSHs((SV*)sv);
1553             /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1554             PUSHs(sv_2mortal(newSViv((klen) ?
1555                                      (code_point & ~(needents - 1)) : 0)));
1556             PUSHs(sv_2mortal(newSViv(needents)));
1557             PUTBACK;
1558             errsv_save = newSVsv(ERRSV);
1559             if (call_method("SWASHGET", G_SCALAR))
1560                 retval = newSVsv(*PL_stack_sp--);
1561             else
1562                 retval = &PL_sv_undef;
1563             if (!SvTRUE(ERRSV))
1564                 sv_setsv(ERRSV, errsv_save);
1565             SvREFCNT_dec(errsv_save);
1566             POPSTACK;
1567             FREETMPS;
1568             LEAVE;
1569             if (PL_curcop == &PL_compiling)
1570                 PL_curcop->op_private = PL_hints;
1571
1572             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1573
1574             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
1575                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1576         }
1577
1578         PL_last_swash_hv = hv;
1579         PL_last_swash_klen = klen;
1580         PL_last_swash_tmps = tmps;
1581         PL_last_swash_slen = slen;
1582         if (klen)
1583             Copy(ptr, PL_last_swash_key, klen, U8);
1584     }
1585
1586     switch ((int)((slen << 3) / needents)) {
1587     case 1:
1588         bit = 1 << (off & 7);
1589         off >>= 3;
1590         return (tmps[off] & bit) != 0;
1591     case 8:
1592         return tmps[off];
1593     case 16:
1594         off <<= 1;
1595         return (tmps[off] << 8) + tmps[off + 1] ;
1596     case 32:
1597         off <<= 2;
1598         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1599     }
1600     Perl_croak(aTHX_ "panic: swash_fetch");
1601     return 0;
1602 }
1603
1604
1605 /*
1606 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
1607
1608 Adds the UTF8 representation of the Native codepoint C<uv> to the end
1609 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1610 bytes available. The return value is the pointer to the byte after the
1611 end of the new character. In other words,
1612
1613     d = uvchr_to_utf8(d, uv);
1614
1615 is the recommended wide native character-aware way of saying
1616
1617     *(d++) = uv;
1618
1619 =cut
1620 */
1621
1622 /* On ASCII machines this is normally a macro but we want a
1623    real function in case XS code wants it
1624 */
1625 #undef Perl_uvchr_to_utf8
1626 U8 *
1627 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1628 {
1629     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
1630 }
1631
1632 U8 *
1633 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1634 {
1635     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1636 }
1637
1638 /*
1639 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1640
1641 Returns the native character value of the first character in the string C<s>
1642 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
1643 length, in bytes, of that character.
1644
1645 Allows length and flags to be passed to low level routine.
1646
1647 =cut
1648 */
1649 /* On ASCII machines this is normally a macro but we want a
1650    real function in case XS code wants it
1651 */
1652 #undef Perl_utf8n_to_uvchr
1653 UV
1654 Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1655 {
1656     UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1657     return UNI_TO_NATIVE(uv);
1658 }
1659
1660 /*
1661 =for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1662
1663 Build to the scalar dsv a displayable version of the string spv,
1664 length len, the displayable version being at most pvlim bytes long
1665 (if longer, the rest is truncated and "..." will be appended).
1666 The flags argument can have UNI_DISPLAY_ISPRINT set to display
1667 isprint() characters as themselves.
1668 The pointer to the PV of the dsv is returned.
1669
1670 =cut */
1671 char *
1672 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1673 {
1674     int truncated = 0;
1675     char *s, *e;
1676
1677     sv_setpvn(dsv, "", 0);
1678     for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1679          UV u;
1680          bool ok = FALSE;
1681
1682          if (pvlim && SvCUR(dsv) >= pvlim) {
1683               truncated++;
1684               break;
1685          }
1686          u = utf8_to_uvchr((U8*)s, 0);
1687          if (u < 256) {
1688              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isprint(u & 0xFF)) {
1689                  Perl_sv_catpvf(aTHX_ dsv, "%c", u);
1690                  ok = TRUE;
1691              }
1692              if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1693                  switch (u & 0xFF) {
1694                  case '\n':
1695                      Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
1696                  case '\r':
1697                      Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
1698                  case '\t':
1699                      Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
1700                  case '\f':
1701                      Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
1702                  case '\a':
1703                      Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
1704                  case '\\':
1705                      Perl_sv_catpvf(aTHX_ dsv, "\\" ); ok = TRUE; break;
1706                  default: break;
1707                  }
1708              }
1709          }
1710          if (!ok)
1711              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1712     }
1713     if (truncated)
1714          sv_catpvn(dsv, "...", 3);
1715     
1716     return SvPVX(dsv);
1717 }
1718
1719 /*
1720 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1721
1722 Build to the scalar dsv a displayable version of the scalar sv,
1723 he displayable version being at most pvlim bytes long
1724 (if longer, the rest is truncated and "..." will be appended).
1725 The flags argument is currently unused but available for future extensions.
1726 The pointer to the PV of the dsv is returned.
1727
1728 =cut */
1729 char *
1730 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1731 {
1732      return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1733                                 pvlim, flags);
1734 }
1735
1736 /*
1737 =for apidoc A|I32|ibcmp_utf8|const char *s1|char **pe1|register UV l1|bool u1|const char *s2|char **pe2|register UV l2|bool u2
1738
1739 Return true if the strings s1 and s2 differ case-insensitively, false
1740 if not (if they are equal case-insensitively).  If u1 is true, the
1741 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
1742 the string s2 is assumed to be in UTF-8-encoded Unicode.  If u1 or u2
1743 are false, the respective string is assumed to be in native 8-bit
1744 encoding.
1745
1746 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1747 in there (they will point at the beginning of the I<next> character).
1748 If the pointers behind pe1 or pe2 are non-NULL, they are the end
1749 pointers beyond which scanning will not continue under any
1750 circustances.  If the byte lengths l1 and l2 are non-zero, s1+l1 and
1751 s2+l2 will be used as goal end pointers that will also stop the scan,
1752 and which qualify towards defining a successful match: all the scans
1753 that define an explicit length must reach their goal pointers for
1754 a match to succeed).
1755
1756 For case-insensitiveness, the "casefolding" of Unicode is used
1757 instead of upper/lowercasing both the characters, see
1758 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1759
1760 =cut */
1761 I32
1762 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
1763 {
1764      register U8 *p1  = (U8*)s1;
1765      register U8 *p2  = (U8*)s2;
1766      register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1767      register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1768      STRLEN n1 = 0, n2 = 0;
1769      U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
1770      U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
1771      U8 natbuf[1+1];
1772      STRLEN foldlen1, foldlen2;
1773      bool match;
1774      
1775      if (pe1)
1776           e1 = *(U8**)pe1;
1777      if (e1 == 0 || (l1 && l1 < e1 - (U8*)s1))
1778           f1 = (U8*)s1 + l1;
1779      if (pe2)
1780           e2 = *(U8**)pe2;
1781      if (e2 == 0 || (l2 && l2 < e2 - (U8*)s2))
1782           f2 = (U8*)s2 + l2;
1783
1784      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1785           return 1; /* mismatch; possible infinite loop or false positive */
1786
1787      while ((e1 == 0 || p1 < e1) &&
1788             (f1 == 0 || p1 < f1) &&
1789             (e2 == 0 || p2 < e2) &&
1790             (f2 == 0 || p2 < f2)) {
1791           if (n1 == 0) {
1792                if (u1)
1793                     to_utf8_fold(p1, foldbuf1, &foldlen1);
1794                else {
1795                     natbuf[0] = NATIVE_TO_UNI(*p1);
1796                     to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1797                }
1798                q1 = foldbuf1;
1799                n1 = foldlen1;
1800           }
1801           if (n2 == 0) {
1802                if (u2)
1803                     to_utf8_fold(p2, foldbuf2, &foldlen2);
1804                else {
1805                     natbuf[0] = NATIVE_TO_UNI(*p2);
1806                     to_utf8_fold(natbuf, foldbuf2, &foldlen2);
1807                }
1808                q2 = foldbuf2;
1809                n2 = foldlen2;
1810           }
1811           while (n1 && n2) {
1812                if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
1813                    (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
1814                     memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
1815                    return 1; /* mismatch */
1816                n1 -= UTF8SKIP(q1);
1817                q1 += UTF8SKIP(q1);
1818                n2 -= UTF8SKIP(q2);
1819                q2 += UTF8SKIP(q2);
1820           }
1821           if (n1 == 0)
1822                p1 += u1 ? UTF8SKIP(p1) : 1;
1823           if (n2 == 0)
1824                p2 += u2 ? UTF8SKIP(p2) : 1;
1825
1826      }
1827
1828      /* A match is defined by all the scans that specified
1829       * an explicit length reaching their final goals. */
1830      match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
1831
1832      if (match) {
1833           if (pe1)
1834                *pe1 = (char*)p1;
1835           if (pe2)
1836                *pe2 = (char*)p2;
1837      }
1838
1839      return match ? 0 : 1; /* 0 match, 1 mismatch */
1840 }
1841