This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document the flags of pv_uni_display().
[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
1650    a 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
1667 The flags argument can have UNI_DISPLAY_ISPRINT set to display
1668 isprint()able characters as themselves, UNI_DISPLAY_BACKSLASH
1669 to display the \\[nrfta\\] as the backslashed versions (like '\n')
1670 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1671 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1672 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1673
1674 The pointer to the PV of the dsv is returned.
1675
1676 =cut */
1677 char *
1678 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1679 {
1680     int truncated = 0;
1681     char *s, *e;
1682
1683     sv_setpvn(dsv, "", 0);
1684     for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1685          UV u;
1686          bool ok = FALSE;
1687
1688          if (pvlim && SvCUR(dsv) >= pvlim) {
1689               truncated++;
1690               break;
1691          }
1692          u = utf8_to_uvchr((U8*)s, 0);
1693          if (u < 256) {
1694              if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1695                  switch (u & 0xFF) {
1696                  case '\n':
1697                      Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
1698                  case '\r':
1699                      Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
1700                  case '\t':
1701                      Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
1702                  case '\f':
1703                      Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
1704                  case '\a':
1705                      Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
1706                  case '\\':
1707                      Perl_sv_catpvf(aTHX_ dsv, "\\" ); ok = TRUE; break;
1708                  default: break;
1709                  }
1710              }
1711              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isprint(u & 0xFF)) {
1712                  Perl_sv_catpvf(aTHX_ dsv, "%c", u);
1713                  ok = TRUE;
1714              }
1715          }
1716          if (!ok)
1717              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1718     }
1719     if (truncated)
1720          sv_catpvn(dsv, "...", 3);
1721     
1722     return SvPVX(dsv);
1723 }
1724
1725 /*
1726 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1727
1728 Build to the scalar dsv a displayable version of the scalar sv,
1729 the displayable version being at most pvlim bytes long
1730 (if longer, the rest is truncated and "..." will be appended).
1731
1732 The flags argument is as in pv_uni_display().
1733
1734 The pointer to the PV of the dsv is returned.
1735
1736 =cut */
1737 char *
1738 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1739 {
1740      return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1741                                 pvlim, flags);
1742 }
1743
1744 /*
1745 =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
1746
1747 Return true if the strings s1 and s2 differ case-insensitively, false
1748 if not (if they are equal case-insensitively).  If u1 is true, the
1749 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
1750 the string s2 is assumed to be in UTF-8-encoded Unicode.  If u1 or u2
1751 are false, the respective string is assumed to be in native 8-bit
1752 encoding.
1753
1754 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1755 in there (they will point at the beginning of the I<next> character).
1756 If the pointers behind pe1 or pe2 are non-NULL, they are the end
1757 pointers beyond which scanning will not continue under any
1758 circustances.  If the byte lengths l1 and l2 are non-zero, s1+l1 and
1759 s2+l2 will be used as goal end pointers that will also stop the scan,
1760 and which qualify towards defining a successful match: all the scans
1761 that define an explicit length must reach their goal pointers for
1762 a match to succeed).
1763
1764 For case-insensitiveness, the "casefolding" of Unicode is used
1765 instead of upper/lowercasing both the characters, see
1766 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1767
1768 =cut */
1769 I32
1770 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
1771 {
1772      register U8 *p1  = (U8*)s1;
1773      register U8 *p2  = (U8*)s2;
1774      register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1775      register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1776      STRLEN n1 = 0, n2 = 0;
1777      U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
1778      U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
1779      U8 natbuf[1+1];
1780      STRLEN foldlen1, foldlen2;
1781      bool match;
1782      
1783      if (pe1)
1784           e1 = *(U8**)pe1;
1785      if (e1 == 0 || (l1 && l1 < e1 - (U8*)s1))
1786           f1 = (U8*)s1 + l1;
1787      if (pe2)
1788           e2 = *(U8**)pe2;
1789      if (e2 == 0 || (l2 && l2 < e2 - (U8*)s2))
1790           f2 = (U8*)s2 + l2;
1791
1792      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1793           return 1; /* mismatch; possible infinite loop or false positive */
1794
1795      while ((e1 == 0 || p1 < e1) &&
1796             (f1 == 0 || p1 < f1) &&
1797             (e2 == 0 || p2 < e2) &&
1798             (f2 == 0 || p2 < f2)) {
1799           if (n1 == 0) {
1800                if (u1)
1801                     to_utf8_fold(p1, foldbuf1, &foldlen1);
1802                else {
1803                     natbuf[0] = NATIVE_TO_UNI(*p1);
1804                     to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1805                }
1806                q1 = foldbuf1;
1807                n1 = foldlen1;
1808           }
1809           if (n2 == 0) {
1810                if (u2)
1811                     to_utf8_fold(p2, foldbuf2, &foldlen2);
1812                else {
1813                     natbuf[0] = NATIVE_TO_UNI(*p2);
1814                     to_utf8_fold(natbuf, foldbuf2, &foldlen2);
1815                }
1816                q2 = foldbuf2;
1817                n2 = foldlen2;
1818           }
1819           while (n1 && n2) {
1820                if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
1821                    (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
1822                     memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
1823                    return 1; /* mismatch */
1824                n1 -= UTF8SKIP(q1);
1825                q1 += UTF8SKIP(q1);
1826                n2 -= UTF8SKIP(q2);
1827                q2 += UTF8SKIP(q2);
1828           }
1829           if (n1 == 0)
1830                p1 += u1 ? UTF8SKIP(p1) : 1;
1831           if (n2 == 0)
1832                p2 += u2 ? UTF8SKIP(p2) : 1;
1833
1834      }
1835
1836      /* A match is defined by all the scans that specified
1837       * an explicit length reaching their final goals. */
1838      match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
1839
1840      if (match) {
1841           if (pe1)
1842                *pe1 = (char*)p1;
1843           if (pe2)
1844                *pe2 = (char*)p2;
1845      }
1846
1847      return match ? 0 : 1; /* 0 match, 1 mismatch */
1848 }
1849