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