3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4 * by Larry Wall and others
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
29 /* Separate prototypes needed because in ASCII systems these
30 * usually macros but they still are compiled as code, too. */
31 PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
32 PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
35 static const char unees[] =
36 "Malformed UTF-8 character (unexpected end of string)";
39 =head1 Unicode Support
41 This file contains various utility functions for manipulating UTF8-encoded
42 strings. For the uninitiated, this is a method of representing arbitrary
43 Unicode characters as a variable number of bytes, in such a way that
44 characters in the ASCII range are unmodified, and a zero byte never appears
45 within non-zero characters.
47 =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
49 Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
50 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
51 bytes available. The return value is the pointer to the byte after the
52 end of the new character. In other words,
54 d = uvuni_to_utf8_flags(d, uv, flags);
58 d = uvuni_to_utf8(d, uv);
60 (which is equivalent to)
62 d = uvuni_to_utf8_flags(d, uv, 0);
64 is the recommended Unicode-aware way of saying
72 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
74 if (ckWARN(WARN_UTF8)) {
75 if (UNICODE_IS_SURROGATE(uv) &&
76 !(flags & UNICODE_ALLOW_SURROGATE))
77 Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
79 ((uv >= 0xFDD0 && uv <= 0xFDEF &&
80 !(flags & UNICODE_ALLOW_FDD0))
82 ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
83 !(flags & UNICODE_ALLOW_FFFF))) &&
84 /* UNICODE_ALLOW_SUPER includes
85 * FFFEs and FFFFs beyond 0x10FFFF. */
86 ((uv <= PERL_UNICODE_MAX) ||
87 !(flags & UNICODE_ALLOW_SUPER))
89 Perl_warner(aTHX_ packWARN(WARN_UTF8),
90 "Unicode character 0x%04"UVxf" is illegal", uv);
92 if (UNI_IS_INVARIANT(uv)) {
93 *d++ = (U8)UTF_TO_NATIVE(uv);
98 STRLEN len = UNISKIP(uv);
101 *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
102 uv >>= UTF_ACCUMULATION_SHIFT;
104 *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
107 #else /* Non loop style */
109 *d++ = (U8)(( uv >> 6) | 0xc0);
110 *d++ = (U8)(( uv & 0x3f) | 0x80);
114 *d++ = (U8)(( uv >> 12) | 0xe0);
115 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
116 *d++ = (U8)(( uv & 0x3f) | 0x80);
120 *d++ = (U8)(( uv >> 18) | 0xf0);
121 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
122 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
123 *d++ = (U8)(( uv & 0x3f) | 0x80);
126 if (uv < 0x4000000) {
127 *d++ = (U8)(( uv >> 24) | 0xf8);
128 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
129 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
130 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
131 *d++ = (U8)(( uv & 0x3f) | 0x80);
134 if (uv < 0x80000000) {
135 *d++ = (U8)(( uv >> 30) | 0xfc);
136 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
137 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
138 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
139 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
140 *d++ = (U8)(( uv & 0x3f) | 0x80);
144 if (uv < UTF8_QUAD_MAX)
147 *d++ = 0xfe; /* Can't match U+FEFF! */
148 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
149 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
150 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
151 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
152 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
153 *d++ = (U8)(( uv & 0x3f) | 0x80);
158 *d++ = 0xff; /* Can't match U+FFFE! */
159 *d++ = 0x80; /* 6 Reserved bits */
160 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
161 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
162 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
163 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
164 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
165 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
166 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
167 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
168 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
169 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
170 *d++ = (U8)(( uv & 0x3f) | 0x80);
174 #endif /* Loop style */
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.
184 This is the "slow" version as opposed to the "fast" version which is
185 the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed
186 difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four
187 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
188 you should use the _slow(). In practice this means that the _slow()
189 will be used very rarely, since the maximum Unicode code point (as of
190 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
191 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
196 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
202 if (UTF8_IS_INVARIANT(u))
205 if (!UTF8_IS_START(u))
208 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
214 u = NATIVE_TO_UTF(u);
216 u &= UTF_START_MASK(len);
220 if (!UTF8_IS_CONTINUATION(*s))
222 uv = UTF8_ACCUMULATE(uv, *s);
229 if ((STRLEN)UNISKIP(uv) < len)
236 =for apidoc A|STRLEN|is_utf8_char|U8 *s
238 Tests if some arbitrary number of bytes begins in a valid UTF-8
239 character. Note that an INVARIANT (i.e. ASCII) character is a valid
240 UTF-8 character. The actual number of bytes in the UTF-8 character
241 will be returned if it is valid, otherwise 0.
245 Perl_is_utf8_char(pTHX_ U8 *s)
247 const STRLEN len = UTF8SKIP(s);
250 if (IS_UTF8_CHAR_FAST(len))
251 return IS_UTF8_CHAR(s, len) ? len : 0;
252 #endif /* #ifdef IS_UTF8_CHAR */
253 return is_utf8_char_slow(s, len);
257 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
259 Returns true if first C<len> bytes of the given string form a valid
260 UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
261 not mean 'a string that contains code points above 0x7F encoded in UTF-8'
262 because a valid ASCII string is a valid UTF-8 string.
264 See also is_utf8_string_loclen() and is_utf8_string_loc().
270 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
272 const U8* const send = s + (len ? len : strlen((const char *)s));
279 /* Inline the easy bits of is_utf8_char() here for speed... */
280 if (UTF8_IS_INVARIANT(*x))
282 else if (!UTF8_IS_START(*x))
285 /* ... and call is_utf8_char() only if really needed. */
288 if (IS_UTF8_CHAR_FAST(c)) {
289 if (!IS_UTF8_CHAR(x, c))
293 c = is_utf8_char_slow(x, c);
296 #endif /* #ifdef IS_UTF8_CHAR */
311 Implemented as a macro in utf8.h
313 =for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **ep
315 Like is_utf8_string() but stores the location of the failure (in the
316 case of "utf8ness failure") or the location s+len (in the case of
317 "utf8ness success") in the C<ep>.
319 See also is_utf8_string_loclen() and is_utf8_string().
321 =for apidoc A|bool|is_utf8_string_loclen|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el
323 Like is_utf8_string() but stores the location of the failure (in the
324 case of "utf8ness failure") or the location s+len (in the case of
325 "utf8ness success") in the C<ep>, and the number of UTF-8
326 encoded characters in the C<el>.
328 See also is_utf8_string_loc() and is_utf8_string().
334 Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
336 const U8* const send = s + (len ? len : strlen((const char *)s));
343 /* Inline the easy bits of is_utf8_char() here for speed... */
344 if (UTF8_IS_INVARIANT(*x))
346 else if (!UTF8_IS_START(*x))
349 /* ... and call is_utf8_char() only if really needed. */
352 if (IS_UTF8_CHAR_FAST(c)) {
353 if (!IS_UTF8_CHAR(x, c))
356 c = is_utf8_char_slow(x, c);
359 #endif /* #ifdef IS_UTF8_CHAR */
378 =for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
380 Bottom level UTF-8 decode routine.
381 Returns the unicode code point value of the first character in the string C<s>
382 which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
383 C<retlen> will be set to the length, in bytes, of that character.
385 If C<s> does not point to a well-formed UTF-8 character, the behaviour
386 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
387 it is assumed that the caller will raise a warning, and this function
388 will silently just set C<retlen> to C<-1> and return zero. If the
389 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
390 malformations will be given, C<retlen> will be set to the expected
391 length of the UTF-8 character in bytes, and zero will be returned.
393 The C<flags> can also contain various flags to allow deviations from
394 the strict UTF-8 encoding (see F<utf8.h>).
396 Most code should use utf8_to_uvchr() rather than call this directly.
402 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
404 const U8 * const s0 = s;
407 const bool dowarn = ckWARN_d(WARN_UTF8);
408 const UV startbyte = *s;
409 STRLEN expectlen = 0;
412 /* This list is a superset of the UTF8_ALLOW_XXX. */
414 #define UTF8_WARN_EMPTY 1
415 #define UTF8_WARN_CONTINUATION 2
416 #define UTF8_WARN_NON_CONTINUATION 3
417 #define UTF8_WARN_FE_FF 4
418 #define UTF8_WARN_SHORT 5
419 #define UTF8_WARN_OVERFLOW 6
420 #define UTF8_WARN_SURROGATE 7
421 #define UTF8_WARN_LONG 8
422 #define UTF8_WARN_FFFF 9 /* Also FFFE. */
425 !(flags & UTF8_ALLOW_EMPTY)) {
426 warning = UTF8_WARN_EMPTY;
430 if (UTF8_IS_INVARIANT(uv)) {
433 return (UV) (NATIVE_TO_UTF(*s));
436 if (UTF8_IS_CONTINUATION(uv) &&
437 !(flags & UTF8_ALLOW_CONTINUATION)) {
438 warning = UTF8_WARN_CONTINUATION;
442 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
443 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
444 warning = UTF8_WARN_NON_CONTINUATION;
449 uv = NATIVE_TO_UTF(uv);
451 if ((uv == 0xfe || uv == 0xff) &&
452 !(flags & UTF8_ALLOW_FE_FF)) {
453 warning = UTF8_WARN_FE_FF;
458 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
459 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
460 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
461 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
463 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
464 else { len = 7; uv &= 0x01; }
466 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
467 else if (!(uv & 0x01)) { len = 7; uv = 0; }
468 else { len = 13; uv = 0; } /* whoa! */
476 if ((curlen < expectlen) &&
477 !(flags & UTF8_ALLOW_SHORT)) {
478 warning = UTF8_WARN_SHORT;
487 if (!UTF8_IS_CONTINUATION(*s) &&
488 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
490 warning = UTF8_WARN_NON_CONTINUATION;
494 uv = UTF8_ACCUMULATE(uv, *s);
496 /* These cannot be allowed. */
498 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
499 warning = UTF8_WARN_LONG;
503 else { /* uv < ouv */
504 /* This cannot be allowed. */
505 warning = UTF8_WARN_OVERFLOW;
513 if (UNICODE_IS_SURROGATE(uv) &&
514 !(flags & UTF8_ALLOW_SURROGATE)) {
515 warning = UTF8_WARN_SURROGATE;
517 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
518 !(flags & UTF8_ALLOW_LONG)) {
519 warning = UTF8_WARN_LONG;
521 } else if (UNICODE_IS_ILLEGAL(uv) &&
522 !(flags & UTF8_ALLOW_FFFF)) {
523 warning = UTF8_WARN_FFFF;
531 if (flags & UTF8_CHECK_ONLY) {
533 *retlen = ((STRLEN) -1);
538 SV* const sv = sv_2mortal(newSVpvs("Malformed UTF-8 character "));
541 case 0: /* Intentionally empty. */ break;
542 case UTF8_WARN_EMPTY:
543 sv_catpvs(sv, "(empty string)");
545 case UTF8_WARN_CONTINUATION:
546 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
548 case UTF8_WARN_NON_CONTINUATION:
550 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
551 (UV)s[1], startbyte);
553 const int len = (int)(s-s0);
554 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
555 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
559 case UTF8_WARN_FE_FF:
560 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
562 case UTF8_WARN_SHORT:
563 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
564 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
565 expectlen = curlen; /* distance for caller to skip */
567 case UTF8_WARN_OVERFLOW:
568 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
571 case UTF8_WARN_SURROGATE:
572 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
575 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
576 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
579 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
582 sv_catpvs(sv, "(unknown reason)");
587 const char * const s = SvPVX_const(sv);
590 Perl_warner(aTHX_ packWARN(WARN_UTF8),
591 "%s in %s", s, OP_DESC(PL_op));
593 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
598 *retlen = expectlen ? expectlen : len;
604 =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
606 Returns the native character value of the first character in the string C<s>
607 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
608 length, in bytes, of that character.
610 If C<s> does not point to a well-formed UTF-8 character, zero is
611 returned and retlen is set, if possible, to -1.
617 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
619 return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
620 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
624 =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
626 Returns the Unicode code point of the first character in the string C<s>
627 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
628 length, in bytes, of that character.
630 This function should only be used when returned UV is considered
631 an index into the Unicode semantic tables (e.g. swashes).
633 If C<s> does not point to a well-formed UTF-8 character, zero is
634 returned and retlen is set, if possible, to -1.
640 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
642 /* Call the low level routine asking for checks */
643 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
644 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
648 =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
650 Return the length of the UTF-8 char encoded string C<s> in characters.
651 Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
652 up past C<e>, croaks.
658 Perl_utf8_length(pTHX_ U8 *s, U8 *e)
663 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
664 * the bitops (especially ~) can create illegal UTF-8.
665 * In other words: in Perl UTF-8 is not just for Unicode. */
668 goto warn_and_return;
673 if (ckWARN_d(WARN_UTF8)) {
675 Perl_warner(aTHX_ packWARN(WARN_UTF8),
676 "%s in %s", unees, OP_DESC(PL_op));
678 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
690 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
692 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
695 WARNING: use only if you *know* that the pointers point inside the
702 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
704 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
708 =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
710 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
713 WARNING: do not use the following unless you *know* C<off> is within
714 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
715 on the first byte of character or just after the last byte of a character.
721 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
724 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
725 * the bitops (especially ~) can create illegal UTF-8.
726 * In other words: in Perl UTF-8 is not just for Unicode. */
735 while (UTF8_IS_CONTINUATION(*s))
743 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
745 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
746 Unlike C<bytes_to_utf8>, this over-writes the original string, and
747 updates len to contain the new length.
748 Returns zero on failure, setting C<len> to -1.
754 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
757 U8 * const send = s + *len;
760 /* ensure valid UTF-8 and chars < 256 before updating string */
764 if (!UTF8_IS_INVARIANT(c) &&
765 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
766 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
767 *len = ((STRLEN) -1);
775 *d++ = (U8)utf8_to_uvchr(s, &ulen);
784 =for apidoc A|U8 *|bytes_from_utf8|const U8 *s|STRLEN *len|bool *is_utf8
786 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
787 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
788 the newly-created string, and updates C<len> to contain the new
789 length. Returns the original string if no conversion occurs, C<len>
790 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
791 0 if C<s> is converted or contains all 7bit characters.
797 Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
809 /* ensure valid UTF-8 and chars < 256 before converting string */
810 for (send = s + *len; s < send;) {
812 if (!UTF8_IS_INVARIANT(c)) {
813 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
814 (c = *s++) && UTF8_IS_CONTINUATION(c))
823 Newx(d, (*len) - count + 1, U8);
824 s2 = start; start = d;
827 if (!UTF8_IS_INVARIANT(c)) {
828 /* Then it is two-byte encoded */
829 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s2++);
830 c = ASCII_TO_NATIVE(c);
840 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
842 Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
843 Returns a pointer to the newly-created string, and sets C<len> to
844 reflect the new length.
846 If you want to convert to UTF-8 from other encodings than ASCII,
847 see sv_recode_to_utf8().
853 Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
855 const U8 * const send = s + (*len);
860 Newx(d, (*len) * 2 + 1, U8);
864 const UV uv = NATIVE_TO_ASCII(*s++);
865 if (UNI_IS_INVARIANT(uv))
866 *d++ = (U8)UTF_TO_NATIVE(uv);
868 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
869 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
878 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
880 * Destination must be pre-extended to 3/2 source. Do not use in-place.
881 * We optimize for native, for obvious reasons. */
884 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
889 if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
896 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
901 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
905 *d++ = UNI_TO_NATIVE(uv);
912 *d++ = (U8)(( uv >> 6) | 0xc0);
913 *d++ = (U8)(( uv & 0x3f) | 0x80);
916 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
917 UV low = (p[0] << 8) + p[1];
919 if (low < 0xdc00 || low >= 0xdfff)
920 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
921 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
924 *d++ = (U8)(( uv >> 12) | 0xe0);
925 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
926 *d++ = (U8)(( uv & 0x3f) | 0x80);
930 *d++ = (U8)(( uv >> 18) | 0xf0);
931 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
932 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
933 *d++ = (U8)(( uv & 0x3f) | 0x80);
937 *newlen = d - dstart;
941 /* Note: this one is slightly destructive of the source. */
944 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
947 U8* const send = s + bytelen;
954 return utf16_to_utf8(p, d, bytelen, newlen);
957 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
960 Perl_is_uni_alnum(pTHX_ UV c)
962 U8 tmpbuf[UTF8_MAXBYTES+1];
963 uvchr_to_utf8(tmpbuf, c);
964 return is_utf8_alnum(tmpbuf);
968 Perl_is_uni_alnumc(pTHX_ UV c)
970 U8 tmpbuf[UTF8_MAXBYTES+1];
971 uvchr_to_utf8(tmpbuf, c);
972 return is_utf8_alnumc(tmpbuf);
976 Perl_is_uni_idfirst(pTHX_ UV c)
978 U8 tmpbuf[UTF8_MAXBYTES+1];
979 uvchr_to_utf8(tmpbuf, c);
980 return is_utf8_idfirst(tmpbuf);
984 Perl_is_uni_alpha(pTHX_ UV c)
986 U8 tmpbuf[UTF8_MAXBYTES+1];
987 uvchr_to_utf8(tmpbuf, c);
988 return is_utf8_alpha(tmpbuf);
992 Perl_is_uni_ascii(pTHX_ UV c)
994 U8 tmpbuf[UTF8_MAXBYTES+1];
995 uvchr_to_utf8(tmpbuf, c);
996 return is_utf8_ascii(tmpbuf);
1000 Perl_is_uni_space(pTHX_ UV c)
1002 U8 tmpbuf[UTF8_MAXBYTES+1];
1003 uvchr_to_utf8(tmpbuf, c);
1004 return is_utf8_space(tmpbuf);
1008 Perl_is_uni_digit(pTHX_ UV c)
1010 U8 tmpbuf[UTF8_MAXBYTES+1];
1011 uvchr_to_utf8(tmpbuf, c);
1012 return is_utf8_digit(tmpbuf);
1016 Perl_is_uni_upper(pTHX_ UV c)
1018 U8 tmpbuf[UTF8_MAXBYTES+1];
1019 uvchr_to_utf8(tmpbuf, c);
1020 return is_utf8_upper(tmpbuf);
1024 Perl_is_uni_lower(pTHX_ UV c)
1026 U8 tmpbuf[UTF8_MAXBYTES+1];
1027 uvchr_to_utf8(tmpbuf, c);
1028 return is_utf8_lower(tmpbuf);
1032 Perl_is_uni_cntrl(pTHX_ UV c)
1034 U8 tmpbuf[UTF8_MAXBYTES+1];
1035 uvchr_to_utf8(tmpbuf, c);
1036 return is_utf8_cntrl(tmpbuf);
1040 Perl_is_uni_graph(pTHX_ UV c)
1042 U8 tmpbuf[UTF8_MAXBYTES+1];
1043 uvchr_to_utf8(tmpbuf, c);
1044 return is_utf8_graph(tmpbuf);
1048 Perl_is_uni_print(pTHX_ UV c)
1050 U8 tmpbuf[UTF8_MAXBYTES+1];
1051 uvchr_to_utf8(tmpbuf, c);
1052 return is_utf8_print(tmpbuf);
1056 Perl_is_uni_punct(pTHX_ UV c)
1058 U8 tmpbuf[UTF8_MAXBYTES+1];
1059 uvchr_to_utf8(tmpbuf, c);
1060 return is_utf8_punct(tmpbuf);
1064 Perl_is_uni_xdigit(pTHX_ UV c)
1066 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1067 uvchr_to_utf8(tmpbuf, c);
1068 return is_utf8_xdigit(tmpbuf);
1072 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1074 uvchr_to_utf8(p, c);
1075 return to_utf8_upper(p, p, lenp);
1079 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1081 uvchr_to_utf8(p, c);
1082 return to_utf8_title(p, p, lenp);
1086 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1088 uvchr_to_utf8(p, c);
1089 return to_utf8_lower(p, p, lenp);
1093 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1095 uvchr_to_utf8(p, c);
1096 return to_utf8_fold(p, p, lenp);
1099 /* for now these all assume no locale info available for Unicode > 255 */
1102 Perl_is_uni_alnum_lc(pTHX_ UV c)
1104 return is_uni_alnum(c); /* XXX no locale support yet */
1108 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1110 return is_uni_alnumc(c); /* XXX no locale support yet */
1114 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1116 return is_uni_idfirst(c); /* XXX no locale support yet */
1120 Perl_is_uni_alpha_lc(pTHX_ UV c)
1122 return is_uni_alpha(c); /* XXX no locale support yet */
1126 Perl_is_uni_ascii_lc(pTHX_ UV c)
1128 return is_uni_ascii(c); /* XXX no locale support yet */
1132 Perl_is_uni_space_lc(pTHX_ UV c)
1134 return is_uni_space(c); /* XXX no locale support yet */
1138 Perl_is_uni_digit_lc(pTHX_ UV c)
1140 return is_uni_digit(c); /* XXX no locale support yet */
1144 Perl_is_uni_upper_lc(pTHX_ UV c)
1146 return is_uni_upper(c); /* XXX no locale support yet */
1150 Perl_is_uni_lower_lc(pTHX_ UV c)
1152 return is_uni_lower(c); /* XXX no locale support yet */
1156 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1158 return is_uni_cntrl(c); /* XXX no locale support yet */
1162 Perl_is_uni_graph_lc(pTHX_ UV c)
1164 return is_uni_graph(c); /* XXX no locale support yet */
1168 Perl_is_uni_print_lc(pTHX_ UV c)
1170 return is_uni_print(c); /* XXX no locale support yet */
1174 Perl_is_uni_punct_lc(pTHX_ UV c)
1176 return is_uni_punct(c); /* XXX no locale support yet */
1180 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1182 return is_uni_xdigit(c); /* XXX no locale support yet */
1186 Perl_to_uni_upper_lc(pTHX_ U32 c)
1188 /* XXX returns only the first character -- do not use XXX */
1189 /* XXX no locale support yet */
1191 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1192 return (U32)to_uni_upper(c, tmpbuf, &len);
1196 Perl_to_uni_title_lc(pTHX_ U32 c)
1198 /* XXX returns only the first character XXX -- do not use XXX */
1199 /* XXX no locale support yet */
1201 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1202 return (U32)to_uni_title(c, tmpbuf, &len);
1206 Perl_to_uni_lower_lc(pTHX_ U32 c)
1208 /* XXX returns only the first character -- do not use XXX */
1209 /* XXX no locale support yet */
1211 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1212 return (U32)to_uni_lower(c, tmpbuf, &len);
1216 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1217 const char *const swashname)
1219 if (!is_utf8_char((U8 *)p))
1222 *swash = swash_init("utf8", (char *)swashname, &PL_sv_undef, 1, 0);
1223 return swash_fetch(*swash, (U8 *)p, TRUE) != 0;
1227 Perl_is_utf8_alnum(pTHX_ U8 *p)
1229 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1230 * descendant of isalnum(3), in other words, it doesn't
1231 * contain the '_'. --jhi */
1232 return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1236 Perl_is_utf8_alnumc(pTHX_ U8 *p)
1238 return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnumC");
1242 Perl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
1246 /* is_utf8_idstart would be more logical. */
1247 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1251 Perl_is_utf8_idcont(pTHX_ U8 *p)
1255 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1259 Perl_is_utf8_alpha(pTHX_ U8 *p)
1261 return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1265 Perl_is_utf8_ascii(pTHX_ U8 *p)
1267 return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1271 Perl_is_utf8_space(pTHX_ U8 *p)
1273 return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1277 Perl_is_utf8_digit(pTHX_ U8 *p)
1279 return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1283 Perl_is_utf8_upper(pTHX_ U8 *p)
1285 return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1289 Perl_is_utf8_lower(pTHX_ U8 *p)
1291 return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1295 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1297 return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1301 Perl_is_utf8_graph(pTHX_ U8 *p)
1303 return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1307 Perl_is_utf8_print(pTHX_ U8 *p)
1309 return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1313 Perl_is_utf8_punct(pTHX_ U8 *p)
1315 return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1319 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1321 return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
1325 Perl_is_utf8_mark(pTHX_ U8 *p)
1327 return is_utf8_common(p, &PL_utf8_mark, "IsM");
1331 =for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1333 The "p" contains the pointer to the UTF-8 string encoding
1334 the character that is being converted.
1336 The "ustrp" is a pointer to the character buffer to put the
1337 conversion result to. The "lenp" is a pointer to the length
1340 The "swashp" is a pointer to the swash to use.
1342 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1343 and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
1344 but not always, a multicharacter mapping), is tried first.
1346 The "special" is a string like "utf8::ToSpecLower", which means the
1347 hash %utf8::ToSpecLower. The access to the hash is through
1348 Perl_to_utf8_case().
1350 The "normal" is a string like "ToLower" which means the swash
1356 Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
1358 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1361 const UV uv0 = utf8_to_uvchr(p, NULL);
1362 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1363 * are necessary in EBCDIC, they are redundant no-ops
1364 * in ASCII-ish platforms, and hopefully optimized away. */
1365 const UV uv1 = NATIVE_TO_UNI(uv0);
1366 uvuni_to_utf8(tmpbuf, uv1);
1368 if (!*swashp) /* load on-demand */
1369 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1371 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1372 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1373 /* It might be "special" (sometimes, but not always,
1374 * a multicharacter mapping) */
1375 HV * const hv = get_hv(special, FALSE);
1379 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1383 s = SvPV_const(*svp, len);
1385 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1388 /* If we have EBCDIC we need to remap the characters
1389 * since any characters in the low 256 are Unicode
1390 * code points, not EBCDIC. */
1391 U8 *t = (U8*)s, *tend = t + len, *d;
1398 const UV c = utf8_to_uvchr(t, &tlen);
1400 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1409 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1414 Copy(tmpbuf, ustrp, len, U8);
1416 Copy(s, ustrp, len, U8);
1422 if (!len && *swashp) {
1423 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1426 /* It was "normal" (a single character mapping). */
1427 const UV uv3 = UNI_TO_NATIVE(uv2);
1428 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1432 if (!len) /* Neither: just copy. */
1433 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1438 return len ? utf8_to_uvchr(ustrp, 0) : 0;
1442 =for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1444 Convert the UTF-8 encoded character at p to its uppercase version and
1445 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1446 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1447 the uppercase version may be longer than the original character.
1449 The first character of the uppercased version is returned
1450 (but note, as explained above, that there may be more.)
1455 Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1457 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1458 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1462 =for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1464 Convert the UTF-8 encoded character at p to its titlecase version and
1465 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1466 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1467 titlecase version may be longer than the original character.
1469 The first character of the titlecased version is returned
1470 (but note, as explained above, that there may be more.)
1475 Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1477 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1478 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1482 =for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1484 Convert the UTF-8 encoded character at p to its lowercase version and
1485 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1486 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1487 lowercase version may be longer than the original character.
1489 The first character of the lowercased version is returned
1490 (but note, as explained above, that there may be more.)
1495 Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1497 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1498 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1502 =for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1504 Convert the UTF-8 encoded character at p to its foldcase version and
1505 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1506 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1507 foldcase version may be longer than the original character (up to
1510 The first character of the foldcased version is returned
1511 (but note, as explained above, that there may be more.)
1516 Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1518 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1519 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1523 * A "swash" is a swatch hash.
1524 * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1525 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1526 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1529 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1532 SV* const tokenbufsv = sv_newmortal();
1534 const size_t pkg_len = strlen(pkg);
1535 const size_t name_len = strlen(name);
1536 HV * const stash = gv_stashpvn(pkg, pkg_len, FALSE);
1539 PUSHSTACKi(PERLSI_MAGIC);
1544 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
1546 errsv_save = newSVsv(ERRSV);
1547 /* It is assumed that callers of this routine are not passing in any
1548 user derived data. */
1549 /* Need to do this after save_re_context() as it will set PL_tainted to
1550 1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1551 Even line to create errsv_save can turn on PL_tainted. */
1552 SAVEBOOL(PL_tainted);
1554 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1557 sv_setsv(ERRSV, errsv_save);
1558 SvREFCNT_dec(errsv_save);
1564 PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
1565 PUSHs(sv_2mortal(newSVpvn(name, name_len)));
1567 PUSHs(sv_2mortal(newSViv(minbits)));
1568 PUSHs(sv_2mortal(newSViv(none)));
1570 if (IN_PERL_COMPILETIME) {
1571 /* XXX ought to be handled by lex_start */
1574 sv_setpv(tokenbufsv, PL_tokenbuf);
1576 errsv_save = newSVsv(ERRSV);
1577 if (call_method("SWASHNEW", G_SCALAR))
1578 retval = newSVsv(*PL_stack_sp--);
1580 retval = &PL_sv_undef;
1582 sv_setsv(ERRSV, errsv_save);
1583 SvREFCNT_dec(errsv_save);
1586 if (IN_PERL_COMPILETIME) {
1588 const char* const pv = SvPV_const(tokenbufsv, len);
1590 Copy(pv, PL_tokenbuf, len+1, char);
1591 CopHINTS_set(PL_curcop, PL_hints);
1593 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1595 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1597 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1603 /* This API is wrong for special case conversions since we may need to
1604 * return several Unicode characters for a single Unicode character
1605 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1606 * the lower-level routine, and it is similarly broken for returning
1607 * multiple values. --jhi */
1608 /* Now SWASHGET is recasted into S_swash_get in this file. */
1611 * Returns the value of property/mapping C<swash> for the first character
1612 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1613 * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1614 * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1617 Perl_swash_fetch(pTHX_ SV *swash, U8 *ptr, bool do_utf8)
1619 HV* const hv = (HV*)SvRV(swash);
1624 const U8 *tmps = NULL;
1628 const UV c = NATIVE_TO_ASCII(*ptr);
1630 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1631 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1632 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1635 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1636 * then the "swatch" is a vec() for al the chars which start
1638 * So the key in the hash (klen) is length of encoded char -1
1640 klen = UTF8SKIP(ptr) - 1;
1644 /* If char in invariant then swatch is for all the invariant chars
1645 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1647 needents = UTF_CONTINUATION_MARK;
1648 off = NATIVE_TO_UTF(ptr[klen]);
1651 /* If char is encoded then swatch is for the prefix */
1652 needents = (1 << UTF_ACCUMULATION_SHIFT);
1653 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1657 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1658 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1659 * it's nothing to sniff at.) Pity we usually come through at least
1660 * two function calls to get here...
1662 * NB: this code assumes that swatches are never modified, once generated!
1665 if (hv == PL_last_swash_hv &&
1666 klen == PL_last_swash_klen &&
1667 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1669 tmps = PL_last_swash_tmps;
1670 slen = PL_last_swash_slen;
1673 /* Try our second-level swatch cache, kept in a hash. */
1674 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
1676 /* If not cached, generate it via swash_get */
1677 if (!svp || !SvPOK(*svp)
1678 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
1679 /* We use utf8n_to_uvuni() as we want an index into
1680 Unicode tables, not a native character number.
1682 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
1684 0 : UTF8_ALLOW_ANY);
1685 swatch = swash_get(swash,
1686 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1687 (klen) ? (code_point & ~(needents - 1)) : 0,
1690 if (IN_PERL_COMPILETIME)
1691 CopHINTS_set(PL_curcop, PL_hints);
1693 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
1695 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1696 || (slen << 3) < needents)
1697 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
1700 PL_last_swash_hv = hv;
1701 PL_last_swash_klen = klen;
1702 /* FIXME change interpvar.h? */
1703 PL_last_swash_tmps = (U8 *) tmps;
1704 PL_last_swash_slen = slen;
1706 Copy(ptr, PL_last_swash_key, klen, U8);
1709 switch ((int)((slen << 3) / needents)) {
1711 bit = 1 << (off & 7);
1713 return (tmps[off] & bit) != 0;
1718 return (tmps[off] << 8) + tmps[off + 1] ;
1721 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1723 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
1724 NORETURN_FUNCTION_END;
1728 * Returns a swatch (a bit vector string) for a code point sequence
1729 * that starts from the value C<start> and comprises the number C<span>.
1730 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1731 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1734 S_swash_get(pTHX_ SV* swash, UV start, UV span)
1737 U8 *l, *lend, *x, *xend, *s;
1738 STRLEN lcur, xcur, scur;
1740 HV* const hv = (HV*)SvRV(swash);
1741 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1742 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1743 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1744 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1745 SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
1746 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1747 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
1748 const STRLEN bits = SvUV(*bitssvp);
1749 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1750 const UV none = SvUV(*nonesvp);
1751 const UV end = start + span;
1753 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1754 Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1758 /* create and initialize $swatch */
1759 swatch = newSVpvs("");
1760 scur = octets ? (span * octets) : (span + 7) / 8;
1761 SvGROW(swatch, scur + 1);
1762 s = (U8*)SvPVX(swatch);
1763 if (octets && none) {
1764 const U8* const e = s + scur;
1767 *s++ = (U8)(none & 0xff);
1768 else if (bits == 16) {
1769 *s++ = (U8)((none >> 8) & 0xff);
1770 *s++ = (U8)( none & 0xff);
1772 else if (bits == 32) {
1773 *s++ = (U8)((none >> 24) & 0xff);
1774 *s++ = (U8)((none >> 16) & 0xff);
1775 *s++ = (U8)((none >> 8) & 0xff);
1776 *s++ = (U8)( none & 0xff);
1782 (void)memzero((U8*)s, scur + 1);
1784 SvCUR_set(swatch, scur);
1785 s = (U8*)SvPVX(swatch);
1787 /* read $swash->{LIST} */
1788 l = (U8*)SvPV(*listsvp, lcur);
1793 I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1795 U8* const nl = (U8*)memchr(l, '\n', lend - l);
1798 min = grok_hex((char *)l, &numlen, &flags, NULL);
1802 l = nl + 1; /* 1 is length of "\n" */
1806 l = lend; /* to LIST's end at which \n is not found */
1812 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1814 max = grok_hex((char *)l, &numlen, &flags, NULL);
1823 flags = PERL_SCAN_SILENT_ILLDIGIT |
1824 PERL_SCAN_DISALLOW_PREFIX;
1826 val = grok_hex((char *)l, &numlen, &flags, NULL);
1835 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1841 val = 0; /* bits == 1, then val should be ignored */
1848 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1852 val = 0; /* bits == 1, then val should be ignored */
1866 if (!none || val < none) {
1871 for (key = min; key <= max; key++) {
1875 /* offset must be non-negative (start <= min <= key < end) */
1876 offset = octets * (key - start);
1878 s[offset] = (U8)(val & 0xff);
1879 else if (bits == 16) {
1880 s[offset ] = (U8)((val >> 8) & 0xff);
1881 s[offset + 1] = (U8)( val & 0xff);
1883 else if (bits == 32) {
1884 s[offset ] = (U8)((val >> 24) & 0xff);
1885 s[offset + 1] = (U8)((val >> 16) & 0xff);
1886 s[offset + 2] = (U8)((val >> 8) & 0xff);
1887 s[offset + 3] = (U8)( val & 0xff);
1890 if (!none || val < none)
1894 else { /* bits == 1, then val should be ignored */
1898 for (key = min; key <= max; key++) {
1899 const STRLEN offset = (STRLEN)(key - start);
1902 s[offset >> 3] |= 1 << (offset & 7);
1908 /* read $swash->{EXTRAS} */
1909 x = (U8*)SvPV(*extssvp, xcur);
1917 SV **otherbitssvp, *other;
1921 const U8 opc = *x++;
1925 nl = (U8*)memchr(x, '\n', xend - x);
1927 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
1929 x = nl + 1; /* 1 is length of "\n" */
1933 x = xend; /* to EXTRAS' end at which \n is not found */
1940 namelen = nl - namestr;
1944 namelen = xend - namestr;
1948 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
1949 otherhv = (HV*)SvRV(*othersvp);
1950 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
1951 otherbits = (STRLEN)SvUV(*otherbitssvp);
1952 if (bits < otherbits)
1953 Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
1955 /* The "other" swatch must be destroyed after. */
1956 other = swash_get(*othersvp, start, span);
1957 o = (U8*)SvPV(other, olen);
1960 Perl_croak(aTHX_ "panic: swash_get got improper swatch");
1962 s = (U8*)SvPV(swatch, slen);
1963 if (bits == 1 && otherbits == 1) {
1965 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
1989 STRLEN otheroctets = otherbits >> 3;
1991 U8* const send = s + slen;
1996 if (otherbits == 1) {
1997 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2001 STRLEN vlen = otheroctets;
2009 if (opc == '+' && otherval)
2010 NOOP; /* replace with otherval */
2011 else if (opc == '!' && !otherval)
2013 else if (opc == '-' && otherval)
2015 else if (opc == '&' && !otherval)
2018 s += octets; /* no replacement */
2023 *s++ = (U8)( otherval & 0xff);
2024 else if (bits == 16) {
2025 *s++ = (U8)((otherval >> 8) & 0xff);
2026 *s++ = (U8)( otherval & 0xff);
2028 else if (bits == 32) {
2029 *s++ = (U8)((otherval >> 24) & 0xff);
2030 *s++ = (U8)((otherval >> 16) & 0xff);
2031 *s++ = (U8)((otherval >> 8) & 0xff);
2032 *s++ = (U8)( otherval & 0xff);
2036 sv_free(other); /* through with it! */
2042 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
2044 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2045 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2046 bytes available. The return value is the pointer to the byte after the
2047 end of the new character. In other words,
2049 d = uvchr_to_utf8(d, uv);
2051 is the recommended wide native character-aware way of saying
2058 /* On ASCII machines this is normally a macro but we want a
2059 real function in case XS code wants it
2062 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2064 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2068 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2070 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2074 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
2077 Returns the native character value of the first character in the string
2079 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2080 length, in bytes, of that character.
2082 Allows length and flags to be passed to low level routine.
2086 /* On ASCII machines this is normally a macro but we want
2087 a real function in case XS code wants it
2090 Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
2092 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2093 return UNI_TO_NATIVE(uv);
2097 =for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
2099 Build to the scalar dsv a displayable version of the string spv,
2100 length len, the displayable version being at most pvlim bytes long
2101 (if longer, the rest is truncated and "..." will be appended).
2103 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2104 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2105 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2106 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2107 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2108 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2110 The pointer to the PV of the dsv is returned.
2114 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2119 sv_setpvn(dsv, "", 0);
2120 for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2122 /* This serves double duty as a flag and a character to print after
2123 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2127 if (pvlim && SvCUR(dsv) >= pvlim) {
2131 u = utf8_to_uvchr((U8*)s, 0);
2133 const unsigned char c = (unsigned char)u & 0xFF;
2134 if (flags & UNI_DISPLAY_BACKSLASH) {
2151 Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok);
2154 /* isPRINT() is the locale-blind version. */
2155 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2156 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2161 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2164 sv_catpvs(dsv, "...");
2170 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
2172 Build to the scalar dsv a displayable version of the scalar sv,
2173 the displayable version being at most pvlim bytes long
2174 (if longer, the rest is truncated and "..." will be appended).
2176 The flags argument is as in pv_uni_display().
2178 The pointer to the PV of the dsv is returned.
2183 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2185 return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX_const(ssv),
2186 SvCUR(ssv), pvlim, flags);
2190 =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
2192 Return true if the strings s1 and s2 differ case-insensitively, false
2193 if not (if they are equal case-insensitively). If u1 is true, the
2194 string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
2195 the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
2196 are false, the respective string is assumed to be in native 8-bit
2199 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2200 in there (they will point at the beginning of the I<next> character).
2201 If the pointers behind pe1 or pe2 are non-NULL, they are the end
2202 pointers beyond which scanning will not continue under any
2203 circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
2204 s2+l2 will be used as goal end pointers that will also stop the scan,
2205 and which qualify towards defining a successful match: all the scans
2206 that define an explicit length must reach their goal pointers for
2207 a match to succeed).
2209 For case-insensitiveness, the "casefolding" of Unicode is used
2210 instead of upper/lowercasing both the characters, see
2211 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2215 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2217 register const U8 *p1 = (const U8*)s1;
2218 register const U8 *p2 = (const U8*)s2;
2219 register const U8 *f1 = NULL;
2220 register const U8 *f2 = NULL;
2221 register U8 *e1 = NULL;
2222 register U8 *q1 = NULL;
2223 register U8 *e2 = NULL;
2224 register U8 *q2 = NULL;
2225 STRLEN n1 = 0, n2 = 0;
2226 U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2227 U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2229 STRLEN foldlen1, foldlen2;
2234 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2235 f1 = (const U8*)s1 + l1;
2238 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2239 f2 = (const U8*)s2 + l2;
2241 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2242 return 1; /* mismatch; possible infinite loop or false positive */
2245 natbuf[1] = 0; /* Need to terminate the buffer. */
2247 while ((e1 == 0 || p1 < e1) &&
2248 (f1 == 0 || p1 < f1) &&
2249 (e2 == 0 || p2 < e2) &&
2250 (f2 == 0 || p2 < f2)) {
2253 to_utf8_fold((U8 *)p1, foldbuf1, &foldlen1);
2255 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2256 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2263 to_utf8_fold((U8 *)p2, foldbuf2, &foldlen2);
2265 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2266 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2272 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2273 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2274 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
2275 return 1; /* mismatch */
2282 p1 += u1 ? UTF8SKIP(p1) : 1;
2284 p2 += u2 ? UTF8SKIP(p2) : 1;
2288 /* A match is defined by all the scans that specified
2289 * an explicit length reaching their final goals. */
2290 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
2299 return match ? 0 : 1; /* 0 match, 1 mismatch */
2304 * c-indentation-style: bsd
2306 * indent-tabs-mode: t
2309 * ex: set ts=8 sts=4 sw=4 noet: