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