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