Re: API Cleanup
[p5sagit/p5-mst-13.2.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 /* Unicode support */
28
29 /*
30 =for apidoc A|U8*|uv_to_utf8|U8 *d|UV uv
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 = uv_to_utf8(d, uv);
38
39 is the recommended Unicode-aware way of saying
40
41     *(d++) = uv;
42
43 =cut
44 */
45
46 U8 *
47 Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
48 {
49     if (uv < 0x80) {
50         *d++ = uv;
51         return d;
52     }
53     if (uv < 0x800) {
54         *d++ = (( uv >>  6)         | 0xc0);
55         *d++ = (( uv        & 0x3f) | 0x80);
56         return d;
57     }
58     if (uv < 0x10000) {
59         *d++ = (( uv >> 12)         | 0xe0);
60         *d++ = (((uv >>  6) & 0x3f) | 0x80);
61         *d++ = (( uv        & 0x3f) | 0x80);
62         return d;
63     }
64     if (uv < 0x200000) {
65         *d++ = (( uv >> 18)         | 0xf0);
66         *d++ = (((uv >> 12) & 0x3f) | 0x80);
67         *d++ = (((uv >>  6) & 0x3f) | 0x80);
68         *d++ = (( uv        & 0x3f) | 0x80);
69         return d;
70     }
71     if (uv < 0x4000000) {
72         *d++ = (( uv >> 24)         | 0xf8);
73         *d++ = (((uv >> 18) & 0x3f) | 0x80);
74         *d++ = (((uv >> 12) & 0x3f) | 0x80);
75         *d++ = (((uv >>  6) & 0x3f) | 0x80);
76         *d++ = (( uv        & 0x3f) | 0x80);
77         return d;
78     }
79     if (uv < 0x80000000) {
80         *d++ = (( uv >> 30)         | 0xfc);
81         *d++ = (((uv >> 24) & 0x3f) | 0x80);
82         *d++ = (((uv >> 18) & 0x3f) | 0x80);
83         *d++ = (((uv >> 12) & 0x3f) | 0x80);
84         *d++ = (((uv >>  6) & 0x3f) | 0x80);
85         *d++ = (( uv        & 0x3f) | 0x80);
86         return d;
87     }
88 #ifdef HAS_QUAD
89     if (uv < UTF8_QUAD_MAX)
90 #endif
91     {
92         *d++ =                        0xfe;     /* Can't match U+FEFF! */
93         *d++ = (((uv >> 30) & 0x3f) | 0x80);
94         *d++ = (((uv >> 24) & 0x3f) | 0x80);
95         *d++ = (((uv >> 18) & 0x3f) | 0x80);
96         *d++ = (((uv >> 12) & 0x3f) | 0x80);
97         *d++ = (((uv >>  6) & 0x3f) | 0x80);
98         *d++ = (( uv        & 0x3f) | 0x80);
99         return d;
100     }
101 #ifdef HAS_QUAD
102     {
103         *d++ =                        0xff;     /* Can't match U+FFFE! */
104         *d++ =                        0x80;     /* 6 Reserved bits */
105         *d++ = (((uv >> 60) & 0x0f) | 0x80);    /* 2 Reserved bits */
106         *d++ = (((uv >> 54) & 0x3f) | 0x80);
107         *d++ = (((uv >> 48) & 0x3f) | 0x80);
108         *d++ = (((uv >> 42) & 0x3f) | 0x80);
109         *d++ = (((uv >> 36) & 0x3f) | 0x80);
110         *d++ = (((uv >> 30) & 0x3f) | 0x80);
111         *d++ = (((uv >> 24) & 0x3f) | 0x80);
112         *d++ = (((uv >> 18) & 0x3f) | 0x80);
113         *d++ = (((uv >> 12) & 0x3f) | 0x80);
114         *d++ = (((uv >>  6) & 0x3f) | 0x80);
115         *d++ = (( uv        & 0x3f) | 0x80);
116         return d;
117     }
118 #endif
119 }
120
121 /*
122 =for apidoc A|STRLEN|is_utf8_char|U8 *s
123
124 Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
125 The actual number of bytes in the UTF-8 character will be returned if it
126 is valid, otherwise 0. 
127  
128 =cut
129 */
130 STRLEN
131 Perl_is_utf8_char(pTHX_ U8 *s)
132 {
133     U8 u = *s;
134     STRLEN slen, len;
135     UV uv, ouv;
136
137     if (UTF8_IS_ASCII(u))
138         return 1;
139
140     if (!UTF8_IS_START(u))
141         return 0;
142
143     len = UTF8SKIP(s);
144
145     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
146         return 0;
147
148     slen = len - 1;
149     s++;
150     uv = u;
151     ouv = uv;
152     while (slen--) {
153         if (!UTF8_IS_CONTINUATION(*s))
154             return 0;
155         uv = UTF8_ACCUMULATE(uv, *s);
156         if (uv < ouv)
157             return 0;
158         ouv = uv;
159         s++;
160     }
161
162     if (UNISKIP(uv) < len)
163         return 0;
164
165     return len;
166 }
167
168 /*
169 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
170
171 Returns true if first C<len> bytes of the given string form valid a UTF8
172 string, false otherwise.
173
174 =cut
175 */
176
177 bool
178 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
179 {
180     U8* x = s;
181     U8* send;
182     STRLEN c;
183
184     if (!len)
185         len = strlen((char *)s);
186     send = s + len;
187
188     while (x < send) {
189         c = is_utf8_char(x);
190         if (!c)
191             return FALSE;
192         x += c;
193     }
194     if (x != send)
195         return FALSE;
196
197     return TRUE;
198 }
199
200 /*
201 =for apidoc A|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags
202
203 Returns the character value of the first character in the string C<s>
204 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
205 C<retlen> will be set to the length, in bytes, of that character.
206
207 If C<s> does not point to a well-formed UTF8 character, the behaviour
208 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
209 it is assumed that the caller will raise a warning, and this function
210 will silently just set C<retlen> to C<-1> and return zero.  If the
211 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
212 malformations will be given, C<retlen> will be set to the expected
213 length of the UTF-8 character in bytes, and zero will be returned.
214
215 The C<flags> can also contain various flags to allow deviations from
216 the strict UTF-8 encoding (see F<utf8.h>).
217
218 =cut */
219
220 UV
221 Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
222 {
223     UV uv = *s, ouv;
224     STRLEN len = 1;
225 #ifdef EBCDIC
226     bool dowarn = 0;
227 #else
228     bool dowarn = ckWARN_d(WARN_UTF8);
229 #endif
230     STRLEN expectlen = 0;
231     U32 warning = 0;
232
233 /* This list is a superset of the UTF8_ALLOW_XXX. */
234
235 #define UTF8_WARN_EMPTY                          1
236 #define UTF8_WARN_CONTINUATION                   2
237 #define UTF8_WARN_NON_CONTINUATION               3
238 #define UTF8_WARN_FE_FF                          4
239 #define UTF8_WARN_SHORT                          5
240 #define UTF8_WARN_OVERFLOW                       6
241 #define UTF8_WARN_SURROGATE                      7
242 #define UTF8_WARN_BOM                            8
243 #define UTF8_WARN_LONG                           9
244 #define UTF8_WARN_FFFF                          10
245
246     if (curlen == 0 &&
247         !(flags & UTF8_ALLOW_EMPTY)) {
248         warning = UTF8_WARN_EMPTY;
249         goto malformed;
250     }
251
252     if (UTF8_IS_ASCII(uv)) {
253         if (retlen)
254             *retlen = 1;
255         return *s;
256     }
257
258     if (UTF8_IS_CONTINUATION(uv) &&
259         !(flags & UTF8_ALLOW_CONTINUATION)) {
260         warning = UTF8_WARN_CONTINUATION;
261         goto malformed;
262     }
263
264     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
265         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
266         warning = UTF8_WARN_NON_CONTINUATION;
267         goto malformed;
268     }
269     
270     if ((uv == 0xfe || uv == 0xff) &&
271         !(flags & UTF8_ALLOW_FE_FF)) {
272         warning = UTF8_WARN_FE_FF;
273         goto malformed;
274     }
275         
276     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
277     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
278     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
279     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
280     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
281     else if (!(uv & 0x01))      { len =  7; uv = 0; }
282     else                        { len = 13; uv = 0; } /* whoa! */
283         
284     if (retlen)
285         *retlen = len;
286     
287     expectlen = len;
288
289     if ((curlen < expectlen) &&
290         !(flags & UTF8_ALLOW_SHORT)) {
291         warning = UTF8_WARN_SHORT;
292         goto malformed;
293     }
294
295     len--;
296     s++;
297     ouv = uv;
298
299     while (len--) {
300         if (!UTF8_IS_CONTINUATION(*s) &&
301             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
302             s--;
303             warning = UTF8_WARN_NON_CONTINUATION;
304             goto malformed;
305         }
306         else
307             uv = UTF8_ACCUMULATE(uv, *s);
308         if (!(uv > ouv)) {
309             /* These cannot be allowed. */
310             if (uv == ouv) {
311                 if (!(flags & UTF8_ALLOW_LONG)) {
312                     warning = UTF8_WARN_LONG;
313                     goto malformed;
314                 }
315             }
316             else { /* uv < ouv */
317                 /* This cannot be allowed. */
318                 warning = UTF8_WARN_OVERFLOW;
319                 goto malformed;
320             }
321         }
322         s++;
323         ouv = uv;
324     }
325
326     if (UNICODE_IS_SURROGATE(uv) &&
327         !(flags & UTF8_ALLOW_SURROGATE)) {
328         warning = UTF8_WARN_SURROGATE;
329         goto malformed;
330     } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
331                !(flags & UTF8_ALLOW_BOM)) {
332         warning = UTF8_WARN_BOM;
333         goto malformed;
334     } else if ((expectlen > UNISKIP(uv)) &&
335                !(flags & UTF8_ALLOW_LONG)) {
336         warning = UTF8_WARN_LONG;
337         goto malformed;
338     } else if (UNICODE_IS_ILLEGAL(uv) &&
339                !(flags & UTF8_ALLOW_FFFF)) {
340         warning = UTF8_WARN_FFFF;
341         goto malformed;
342     }
343
344     return uv;
345
346 malformed:
347
348     if (flags & UTF8_CHECK_ONLY) {
349         if (retlen)
350             *retlen = -1;
351         return 0;
352     }
353
354     if (dowarn) {
355         SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
356
357         switch (warning) {
358         case 0: /* Intentionally empty. */ break;
359         case UTF8_WARN_EMPTY:
360             Perl_sv_catpvf(aTHX_ sv, "(empty string)");
361             break;
362         case UTF8_WARN_CONTINUATION:
363             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
364             break;
365         case UTF8_WARN_NON_CONTINUATION:
366             Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
367                            (UV)s[1], uv);
368             break;
369         case UTF8_WARN_FE_FF:
370             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
371             break;
372         case UTF8_WARN_SHORT:
373             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
374                            curlen, curlen == 1 ? "" : "s", expectlen);
375             break;
376         case UTF8_WARN_OVERFLOW:
377             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
378                            ouv, *s);
379             break;
380         case UTF8_WARN_SURROGATE:
381             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
382             break;
383         case UTF8_WARN_BOM:
384             Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
385             break;
386         case UTF8_WARN_LONG:
387             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
388                            expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
389             break;
390         case UTF8_WARN_FFFF:
391             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
392             break;
393         default:
394             Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
395             break;
396         }
397         
398         if (warning) {
399             char *s = SvPVX(sv);
400
401             if (PL_op)
402                 Perl_warner(aTHX_ WARN_UTF8,
403                             "%s in %s", s,  PL_op_desc[PL_op->op_type]);
404             else
405                 Perl_warner(aTHX_ WARN_UTF8, "%s", s);
406         }
407     }
408
409     if (retlen)
410         *retlen = expectlen ? expectlen : len;
411
412     return 0;
413 }
414
415 /*
416 =for apidoc A|U8* s|utf8_to_uv_simple|STRLEN *retlen
417
418 Returns the character value of the first character in the string C<s>
419 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
420 length, in bytes, of that character.
421
422 If C<s> does not point to a well-formed UTF8 character, zero is
423 returned and retlen is set, if possible, to -1.
424
425 =cut
426 */
427
428 UV
429 Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
430 {
431     return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0);
432 }
433
434 /*
435 =for apidoc A|STRLEN|utf8_length|U8* s|U8 *e
436
437 Return the length of the UTF-8 char encoded string C<s> in characters.
438 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
439 up past C<e>, croaks.
440
441 =cut
442 */
443
444 STRLEN
445 Perl_utf8_length(pTHX_ U8* s, U8* e)
446 {
447     STRLEN len = 0;
448
449     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
450      * the bitops (especially ~) can create illegal UTF-8.
451      * In other words: in Perl UTF-8 is not just for Unicode. */
452
453     if (e < s)
454         Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
455     while (s < e) {
456         U8 t = UTF8SKIP(s);
457
458         if (e - s < t)
459             Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
460         s += t;
461         len++;
462     }
463
464     return len;
465 }
466
467 /*
468 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
469
470 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
471 and C<b>.
472
473 WARNING: use only if you *know* that the pointers point inside the
474 same UTF-8 buffer.
475
476 =cut */
477
478 IV
479 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
480 {
481     IV off = 0;
482
483     /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
484      * the bitops (especially ~) can create illegal UTF-8.
485      * In other words: in Perl UTF-8 is not just for Unicode. */
486
487     if (a < b) {
488         while (a < b) {
489             U8 c = UTF8SKIP(a);
490
491             if (b - a < c)
492                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
493             a += c;
494             off--;
495         }
496     }
497     else {
498         while (b < a) {
499             U8 c = UTF8SKIP(b);
500
501             if (a - b < c)
502                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
503             b += c;
504             off++;
505         }
506     }
507
508     return off;
509 }
510
511 /*
512 =for apidoc A|U8*|utf8_hop|U8 *s|I32 off
513
514 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
515 forward or backward.
516
517 WARNING: do not use the following unless you *know* C<off> is within
518 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
519 on the first byte of character or just after the last byte of a character.
520
521 =cut */
522
523 U8 *
524 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
525 {
526     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
527      * the bitops (especially ~) can create illegal UTF-8.
528      * In other words: in Perl UTF-8 is not just for Unicode. */
529
530     if (off >= 0) {
531         while (off--)
532             s += UTF8SKIP(s);
533     }
534     else {
535         while (off++) {
536             s--;
537             while (UTF8_IS_CONTINUATION(*s))
538                 s--;
539         }
540     }
541     return s;
542 }
543
544 /*
545 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
546
547 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
548 Unlike C<bytes_to_utf8>, this over-writes the original string, and
549 updates len to contain the new length.
550 Returns zero on failure, setting C<len> to -1.
551
552 =cut
553 */
554
555 U8 *
556 Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
557 {
558     U8 *send;
559     U8 *d;
560     U8 *save = s;
561
562     /* ensure valid UTF8 and chars < 256 before updating string */
563     for (send = s + *len; s < send; ) {
564         U8 c = *s++;
565
566         if (c >= 0x80 &&
567             ((s >= send) ||
568              ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
569             *len = -1;
570             return 0;
571         }
572     }
573
574     d = s = save;
575     while (s < send) {
576         STRLEN ulen;
577         *d++ = (U8)utf8_to_uv_simple(s, &ulen);
578         s += ulen;
579     }
580     *d = '\0';
581     *len = d - save;
582     return save;
583 }
584
585 /*
586 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
587
588 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
589 Returns a pointer to the newly-created string, and sets C<len> to
590 reflect the new length.
591
592 =cut
593 */
594
595 U8*
596 Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
597 {
598     U8 *send;
599     U8 *d;
600     U8 *dst;
601     send = s + (*len);
602
603     Newz(801, d, (*len) * 2 + 1, U8);
604     dst = d;
605
606     while (s < send) {
607         if (*s < 0x80)
608             *d++ = *s++;
609         else {
610             UV uv = *s++;
611             *d++ = (( uv >>  6)         | 0xc0);
612             *d++ = (( uv        & 0x3f) | 0x80);
613         }
614     }
615     *d = '\0';
616     *len = d-dst;
617     return dst;
618 }
619
620 /*
621  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
622  *
623  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
624  * We optimize for native, for obvious reasons. */
625
626 U8*
627 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
628 {
629     U8* pend;
630     U8* dstart = d;
631
632     if (bytelen & 1)
633         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
634
635     pend = p + bytelen;
636
637     while (p < pend) {
638         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
639         p += 2;
640         if (uv < 0x80) {
641             *d++ = uv;
642             continue;
643         }
644         if (uv < 0x800) {
645             *d++ = (( uv >>  6)         | 0xc0);
646             *d++ = (( uv        & 0x3f) | 0x80);
647             continue;
648         }
649         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
650             UV low = *p++;
651             if (low < 0xdc00 || low >= 0xdfff)
652                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
653             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
654         }
655         if (uv < 0x10000) {
656             *d++ = (( uv >> 12)         | 0xe0);
657             *d++ = (((uv >>  6) & 0x3f) | 0x80);
658             *d++ = (( uv        & 0x3f) | 0x80);
659             continue;
660         }
661         else {
662             *d++ = (( uv >> 18)         | 0xf0);
663             *d++ = (((uv >> 12) & 0x3f) | 0x80);
664             *d++ = (((uv >>  6) & 0x3f) | 0x80);
665             *d++ = (( uv        & 0x3f) | 0x80);
666             continue;
667         }
668     }
669     *newlen = d - dstart;
670     return d;
671 }
672
673 /* Note: this one is slightly destructive of the source. */
674
675 U8*
676 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
677 {
678     U8* s = (U8*)p;
679     U8* send = s + bytelen;
680     while (s < send) {
681         U8 tmp = s[0];
682         s[0] = s[1];
683         s[1] = tmp;
684         s += 2;
685     }
686     return utf16_to_utf8(p, d, bytelen, newlen);
687 }
688
689 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
690
691 bool
692 Perl_is_uni_alnum(pTHX_ U32 c)
693 {
694     U8 tmpbuf[UTF8_MAXLEN+1];
695     uv_to_utf8(tmpbuf, (UV)c);
696     return is_utf8_alnum(tmpbuf);
697 }
698
699 bool
700 Perl_is_uni_alnumc(pTHX_ U32 c)
701 {
702     U8 tmpbuf[UTF8_MAXLEN+1];
703     uv_to_utf8(tmpbuf, (UV)c);
704     return is_utf8_alnumc(tmpbuf);
705 }
706
707 bool
708 Perl_is_uni_idfirst(pTHX_ U32 c)
709 {
710     U8 tmpbuf[UTF8_MAXLEN+1];
711     uv_to_utf8(tmpbuf, (UV)c);
712     return is_utf8_idfirst(tmpbuf);
713 }
714
715 bool
716 Perl_is_uni_alpha(pTHX_ U32 c)
717 {
718     U8 tmpbuf[UTF8_MAXLEN+1];
719     uv_to_utf8(tmpbuf, (UV)c);
720     return is_utf8_alpha(tmpbuf);
721 }
722
723 bool
724 Perl_is_uni_ascii(pTHX_ U32 c)
725 {
726     U8 tmpbuf[UTF8_MAXLEN+1];
727     uv_to_utf8(tmpbuf, (UV)c);
728     return is_utf8_ascii(tmpbuf);
729 }
730
731 bool
732 Perl_is_uni_space(pTHX_ U32 c)
733 {
734     U8 tmpbuf[UTF8_MAXLEN+1];
735     uv_to_utf8(tmpbuf, (UV)c);
736     return is_utf8_space(tmpbuf);
737 }
738
739 bool
740 Perl_is_uni_digit(pTHX_ U32 c)
741 {
742     U8 tmpbuf[UTF8_MAXLEN+1];
743     uv_to_utf8(tmpbuf, (UV)c);
744     return is_utf8_digit(tmpbuf);
745 }
746
747 bool
748 Perl_is_uni_upper(pTHX_ U32 c)
749 {
750     U8 tmpbuf[UTF8_MAXLEN+1];
751     uv_to_utf8(tmpbuf, (UV)c);
752     return is_utf8_upper(tmpbuf);
753 }
754
755 bool
756 Perl_is_uni_lower(pTHX_ U32 c)
757 {
758     U8 tmpbuf[UTF8_MAXLEN+1];
759     uv_to_utf8(tmpbuf, (UV)c);
760     return is_utf8_lower(tmpbuf);
761 }
762
763 bool
764 Perl_is_uni_cntrl(pTHX_ U32 c)
765 {
766     U8 tmpbuf[UTF8_MAXLEN+1];
767     uv_to_utf8(tmpbuf, (UV)c);
768     return is_utf8_cntrl(tmpbuf);
769 }
770
771 bool
772 Perl_is_uni_graph(pTHX_ U32 c)
773 {
774     U8 tmpbuf[UTF8_MAXLEN+1];
775     uv_to_utf8(tmpbuf, (UV)c);
776     return is_utf8_graph(tmpbuf);
777 }
778
779 bool
780 Perl_is_uni_print(pTHX_ U32 c)
781 {
782     U8 tmpbuf[UTF8_MAXLEN+1];
783     uv_to_utf8(tmpbuf, (UV)c);
784     return is_utf8_print(tmpbuf);
785 }
786
787 bool
788 Perl_is_uni_punct(pTHX_ U32 c)
789 {
790     U8 tmpbuf[UTF8_MAXLEN+1];
791     uv_to_utf8(tmpbuf, (UV)c);
792     return is_utf8_punct(tmpbuf);
793 }
794
795 bool
796 Perl_is_uni_xdigit(pTHX_ U32 c)
797 {
798     U8 tmpbuf[UTF8_MAXLEN+1];
799     uv_to_utf8(tmpbuf, (UV)c);
800     return is_utf8_xdigit(tmpbuf);
801 }
802
803 U32
804 Perl_to_uni_upper(pTHX_ U32 c)
805 {
806     U8 tmpbuf[UTF8_MAXLEN+1];
807     uv_to_utf8(tmpbuf, (UV)c);
808     return to_utf8_upper(tmpbuf);
809 }
810
811 U32
812 Perl_to_uni_title(pTHX_ U32 c)
813 {
814     U8 tmpbuf[UTF8_MAXLEN+1];
815     uv_to_utf8(tmpbuf, (UV)c);
816     return to_utf8_title(tmpbuf);
817 }
818
819 U32
820 Perl_to_uni_lower(pTHX_ U32 c)
821 {
822     U8 tmpbuf[UTF8_MAXLEN+1];
823     uv_to_utf8(tmpbuf, (UV)c);
824     return to_utf8_lower(tmpbuf);
825 }
826
827 /* for now these all assume no locale info available for Unicode > 255 */
828
829 bool
830 Perl_is_uni_alnum_lc(pTHX_ U32 c)
831 {
832     return is_uni_alnum(c);     /* XXX no locale support yet */
833 }
834
835 bool
836 Perl_is_uni_alnumc_lc(pTHX_ U32 c)
837 {
838     return is_uni_alnumc(c);    /* XXX no locale support yet */
839 }
840
841 bool
842 Perl_is_uni_idfirst_lc(pTHX_ U32 c)
843 {
844     return is_uni_idfirst(c);   /* XXX no locale support yet */
845 }
846
847 bool
848 Perl_is_uni_alpha_lc(pTHX_ U32 c)
849 {
850     return is_uni_alpha(c);     /* XXX no locale support yet */
851 }
852
853 bool
854 Perl_is_uni_ascii_lc(pTHX_ U32 c)
855 {
856     return is_uni_ascii(c);     /* XXX no locale support yet */
857 }
858
859 bool
860 Perl_is_uni_space_lc(pTHX_ U32 c)
861 {
862     return is_uni_space(c);     /* XXX no locale support yet */
863 }
864
865 bool
866 Perl_is_uni_digit_lc(pTHX_ U32 c)
867 {
868     return is_uni_digit(c);     /* XXX no locale support yet */
869 }
870
871 bool
872 Perl_is_uni_upper_lc(pTHX_ U32 c)
873 {
874     return is_uni_upper(c);     /* XXX no locale support yet */
875 }
876
877 bool
878 Perl_is_uni_lower_lc(pTHX_ U32 c)
879 {
880     return is_uni_lower(c);     /* XXX no locale support yet */
881 }
882
883 bool
884 Perl_is_uni_cntrl_lc(pTHX_ U32 c)
885 {
886     return is_uni_cntrl(c);     /* XXX no locale support yet */
887 }
888
889 bool
890 Perl_is_uni_graph_lc(pTHX_ U32 c)
891 {
892     return is_uni_graph(c);     /* XXX no locale support yet */
893 }
894
895 bool
896 Perl_is_uni_print_lc(pTHX_ U32 c)
897 {
898     return is_uni_print(c);     /* XXX no locale support yet */
899 }
900
901 bool
902 Perl_is_uni_punct_lc(pTHX_ U32 c)
903 {
904     return is_uni_punct(c);     /* XXX no locale support yet */
905 }
906
907 bool
908 Perl_is_uni_xdigit_lc(pTHX_ U32 c)
909 {
910     return is_uni_xdigit(c);    /* XXX no locale support yet */
911 }
912
913 U32
914 Perl_to_uni_upper_lc(pTHX_ U32 c)
915 {
916     return to_uni_upper(c);     /* XXX no locale support yet */
917 }
918
919 U32
920 Perl_to_uni_title_lc(pTHX_ U32 c)
921 {
922     return to_uni_title(c);     /* XXX no locale support yet */
923 }
924
925 U32
926 Perl_to_uni_lower_lc(pTHX_ U32 c)
927 {
928     return to_uni_lower(c);     /* XXX no locale support yet */
929 }
930
931 bool
932 Perl_is_utf8_alnum(pTHX_ U8 *p)
933 {
934     if (!is_utf8_char(p))
935         return FALSE;
936     if (!PL_utf8_alnum)
937         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
938          * descendant of isalnum(3), in other words, it doesn't
939          * contain the '_'. --jhi */
940         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
941     return swash_fetch(PL_utf8_alnum, p);
942 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
943 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
944     if (!PL_utf8_alnum)
945         PL_utf8_alnum = swash_init("utf8", "",
946             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
947     return swash_fetch(PL_utf8_alnum, p);
948 #endif
949 }
950
951 bool
952 Perl_is_utf8_alnumc(pTHX_ U8 *p)
953 {
954     if (!is_utf8_char(p))
955         return FALSE;
956     if (!PL_utf8_alnum)
957         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
958     return swash_fetch(PL_utf8_alnum, p);
959 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
960 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
961     if (!PL_utf8_alnum)
962         PL_utf8_alnum = swash_init("utf8", "",
963             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
964     return swash_fetch(PL_utf8_alnum, p);
965 #endif
966 }
967
968 bool
969 Perl_is_utf8_idfirst(pTHX_ U8 *p)
970 {
971     return *p == '_' || is_utf8_alpha(p);
972 }
973
974 bool
975 Perl_is_utf8_alpha(pTHX_ U8 *p)
976 {
977     if (!is_utf8_char(p))
978         return FALSE;
979     if (!PL_utf8_alpha)
980         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
981     return swash_fetch(PL_utf8_alpha, p);
982 }
983
984 bool
985 Perl_is_utf8_ascii(pTHX_ U8 *p)
986 {
987     if (!is_utf8_char(p))
988         return FALSE;
989     if (!PL_utf8_ascii)
990         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
991     return swash_fetch(PL_utf8_ascii, p);
992 }
993
994 bool
995 Perl_is_utf8_space(pTHX_ U8 *p)
996 {
997     if (!is_utf8_char(p))
998         return FALSE;
999     if (!PL_utf8_space)
1000         PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1001     return swash_fetch(PL_utf8_space, p);
1002 }
1003
1004 bool
1005 Perl_is_utf8_digit(pTHX_ U8 *p)
1006 {
1007     if (!is_utf8_char(p))
1008         return FALSE;
1009     if (!PL_utf8_digit)
1010         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1011     return swash_fetch(PL_utf8_digit, p);
1012 }
1013
1014 bool
1015 Perl_is_utf8_upper(pTHX_ U8 *p)
1016 {
1017     if (!is_utf8_char(p))
1018         return FALSE;
1019     if (!PL_utf8_upper)
1020         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
1021     return swash_fetch(PL_utf8_upper, p);
1022 }
1023
1024 bool
1025 Perl_is_utf8_lower(pTHX_ U8 *p)
1026 {
1027     if (!is_utf8_char(p))
1028         return FALSE;
1029     if (!PL_utf8_lower)
1030         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
1031     return swash_fetch(PL_utf8_lower, p);
1032 }
1033
1034 bool
1035 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1036 {
1037     if (!is_utf8_char(p))
1038         return FALSE;
1039     if (!PL_utf8_cntrl)
1040         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1041     return swash_fetch(PL_utf8_cntrl, p);
1042 }
1043
1044 bool
1045 Perl_is_utf8_graph(pTHX_ U8 *p)
1046 {
1047     if (!is_utf8_char(p))
1048         return FALSE;
1049     if (!PL_utf8_graph)
1050         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1051     return swash_fetch(PL_utf8_graph, p);
1052 }
1053
1054 bool
1055 Perl_is_utf8_print(pTHX_ U8 *p)
1056 {
1057     if (!is_utf8_char(p))
1058         return FALSE;
1059     if (!PL_utf8_print)
1060         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1061     return swash_fetch(PL_utf8_print, p);
1062 }
1063
1064 bool
1065 Perl_is_utf8_punct(pTHX_ U8 *p)
1066 {
1067     if (!is_utf8_char(p))
1068         return FALSE;
1069     if (!PL_utf8_punct)
1070         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1071     return swash_fetch(PL_utf8_punct, p);
1072 }
1073
1074 bool
1075 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1076 {
1077     if (!is_utf8_char(p))
1078         return FALSE;
1079     if (!PL_utf8_xdigit)
1080         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1081     return swash_fetch(PL_utf8_xdigit, p);
1082 }
1083
1084 bool
1085 Perl_is_utf8_mark(pTHX_ U8 *p)
1086 {
1087     if (!is_utf8_char(p))
1088         return FALSE;
1089     if (!PL_utf8_mark)
1090         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1091     return swash_fetch(PL_utf8_mark, p);
1092 }
1093
1094 UV
1095 Perl_to_utf8_upper(pTHX_ U8 *p)
1096 {
1097     UV uv;
1098
1099     if (!PL_utf8_toupper)
1100         PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
1101     uv = swash_fetch(PL_utf8_toupper, p);
1102     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1103 }
1104
1105 UV
1106 Perl_to_utf8_title(pTHX_ U8 *p)
1107 {
1108     UV uv;
1109
1110     if (!PL_utf8_totitle)
1111         PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
1112     uv = swash_fetch(PL_utf8_totitle, p);
1113     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1114 }
1115
1116 UV
1117 Perl_to_utf8_lower(pTHX_ U8 *p)
1118 {
1119     UV uv;
1120
1121     if (!PL_utf8_tolower)
1122         PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
1123     uv = swash_fetch(PL_utf8_tolower, p);
1124     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1125 }
1126
1127 /* a "swash" is a swatch hash */
1128
1129 SV*
1130 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1131 {
1132     SV* retval;
1133     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1134     dSP;
1135
1136     if (!gv_stashpv(pkg, 0)) {  /* demand load utf8 */
1137         ENTER;
1138         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1139         LEAVE;
1140     }
1141     SPAGAIN;
1142     PUSHSTACKi(PERLSI_MAGIC);
1143     PUSHMARK(SP);
1144     EXTEND(SP,5);
1145     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1146     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1147     PUSHs(listsv);
1148     PUSHs(sv_2mortal(newSViv(minbits)));
1149     PUSHs(sv_2mortal(newSViv(none)));
1150     PUTBACK;
1151     ENTER;
1152     SAVEI32(PL_hints);
1153     PL_hints = 0;
1154     save_re_context();
1155     if (PL_curcop == &PL_compiling)
1156         /* XXX ought to be handled by lex_start */
1157         sv_setpv(tokenbufsv, PL_tokenbuf);
1158     if (call_method("SWASHNEW", G_SCALAR))
1159         retval = newSVsv(*PL_stack_sp--);
1160     else
1161         retval = &PL_sv_undef;
1162     LEAVE;
1163     POPSTACK;
1164     if (PL_curcop == &PL_compiling) {
1165         STRLEN len;
1166         char* pv = SvPV(tokenbufsv, len);
1167
1168         Copy(pv, PL_tokenbuf, len+1, char);
1169         PL_curcop->op_private = PL_hints;
1170     }
1171     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
1172         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1173     return retval;
1174 }
1175
1176 UV
1177 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
1178 {
1179     HV* hv = (HV*)SvRV(sv);
1180     U32 klen = UTF8SKIP(ptr) - 1;
1181     U32 off = ptr[klen] & 127;  /* NB: 64 bit always 0 when len > 1 */
1182     STRLEN slen;
1183     STRLEN needents = (klen ? 64 : 128);
1184     U8 *tmps;
1185     U32 bit;
1186     SV *retval;
1187
1188     /*
1189      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1190      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1191      * it's nothing to sniff at.)  Pity we usually come through at least
1192      * two function calls to get here...
1193      *
1194      * NB: this code assumes that swatches are never modified, once generated!
1195      */
1196
1197     if (hv == PL_last_swash_hv &&
1198         klen == PL_last_swash_klen &&
1199         (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
1200     {
1201         tmps = PL_last_swash_tmps;
1202         slen = PL_last_swash_slen;
1203     }
1204     else {
1205         /* Try our second-level swatch cache, kept in a hash. */
1206         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1207
1208         /* If not cached, generate it via utf8::SWASHGET */
1209         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1210             dSP;
1211             ENTER;
1212             SAVETMPS;
1213             save_re_context();
1214             PUSHSTACKi(PERLSI_MAGIC);
1215             PUSHMARK(SP);
1216             EXTEND(SP,3);
1217             PUSHs((SV*)sv);
1218             PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1))));
1219             PUSHs(sv_2mortal(newSViv(needents)));
1220             PUTBACK;
1221             if (call_method("SWASHGET", G_SCALAR))
1222                 retval = newSVsv(*PL_stack_sp--);
1223             else
1224                 retval = &PL_sv_undef;
1225             POPSTACK;
1226             FREETMPS;
1227             LEAVE;
1228             if (PL_curcop == &PL_compiling)
1229                 PL_curcop->op_private = PL_hints;
1230
1231             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1232
1233             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
1234                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1235         }
1236
1237         PL_last_swash_hv = hv;
1238         PL_last_swash_klen = klen;
1239         PL_last_swash_tmps = tmps;
1240         PL_last_swash_slen = slen;
1241         if (klen)
1242             Copy(ptr, PL_last_swash_key, klen, U8);
1243     }
1244
1245     switch ((int)((slen << 3) / needents)) {
1246     case 1:
1247         bit = 1 << (off & 7);
1248         off >>= 3;
1249         return (tmps[off] & bit) != 0;
1250     case 8:
1251         return tmps[off];
1252     case 16:
1253         off <<= 1;
1254         return (tmps[off] << 8) + tmps[off + 1] ;
1255     case 32:
1256         off <<= 2;
1257         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1258     }
1259     Perl_croak(aTHX_ "panic: swash_fetch");
1260     return 0;
1261 }