3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
13 * heard of that we don't want to see any closer; and that's the one place
14 * we're trying to get to! And that's just where we can't get, nohow.'
16 * 'Well do I understand your speech,' he answered in the same language;
17 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
18 * as is the custom in the West, if you wish to be answered?'
20 * ...the travellers perceived that the floor was paved with stones of many
21 * hues; branching runes and strange devices intertwined beneath their feet.
25 #define PERL_IN_UTF8_C
28 static char unees[] = "Malformed UTF-8 character (unexpected end of string)";
31 =head1 Unicode Support
33 This file contains various utility functions for manipulating UTF8-encoded
34 strings. For the uninitiated, this is a method of representing arbitrary
35 Unicode characters as a variable number of bytes, in such a way that
36 characters in the ASCII range are unmodified, and a zero byte never appears
37 within non-zero characters.
39 =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
41 Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
42 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
43 bytes available. The return value is the pointer to the byte after the
44 end of the new character. In other words,
46 d = uvuni_to_utf8_flags(d, uv, flags);
50 d = uvuni_to_utf8(d, uv);
52 (which is equivalent to)
54 d = uvuni_to_utf8_flags(d, uv, 0);
56 is the recommended Unicode-aware way of saying
64 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
66 if (ckWARN(WARN_UTF8)) {
67 if (UNICODE_IS_SURROGATE(uv) &&
68 !(flags & UNICODE_ALLOW_SURROGATE))
69 Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
71 ((uv >= 0xFDD0 && uv <= 0xFDEF &&
72 !(flags & UNICODE_ALLOW_FDD0))
74 ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
75 !(flags & UNICODE_ALLOW_FFFF))) &&
76 /* UNICODE_ALLOW_SUPER includes
77 * FFFEs and FFFFs beyond 0x10FFFF. */
78 ((uv <= PERL_UNICODE_MAX) ||
79 !(flags & UNICODE_ALLOW_SUPER))
81 Perl_warner(aTHX_ packWARN(WARN_UTF8),
82 "Unicode character 0x%04"UVxf" is illegal", uv);
84 if (UNI_IS_INVARIANT(uv)) {
85 *d++ = (U8)UTF_TO_NATIVE(uv);
90 STRLEN len = UNISKIP(uv);
93 *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
94 uv >>= UTF_ACCUMULATION_SHIFT;
96 *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
99 #else /* Non loop style */
101 *d++ = (U8)(( uv >> 6) | 0xc0);
102 *d++ = (U8)(( uv & 0x3f) | 0x80);
106 *d++ = (U8)(( uv >> 12) | 0xe0);
107 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
108 *d++ = (U8)(( uv & 0x3f) | 0x80);
112 *d++ = (U8)(( uv >> 18) | 0xf0);
113 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
114 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
115 *d++ = (U8)(( uv & 0x3f) | 0x80);
118 if (uv < 0x4000000) {
119 *d++ = (U8)(( uv >> 24) | 0xf8);
120 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
121 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
122 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
123 *d++ = (U8)(( uv & 0x3f) | 0x80);
126 if (uv < 0x80000000) {
127 *d++ = (U8)(( uv >> 30) | 0xfc);
128 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
129 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
130 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
131 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
132 *d++ = (U8)(( uv & 0x3f) | 0x80);
136 if (uv < UTF8_QUAD_MAX)
139 *d++ = 0xfe; /* Can't match U+FEFF! */
140 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
141 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
142 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
143 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
144 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
145 *d++ = (U8)(( uv & 0x3f) | 0x80);
150 *d++ = 0xff; /* Can't match U+FFFE! */
151 *d++ = 0x80; /* 6 Reserved bits */
152 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
153 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
154 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
155 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
156 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
157 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
158 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
159 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
160 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
161 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
162 *d++ = (U8)(( uv & 0x3f) | 0x80);
166 #endif /* Loop style */
170 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
172 return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
177 =for apidoc A|STRLEN|is_utf8_char|U8 *s
179 Tests if some arbitrary number of bytes begins in a valid UTF-8
180 character. Note that an INVARIANT (i.e. ASCII) character is a valid
181 UTF-8 character. The actual number of bytes in the UTF-8 character
182 will be returned if it is valid, otherwise 0.
186 Perl_is_utf8_char(pTHX_ U8 *s)
192 if (UTF8_IS_INVARIANT(u))
195 if (!UTF8_IS_START(u))
200 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
205 u &= UTF_START_MASK(len);
209 if (!UTF8_IS_CONTINUATION(*s))
211 uv = UTF8_ACCUMULATE(uv, *s);
218 if ((STRLEN)UNISKIP(uv) < len)
225 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
227 Returns true if first C<len> bytes of the given string form a valid
228 UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
229 not mean 'a string that contains code points above 0x7F encoded in UTF-8'
230 because a valid ASCII string is a valid UTF-8 string.
236 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
243 len = strlen((char *)s);
247 /* Inline the easy bits of is_utf8_char() here for speed... */
248 if (UTF8_IS_INVARIANT(*x))
250 else if (!UTF8_IS_START(*x))
253 /* ... and call is_utf8_char() only if really needed. */
267 =for apidoc A|bool|is_utf8_string_loc|U8 *s|STRLEN len|U8 **p
269 Like is_ut8_string but store the location of the failure in
276 Perl_is_utf8_string_loc(pTHX_ U8 *s, STRLEN len, U8 **p)
283 len = strlen((char *)s);
287 /* Inline the easy bits of is_utf8_char() here for speed... */
288 if (UTF8_IS_INVARIANT(*x))
290 else if (!UTF8_IS_START(*x)) {
296 /* ... and call is_utf8_char() only if really needed. */
316 =for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
318 Bottom level UTF-8 decode routine.
319 Returns the unicode code point value of the first character in the string C<s>
320 which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
321 C<retlen> will be set to the length, in bytes, of that character.
323 If C<s> does not point to a well-formed UTF-8 character, the behaviour
324 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
325 it is assumed that the caller will raise a warning, and this function
326 will silently just set C<retlen> to C<-1> and return zero. If the
327 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
328 malformations will be given, C<retlen> will be set to the expected
329 length of the UTF-8 character in bytes, and zero will be returned.
331 The C<flags> can also contain various flags to allow deviations from
332 the strict UTF-8 encoding (see F<utf8.h>).
334 Most code should use utf8_to_uvchr() rather than call this directly.
340 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
345 bool dowarn = ckWARN_d(WARN_UTF8);
347 STRLEN expectlen = 0;
350 /* This list is a superset of the UTF8_ALLOW_XXX. */
352 #define UTF8_WARN_EMPTY 1
353 #define UTF8_WARN_CONTINUATION 2
354 #define UTF8_WARN_NON_CONTINUATION 3
355 #define UTF8_WARN_FE_FF 4
356 #define UTF8_WARN_SHORT 5
357 #define UTF8_WARN_OVERFLOW 6
358 #define UTF8_WARN_SURROGATE 7
359 #define UTF8_WARN_LONG 8
360 #define UTF8_WARN_FFFF 9 /* Also FFFE. */
363 !(flags & UTF8_ALLOW_EMPTY)) {
364 warning = UTF8_WARN_EMPTY;
368 if (UTF8_IS_INVARIANT(uv)) {
371 return (UV) (NATIVE_TO_UTF(*s));
374 if (UTF8_IS_CONTINUATION(uv) &&
375 !(flags & UTF8_ALLOW_CONTINUATION)) {
376 warning = UTF8_WARN_CONTINUATION;
380 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
381 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
382 warning = UTF8_WARN_NON_CONTINUATION;
387 uv = NATIVE_TO_UTF(uv);
389 if ((uv == 0xfe || uv == 0xff) &&
390 !(flags & UTF8_ALLOW_FE_FF)) {
391 warning = UTF8_WARN_FE_FF;
396 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
397 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
398 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
399 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
401 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
402 else { len = 7; uv &= 0x01; }
404 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
405 else if (!(uv & 0x01)) { len = 7; uv = 0; }
406 else { len = 13; uv = 0; } /* whoa! */
414 if ((curlen < expectlen) &&
415 !(flags & UTF8_ALLOW_SHORT)) {
416 warning = UTF8_WARN_SHORT;
425 if (!UTF8_IS_CONTINUATION(*s) &&
426 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
428 warning = UTF8_WARN_NON_CONTINUATION;
432 uv = UTF8_ACCUMULATE(uv, *s);
434 /* These cannot be allowed. */
436 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
437 warning = UTF8_WARN_LONG;
441 else { /* uv < ouv */
442 /* This cannot be allowed. */
443 warning = UTF8_WARN_OVERFLOW;
451 if (UNICODE_IS_SURROGATE(uv) &&
452 !(flags & UTF8_ALLOW_SURROGATE)) {
453 warning = UTF8_WARN_SURROGATE;
455 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
456 !(flags & UTF8_ALLOW_LONG)) {
457 warning = UTF8_WARN_LONG;
459 } else if (UNICODE_IS_ILLEGAL(uv) &&
460 !(flags & UTF8_ALLOW_FFFF)) {
461 warning = UTF8_WARN_FFFF;
469 if (flags & UTF8_CHECK_ONLY) {
476 SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
479 case 0: /* Intentionally empty. */ break;
480 case UTF8_WARN_EMPTY:
481 Perl_sv_catpv(aTHX_ sv, "(empty string)");
483 case UTF8_WARN_CONTINUATION:
484 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
486 case UTF8_WARN_NON_CONTINUATION:
488 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
489 (UV)s[1], startbyte);
491 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
492 (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
495 case UTF8_WARN_FE_FF:
496 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
498 case UTF8_WARN_SHORT:
499 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
500 curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
501 expectlen = curlen; /* distance for caller to skip */
503 case UTF8_WARN_OVERFLOW:
504 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
507 case UTF8_WARN_SURROGATE:
508 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
511 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
512 expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
515 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
518 Perl_sv_catpv(aTHX_ sv, "(unknown reason)");
526 Perl_warner(aTHX_ packWARN(WARN_UTF8),
527 "%s in %s", s, OP_DESC(PL_op));
529 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
534 *retlen = expectlen ? expectlen : len;
540 =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
542 Returns the native character value of the first character in the string C<s>
543 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
544 length, in bytes, of that character.
546 If C<s> does not point to a well-formed UTF-8 character, zero is
547 returned and retlen is set, if possible, to -1.
553 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
555 return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXBYTES, retlen,
556 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
560 =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
562 Returns the Unicode code point of the first character in the string C<s>
563 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
564 length, in bytes, of that character.
566 This function should only be used when returned UV is considered
567 an index into the Unicode semantic tables (e.g. swashes).
569 If C<s> does not point to a well-formed UTF-8 character, zero is
570 returned and retlen is set, if possible, to -1.
576 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
578 /* Call the low level routine asking for checks */
579 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
580 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
584 =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
586 Return the length of the UTF-8 char encoded string C<s> in characters.
587 Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
588 up past C<e>, croaks.
594 Perl_utf8_length(pTHX_ U8 *s, U8 *e)
598 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
599 * the bitops (especially ~) can create illegal UTF-8.
600 * In other words: in Perl UTF-8 is not just for Unicode. */
603 if (ckWARN_d(WARN_UTF8)) {
605 Perl_warner(aTHX_ packWARN(WARN_UTF8),
606 "%s in %s", unees, OP_DESC(PL_op));
608 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
616 if (ckWARN_d(WARN_UTF8)) {
618 Perl_warner(aTHX_ packWARN(WARN_UTF8),
619 unees, OP_DESC(PL_op));
621 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
633 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
635 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
638 WARNING: use only if you *know* that the pointers point inside the
645 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
649 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
650 * the bitops (especially ~) can create illegal UTF-8.
651 * In other words: in Perl UTF-8 is not just for Unicode. */
658 if (ckWARN_d(WARN_UTF8)) {
660 Perl_warner(aTHX_ packWARN(WARN_UTF8),
661 "%s in %s", unees, OP_DESC(PL_op));
663 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
676 if (ckWARN_d(WARN_UTF8)) {
678 Perl_warner(aTHX_ packWARN(WARN_UTF8),
679 "%s in %s", unees, OP_DESC(PL_op));
681 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
694 =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
696 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
699 WARNING: do not use the following unless you *know* C<off> is within
700 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
701 on the first byte of character or just after the last byte of a character.
707 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
709 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
710 * the bitops (especially ~) can create illegal UTF-8.
711 * In other words: in Perl UTF-8 is not just for Unicode. */
720 while (UTF8_IS_CONTINUATION(*s))
728 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
730 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
731 Unlike C<bytes_to_utf8>, this over-writes the original string, and
732 updates len to contain the new length.
733 Returns zero on failure, setting C<len> to -1.
739 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
745 /* ensure valid UTF-8 and chars < 256 before updating string */
746 for (send = s + *len; s < send; ) {
749 if (!UTF8_IS_INVARIANT(c) &&
750 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
751 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
760 *d++ = (U8)utf8_to_uvchr(s, &ulen);
769 =for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
771 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
772 Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
773 the newly-created string, and updates C<len> to contain the new
774 length. Returns the original string if no conversion occurs, C<len>
775 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
776 0 if C<s> is converted or contains all 7bit characters.
782 Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
792 /* ensure valid UTF-8 and chars < 256 before converting string */
793 for (send = s + *len; s < send;) {
795 if (!UTF8_IS_INVARIANT(c)) {
796 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
797 (c = *s++) && UTF8_IS_CONTINUATION(c))
806 Newz(801, d, (*len) - count + 1, U8);
807 s = start; start = d;
810 if (!UTF8_IS_INVARIANT(c)) {
811 /* Then it is two-byte encoded */
812 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
813 c = ASCII_TO_NATIVE(c);
823 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
825 Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
826 Returns a pointer to the newly-created string, and sets C<len> to
827 reflect the new length.
829 If you want to convert to UTF-8 from other encodings than ASCII,
830 see sv_recode_to_utf8().
836 Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
843 Newz(801, d, (*len) * 2 + 1, U8);
847 UV uv = NATIVE_TO_ASCII(*s++);
848 if (UNI_IS_INVARIANT(uv))
849 *d++ = (U8)UTF_TO_NATIVE(uv);
851 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
852 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
861 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
863 * Destination must be pre-extended to 3/2 source. Do not use in-place.
864 * We optimize for native, for obvious reasons. */
867 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
872 if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
879 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVf, (UV)bytelen);
884 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
891 *d++ = (U8)(( uv >> 6) | 0xc0);
892 *d++ = (U8)(( uv & 0x3f) | 0x80);
895 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
896 UV low = (p[0] << 8) + p[1];
898 if (low < 0xdc00 || low >= 0xdfff)
899 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
900 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
903 *d++ = (U8)(( uv >> 12) | 0xe0);
904 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
905 *d++ = (U8)(( uv & 0x3f) | 0x80);
909 *d++ = (U8)(( uv >> 18) | 0xf0);
910 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
911 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
912 *d++ = (U8)(( uv & 0x3f) | 0x80);
916 *newlen = d - dstart;
920 /* Note: this one is slightly destructive of the source. */
923 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
926 U8* send = s + bytelen;
933 return utf16_to_utf8(p, d, bytelen, newlen);
936 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
939 Perl_is_uni_alnum(pTHX_ UV c)
941 U8 tmpbuf[UTF8_MAXBYTES+1];
942 uvchr_to_utf8(tmpbuf, c);
943 return is_utf8_alnum(tmpbuf);
947 Perl_is_uni_alnumc(pTHX_ UV c)
949 U8 tmpbuf[UTF8_MAXBYTES+1];
950 uvchr_to_utf8(tmpbuf, c);
951 return is_utf8_alnumc(tmpbuf);
955 Perl_is_uni_idfirst(pTHX_ UV c)
957 U8 tmpbuf[UTF8_MAXBYTES+1];
958 uvchr_to_utf8(tmpbuf, c);
959 return is_utf8_idfirst(tmpbuf);
963 Perl_is_uni_alpha(pTHX_ UV c)
965 U8 tmpbuf[UTF8_MAXBYTES+1];
966 uvchr_to_utf8(tmpbuf, c);
967 return is_utf8_alpha(tmpbuf);
971 Perl_is_uni_ascii(pTHX_ UV c)
973 U8 tmpbuf[UTF8_MAXBYTES+1];
974 uvchr_to_utf8(tmpbuf, c);
975 return is_utf8_ascii(tmpbuf);
979 Perl_is_uni_space(pTHX_ UV c)
981 U8 tmpbuf[UTF8_MAXBYTES+1];
982 uvchr_to_utf8(tmpbuf, c);
983 return is_utf8_space(tmpbuf);
987 Perl_is_uni_digit(pTHX_ UV c)
989 U8 tmpbuf[UTF8_MAXBYTES+1];
990 uvchr_to_utf8(tmpbuf, c);
991 return is_utf8_digit(tmpbuf);
995 Perl_is_uni_upper(pTHX_ UV c)
997 U8 tmpbuf[UTF8_MAXBYTES+1];
998 uvchr_to_utf8(tmpbuf, c);
999 return is_utf8_upper(tmpbuf);
1003 Perl_is_uni_lower(pTHX_ UV c)
1005 U8 tmpbuf[UTF8_MAXBYTES+1];
1006 uvchr_to_utf8(tmpbuf, c);
1007 return is_utf8_lower(tmpbuf);
1011 Perl_is_uni_cntrl(pTHX_ UV c)
1013 U8 tmpbuf[UTF8_MAXBYTES+1];
1014 uvchr_to_utf8(tmpbuf, c);
1015 return is_utf8_cntrl(tmpbuf);
1019 Perl_is_uni_graph(pTHX_ UV c)
1021 U8 tmpbuf[UTF8_MAXBYTES+1];
1022 uvchr_to_utf8(tmpbuf, c);
1023 return is_utf8_graph(tmpbuf);
1027 Perl_is_uni_print(pTHX_ UV c)
1029 U8 tmpbuf[UTF8_MAXBYTES+1];
1030 uvchr_to_utf8(tmpbuf, c);
1031 return is_utf8_print(tmpbuf);
1035 Perl_is_uni_punct(pTHX_ UV c)
1037 U8 tmpbuf[UTF8_MAXBYTES+1];
1038 uvchr_to_utf8(tmpbuf, c);
1039 return is_utf8_punct(tmpbuf);
1043 Perl_is_uni_xdigit(pTHX_ UV c)
1045 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1046 uvchr_to_utf8(tmpbuf, c);
1047 return is_utf8_xdigit(tmpbuf);
1051 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1053 uvchr_to_utf8(p, c);
1054 return to_utf8_upper(p, p, lenp);
1058 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1060 uvchr_to_utf8(p, c);
1061 return to_utf8_title(p, p, lenp);
1065 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1067 uvchr_to_utf8(p, c);
1068 return to_utf8_lower(p, p, lenp);
1072 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1074 uvchr_to_utf8(p, c);
1075 return to_utf8_fold(p, p, lenp);
1078 /* for now these all assume no locale info available for Unicode > 255 */
1081 Perl_is_uni_alnum_lc(pTHX_ UV c)
1083 return is_uni_alnum(c); /* XXX no locale support yet */
1087 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1089 return is_uni_alnumc(c); /* XXX no locale support yet */
1093 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1095 return is_uni_idfirst(c); /* XXX no locale support yet */
1099 Perl_is_uni_alpha_lc(pTHX_ UV c)
1101 return is_uni_alpha(c); /* XXX no locale support yet */
1105 Perl_is_uni_ascii_lc(pTHX_ UV c)
1107 return is_uni_ascii(c); /* XXX no locale support yet */
1111 Perl_is_uni_space_lc(pTHX_ UV c)
1113 return is_uni_space(c); /* XXX no locale support yet */
1117 Perl_is_uni_digit_lc(pTHX_ UV c)
1119 return is_uni_digit(c); /* XXX no locale support yet */
1123 Perl_is_uni_upper_lc(pTHX_ UV c)
1125 return is_uni_upper(c); /* XXX no locale support yet */
1129 Perl_is_uni_lower_lc(pTHX_ UV c)
1131 return is_uni_lower(c); /* XXX no locale support yet */
1135 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1137 return is_uni_cntrl(c); /* XXX no locale support yet */
1141 Perl_is_uni_graph_lc(pTHX_ UV c)
1143 return is_uni_graph(c); /* XXX no locale support yet */
1147 Perl_is_uni_print_lc(pTHX_ UV c)
1149 return is_uni_print(c); /* XXX no locale support yet */
1153 Perl_is_uni_punct_lc(pTHX_ UV c)
1155 return is_uni_punct(c); /* XXX no locale support yet */
1159 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1161 return is_uni_xdigit(c); /* XXX no locale support yet */
1165 Perl_to_uni_upper_lc(pTHX_ U32 c)
1167 /* XXX returns only the first character -- do not use XXX */
1168 /* XXX no locale support yet */
1170 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1171 return (U32)to_uni_upper(c, tmpbuf, &len);
1175 Perl_to_uni_title_lc(pTHX_ U32 c)
1177 /* XXX returns only the first character XXX -- do not use XXX */
1178 /* XXX no locale support yet */
1180 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1181 return (U32)to_uni_title(c, tmpbuf, &len);
1185 Perl_to_uni_lower_lc(pTHX_ U32 c)
1187 /* XXX returns only the first character -- do not use XXX */
1188 /* XXX no locale support yet */
1190 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1191 return (U32)to_uni_lower(c, tmpbuf, &len);
1195 Perl_is_utf8_alnum(pTHX_ U8 *p)
1197 if (!is_utf8_char(p))
1200 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1201 * descendant of isalnum(3), in other words, it doesn't
1202 * contain the '_'. --jhi */
1203 PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
1204 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1205 /* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1206 #ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1208 PL_utf8_alnum = swash_init("utf8", "",
1209 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1210 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1215 Perl_is_utf8_alnumc(pTHX_ U8 *p)
1217 if (!is_utf8_char(p))
1220 PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1221 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1222 /* return is_utf8_alpha(p) || is_utf8_digit(p); */
1223 #ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1225 PL_utf8_alnum = swash_init("utf8", "",
1226 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1227 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1232 Perl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
1236 if (!is_utf8_char(p))
1238 if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */
1239 PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0);
1240 return swash_fetch(PL_utf8_idstart, p, TRUE) != 0;
1244 Perl_is_utf8_idcont(pTHX_ U8 *p)
1248 if (!is_utf8_char(p))
1250 if (!PL_utf8_idcont)
1251 PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0);
1252 return swash_fetch(PL_utf8_idcont, p, TRUE) != 0;
1256 Perl_is_utf8_alpha(pTHX_ U8 *p)
1258 if (!is_utf8_char(p))
1261 PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
1262 return swash_fetch(PL_utf8_alpha, p, TRUE) != 0;
1266 Perl_is_utf8_ascii(pTHX_ U8 *p)
1268 if (!is_utf8_char(p))
1271 PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1272 return swash_fetch(PL_utf8_ascii, p, TRUE) != 0;
1276 Perl_is_utf8_space(pTHX_ U8 *p)
1278 if (!is_utf8_char(p))
1281 PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1282 return swash_fetch(PL_utf8_space, p, TRUE) != 0;
1286 Perl_is_utf8_digit(pTHX_ U8 *p)
1288 if (!is_utf8_char(p))
1291 PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1292 return swash_fetch(PL_utf8_digit, p, TRUE) != 0;
1296 Perl_is_utf8_upper(pTHX_ U8 *p)
1298 if (!is_utf8_char(p))
1301 PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0);
1302 return swash_fetch(PL_utf8_upper, p, TRUE) != 0;
1306 Perl_is_utf8_lower(pTHX_ U8 *p)
1308 if (!is_utf8_char(p))
1311 PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0);
1312 return swash_fetch(PL_utf8_lower, p, TRUE) != 0;
1316 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1318 if (!is_utf8_char(p))
1321 PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1322 return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0;
1326 Perl_is_utf8_graph(pTHX_ U8 *p)
1328 if (!is_utf8_char(p))
1331 PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1332 return swash_fetch(PL_utf8_graph, p, TRUE) != 0;
1336 Perl_is_utf8_print(pTHX_ U8 *p)
1338 if (!is_utf8_char(p))
1341 PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1342 return swash_fetch(PL_utf8_print, p, TRUE) != 0;
1346 Perl_is_utf8_punct(pTHX_ U8 *p)
1348 if (!is_utf8_char(p))
1351 PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1352 return swash_fetch(PL_utf8_punct, p, TRUE) != 0;
1356 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1358 if (!is_utf8_char(p))
1360 if (!PL_utf8_xdigit)
1361 PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1362 return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0;
1366 Perl_is_utf8_mark(pTHX_ U8 *p)
1368 if (!is_utf8_char(p))
1371 PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1372 return swash_fetch(PL_utf8_mark, p, TRUE) != 0;
1376 =for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1378 The "p" contains the pointer to the UTF-8 string encoding
1379 the character that is being converted.
1381 The "ustrp" is a pointer to the character buffer to put the
1382 conversion result to. The "lenp" is a pointer to the length
1385 The "swashp" is a pointer to the swash to use.
1387 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1388 and loaded by SWASHGET, using lib/utf8_heavy.pl. The special (usually,
1389 but not always, a multicharacter mapping), is tried first.
1391 The "special" is a string like "utf8::ToSpecLower", which means the
1392 hash %utf8::ToSpecLower. The access to the hash is through
1393 Perl_to_utf8_case().
1395 The "normal" is a string like "ToLower" which means the swash
1401 Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
1404 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1407 uv0 = utf8_to_uvchr(p, 0);
1408 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1409 * are necessary in EBCDIC, they are redundant no-ops
1410 * in ASCII-ish platforms, and hopefully optimized away. */
1411 uv1 = NATIVE_TO_UNI(uv0);
1412 uvuni_to_utf8(tmpbuf, uv1);
1414 if (!*swashp) /* load on-demand */
1415 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1417 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1418 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1419 /* It might be "special" (sometimes, but not always,
1420 * a multicharacter mapping) */
1424 if ((hv = get_hv(special, FALSE)) &&
1425 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1429 s = SvPV(*svp, len);
1431 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1434 /* If we have EBCDIC we need to remap the characters
1435 * since any characters in the low 256 are Unicode
1436 * code points, not EBCDIC. */
1437 U8 *t = (U8*)s, *tend = t + len, *d;
1444 UV c = utf8_to_uvchr(t, &tlen);
1446 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1455 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1460 Copy(tmpbuf, ustrp, len, U8);
1462 Copy(s, ustrp, len, U8);
1468 if (!len && *swashp) {
1469 UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1472 /* It was "normal" (a single character mapping). */
1473 UV uv3 = UNI_TO_NATIVE(uv2);
1475 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1479 if (!len) /* Neither: just copy. */
1480 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1485 return len ? utf8_to_uvchr(ustrp, 0) : 0;
1489 =for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1491 Convert the UTF-8 encoded character at p to its uppercase version and
1492 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1493 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1494 the uppercase version may be longer than the original character.
1496 The first character of the uppercased version is returned
1497 (but note, as explained above, that there may be more.)
1502 Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1504 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1505 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1509 =for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1511 Convert the UTF-8 encoded character at p to its titlecase version and
1512 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1513 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1514 titlecase version may be longer than the original character.
1516 The first character of the titlecased version is returned
1517 (but note, as explained above, that there may be more.)
1522 Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1524 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1525 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1529 =for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1531 Convert the UTF-8 encoded character at p to its lowercase version and
1532 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1533 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1534 lowercase version may be longer than the original character.
1536 The first character of the lowercased version is returned
1537 (but note, as explained above, that there may be more.)
1542 Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1544 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1545 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1549 =for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1551 Convert the UTF-8 encoded character at p to its foldcase version and
1552 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1553 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1554 foldcase version may be longer than the original character (up to
1557 The first character of the foldcased version is returned
1558 (but note, as explained above, that there may be more.)
1563 Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1565 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1566 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1569 /* a "swash" is a swatch hash */
1572 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1575 SV* tokenbufsv = sv_newmortal();
1577 size_t pkg_len = strlen(pkg);
1578 size_t name_len = strlen(name);
1579 HV *stash = gv_stashpvn(pkg, pkg_len, FALSE);
1582 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
1584 errsv_save = newSVsv(ERRSV);
1585 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1588 sv_setsv(ERRSV, errsv_save);
1589 SvREFCNT_dec(errsv_save);
1593 PUSHSTACKi(PERLSI_MAGIC);
1596 PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
1597 PUSHs(sv_2mortal(newSVpvn(name, name_len)));
1599 PUSHs(sv_2mortal(newSViv(minbits)));
1600 PUSHs(sv_2mortal(newSViv(none)));
1606 if (IN_PERL_COMPILETIME) {
1607 /* XXX ought to be handled by lex_start */
1610 sv_setpv(tokenbufsv, PL_tokenbuf);
1612 errsv_save = newSVsv(ERRSV);
1613 if (call_method("SWASHNEW", G_SCALAR))
1614 retval = newSVsv(*PL_stack_sp--);
1616 retval = &PL_sv_undef;
1618 sv_setsv(ERRSV, errsv_save);
1619 SvREFCNT_dec(errsv_save);
1622 if (IN_PERL_COMPILETIME) {
1624 char* pv = SvPV(tokenbufsv, len);
1626 Copy(pv, PL_tokenbuf, len+1, char);
1627 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1629 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1631 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1633 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1639 /* This API is wrong for special case conversions since we may need to
1640 * return several Unicode characters for a single Unicode character
1641 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1642 * the lower-level routine, and it is similarly broken for returning
1643 * multiple values. --jhi */
1645 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
1647 HV* hv = (HV*)SvRV(sv);
1656 UV c = NATIVE_TO_ASCII(*ptr);
1658 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1659 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1660 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1663 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1664 * then the "swatch" is a vec() for al the chars which start
1666 * So the key in the hash (klen) is length of encoded char -1
1668 klen = UTF8SKIP(ptr) - 1;
1673 /* If char in invariant then swatch is for all the invariant chars
1674 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1676 needents = UTF_CONTINUATION_MARK;
1677 off = NATIVE_TO_UTF(ptr[klen]);
1681 /* If char is encoded then swatch is for the prefix */
1682 needents = (1 << UTF_ACCUMULATION_SHIFT);
1683 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1687 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1688 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1689 * it's nothing to sniff at.) Pity we usually come through at least
1690 * two function calls to get here...
1692 * NB: this code assumes that swatches are never modified, once generated!
1695 if (hv == PL_last_swash_hv &&
1696 klen == PL_last_swash_klen &&
1697 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1699 tmps = PL_last_swash_tmps;
1700 slen = PL_last_swash_slen;
1703 /* Try our second-level swatch cache, kept in a hash. */
1704 SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1706 /* If not cached, generate it via utf8::SWASHGET */
1707 if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1709 /* We use utf8n_to_uvuni() as we want an index into
1710 Unicode tables, not a native character number.
1712 UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
1714 0 : UTF8_ALLOW_ANY);
1719 PUSHSTACKi(PERLSI_MAGIC);
1723 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1724 PUSHs(sv_2mortal(newSViv((klen) ?
1725 (code_point & ~(needents - 1)) : 0)));
1726 PUSHs(sv_2mortal(newSViv(needents)));
1728 errsv_save = newSVsv(ERRSV);
1729 if (call_method("SWASHGET", G_SCALAR))
1730 retval = newSVsv(*PL_stack_sp--);
1732 retval = &PL_sv_undef;
1734 sv_setsv(ERRSV, errsv_save);
1735 SvREFCNT_dec(errsv_save);
1739 if (IN_PERL_COMPILETIME)
1740 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1742 svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1744 if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
1745 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1748 PL_last_swash_hv = hv;
1749 PL_last_swash_klen = klen;
1750 PL_last_swash_tmps = tmps;
1751 PL_last_swash_slen = slen;
1753 Copy(ptr, PL_last_swash_key, klen, U8);
1756 switch ((int)((slen << 3) / needents)) {
1758 bit = 1 << (off & 7);
1760 return (tmps[off] & bit) != 0;
1765 return (tmps[off] << 8) + tmps[off + 1] ;
1768 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1770 Perl_croak(aTHX_ "panic: swash_fetch");
1776 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
1778 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
1779 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
1780 bytes available. The return value is the pointer to the byte after the
1781 end of the new character. In other words,
1783 d = uvchr_to_utf8(d, uv);
1785 is the recommended wide native character-aware way of saying
1792 /* On ASCII machines this is normally a macro but we want a
1793 real function in case XS code wants it
1795 #undef Perl_uvchr_to_utf8
1797 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1799 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
1803 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1805 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1809 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1811 Returns the native character value of the first character in the string C<s>
1812 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1813 length, in bytes, of that character.
1815 Allows length and flags to be passed to low level routine.
1819 /* On ASCII machines this is normally a macro but we want
1820 a real function in case XS code wants it
1822 #undef Perl_utf8n_to_uvchr
1824 Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1826 UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1827 return UNI_TO_NATIVE(uv);
1831 =for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1833 Build to the scalar dsv a displayable version of the string spv,
1834 length len, the displayable version being at most pvlim bytes long
1835 (if longer, the rest is truncated and "..." will be appended).
1837 The flags argument can have UNI_DISPLAY_ISPRINT set to display
1838 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
1839 to display the \\[nrfta\\] as the backslashed versions (like '\n')
1840 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1841 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1842 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1844 The pointer to the PV of the dsv is returned.
1848 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1853 sv_setpvn(dsv, "", 0);
1854 for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1856 /* This serves double duty as a flag and a character to print after
1857 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
1861 if (pvlim && SvCUR(dsv) >= pvlim) {
1865 u = utf8_to_uvchr((U8*)s, 0);
1867 unsigned char c = u & 0xFF;
1868 if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1885 Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok);
1888 /* isPRINT() is the locale-blind version. */
1889 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
1890 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
1895 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1898 sv_catpvn(dsv, "...", 3);
1904 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1906 Build to the scalar dsv a displayable version of the scalar sv,
1907 the displayable version being at most pvlim bytes long
1908 (if longer, the rest is truncated and "..." will be appended).
1910 The flags argument is as in pv_uni_display().
1912 The pointer to the PV of the dsv is returned.
1916 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1918 return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1923 =for apidoc A|I32|ibcmp_utf8|const char *s1|char **pe1|register UV l1|bool u1|const char *s2|char **pe2|register UV l2|bool u2
1925 Return true if the strings s1 and s2 differ case-insensitively, false
1926 if not (if they are equal case-insensitively). If u1 is true, the
1927 string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
1928 the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
1929 are false, the respective string is assumed to be in native 8-bit
1932 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1933 in there (they will point at the beginning of the I<next> character).
1934 If the pointers behind pe1 or pe2 are non-NULL, they are the end
1935 pointers beyond which scanning will not continue under any
1936 circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
1937 s2+l2 will be used as goal end pointers that will also stop the scan,
1938 and which qualify towards defining a successful match: all the scans
1939 that define an explicit length must reach their goal pointers for
1940 a match to succeed).
1942 For case-insensitiveness, the "casefolding" of Unicode is used
1943 instead of upper/lowercasing both the characters, see
1944 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1948 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
1950 register U8 *p1 = (U8*)s1;
1951 register U8 *p2 = (U8*)s2;
1952 register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1953 register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1954 STRLEN n1 = 0, n2 = 0;
1955 U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
1956 U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
1958 STRLEN foldlen1, foldlen2;
1963 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
1967 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
1970 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1971 return 1; /* mismatch; possible infinite loop or false positive */
1974 natbuf[1] = 0; /* Need to terminate the buffer. */
1976 while ((e1 == 0 || p1 < e1) &&
1977 (f1 == 0 || p1 < f1) &&
1978 (e2 == 0 || p2 < e2) &&
1979 (f2 == 0 || p2 < f2)) {
1982 to_utf8_fold(p1, foldbuf1, &foldlen1);
1985 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1992 to_utf8_fold(p2, foldbuf2, &foldlen2);
1995 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2001 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2002 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2003 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
2004 return 1; /* mismatch */
2011 p1 += u1 ? UTF8SKIP(p1) : 1;
2013 p2 += u2 ? UTF8SKIP(p2) : 1;
2017 /* A match is defined by all the scans that specified
2018 * an explicit length reaching their final goals. */
2019 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
2028 return match ? 0 : 1; /* 0 match, 1 mismatch */
2033 * c-indentation-style: bsd
2035 * indent-tabs-mode: t
2038 * vim: shiftwidth=4: