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