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