3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
18 * 'Well do I understand your speech,' he answered in the same language;
19 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
20 * as is the custom in the West, if you wish to be answered?'
21 * --Gandalf, addressing Théoden's door wardens
23 * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
25 * ...the travellers perceived that the floor was paved with stones of many
26 * hues; branching runes and strange devices intertwined beneath their feet.
28 * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
32 #define PERL_IN_UTF8_C
36 /* Separate prototypes needed because in ASCII systems these
37 * usually macros but they still are compiled as code, too. */
38 PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
39 PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
42 static const char unees[] =
43 "Malformed UTF-8 character (unexpected end of string)";
46 =head1 Unicode Support
48 This file contains various utility functions for manipulating UTF8-encoded
49 strings. For the uninitiated, this is a method of representing arbitrary
50 Unicode characters as a variable number of bytes, in such a way that
51 characters in the ASCII range are unmodified, and a zero byte never appears
52 within non-zero characters.
54 =for apidoc uvuni_to_utf8_flags
56 Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
57 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
58 bytes available. The return value is the pointer to the byte after the
59 end of the new character. In other words,
61 d = uvuni_to_utf8_flags(d, uv, flags);
65 d = uvuni_to_utf8(d, uv);
67 (which is equivalent to)
69 d = uvuni_to_utf8_flags(d, uv, 0);
71 is the recommended Unicode-aware way of saying
79 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
81 PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
83 if (ckWARN(WARN_UTF8)) {
84 if (UNICODE_IS_SURROGATE(uv) &&
85 !(flags & UNICODE_ALLOW_SURROGATE))
86 Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
88 ((uv >= 0xFDD0 && uv <= 0xFDEF &&
89 !(flags & UNICODE_ALLOW_FDD0))
91 ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
92 !(flags & UNICODE_ALLOW_FFFF))) &&
93 /* UNICODE_ALLOW_SUPER includes
94 * FFFEs and FFFFs beyond 0x10FFFF. */
95 ((uv <= PERL_UNICODE_MAX) ||
96 !(flags & UNICODE_ALLOW_SUPER))
98 Perl_warner(aTHX_ packWARN(WARN_UTF8),
99 "Unicode character 0x%04"UVxf" is illegal", uv);
101 if (UNI_IS_INVARIANT(uv)) {
102 *d++ = (U8)UTF_TO_NATIVE(uv);
107 STRLEN len = UNISKIP(uv);
110 *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
111 uv >>= UTF_ACCUMULATION_SHIFT;
113 *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
116 #else /* Non loop style */
118 *d++ = (U8)(( uv >> 6) | 0xc0);
119 *d++ = (U8)(( uv & 0x3f) | 0x80);
123 *d++ = (U8)(( uv >> 12) | 0xe0);
124 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
125 *d++ = (U8)(( uv & 0x3f) | 0x80);
129 *d++ = (U8)(( uv >> 18) | 0xf0);
130 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
131 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
132 *d++ = (U8)(( uv & 0x3f) | 0x80);
135 if (uv < 0x4000000) {
136 *d++ = (U8)(( uv >> 24) | 0xf8);
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);
143 if (uv < 0x80000000) {
144 *d++ = (U8)(( uv >> 30) | 0xfc);
145 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
146 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
147 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
148 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
149 *d++ = (U8)(( uv & 0x3f) | 0x80);
153 if (uv < UTF8_QUAD_MAX)
156 *d++ = 0xfe; /* Can't match U+FEFF! */
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);
167 *d++ = 0xff; /* Can't match U+FFFE! */
168 *d++ = 0x80; /* 6 Reserved bits */
169 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
170 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
171 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
172 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
173 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
174 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
175 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
176 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
177 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
178 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
179 *d++ = (U8)(( uv & 0x3f) | 0x80);
183 #endif /* Loop style */
188 Tests if some arbitrary number of bytes begins in a valid UTF-8
189 character. Note that an INVARIANT (i.e. ASCII) character is a valid
190 UTF-8 character. The actual number of bytes in the UTF-8 character
191 will be returned if it is valid, otherwise 0.
193 This is the "slow" version as opposed to the "fast" version which is
194 the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed
195 difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four
196 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
197 you should use the _slow(). In practice this means that the _slow()
198 will be used very rarely, since the maximum Unicode code point (as of
199 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
200 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
205 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
211 PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
213 if (UTF8_IS_INVARIANT(u))
216 if (!UTF8_IS_START(u))
219 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
225 u = NATIVE_TO_UTF(u);
227 u &= UTF_START_MASK(len);
231 if (!UTF8_IS_CONTINUATION(*s))
233 uv = UTF8_ACCUMULATE(uv, *s);
240 if ((STRLEN)UNISKIP(uv) < len)
247 =for apidoc is_utf8_char
249 Tests if some arbitrary number of bytes begins in a valid UTF-8
250 character. Note that an INVARIANT (i.e. ASCII) character is a valid
251 UTF-8 character. The actual number of bytes in the UTF-8 character
252 will be returned if it is valid, otherwise 0.
256 Perl_is_utf8_char(pTHX_ const U8 *s)
258 const STRLEN len = UTF8SKIP(s);
260 PERL_ARGS_ASSERT_IS_UTF8_CHAR;
263 if (IS_UTF8_CHAR_FAST(len))
264 return IS_UTF8_CHAR(s, len) ? len : 0;
265 #endif /* #ifdef IS_UTF8_CHAR */
266 return is_utf8_char_slow(s, len);
270 =for apidoc is_utf8_string
272 Returns true if first C<len> bytes of the given string form a valid
273 UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
274 not mean 'a string that contains code points above 0x7F encoded in UTF-8'
275 because a valid ASCII string is a valid UTF-8 string.
277 See also is_utf8_string_loclen() and is_utf8_string_loc().
283 Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len)
285 const U8* const send = s + (len ? len : strlen((const char *)s));
288 PERL_ARGS_ASSERT_IS_UTF8_STRING;
293 /* Inline the easy bits of is_utf8_char() here for speed... */
294 if (UTF8_IS_INVARIANT(*x))
296 else if (!UTF8_IS_START(*x))
299 /* ... and call is_utf8_char() only if really needed. */
302 if (IS_UTF8_CHAR_FAST(c)) {
303 if (!IS_UTF8_CHAR(x, c))
307 c = is_utf8_char_slow(x, c);
310 #endif /* #ifdef IS_UTF8_CHAR */
325 Implemented as a macro in utf8.h
327 =for apidoc is_utf8_string_loc
329 Like is_utf8_string() but stores the location of the failure (in the
330 case of "utf8ness failure") or the location s+len (in the case of
331 "utf8ness success") in the C<ep>.
333 See also is_utf8_string_loclen() and is_utf8_string().
335 =for apidoc is_utf8_string_loclen
337 Like is_utf8_string() but stores the location of the failure (in the
338 case of "utf8ness failure") or the location s+len (in the case of
339 "utf8ness success") in the C<ep>, and the number of UTF-8
340 encoded characters in the C<el>.
342 See also is_utf8_string_loc() and is_utf8_string().
348 Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
350 const U8* const send = s + (len ? len : strlen((const char *)s));
355 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
359 /* Inline the easy bits of is_utf8_char() here for speed... */
360 if (UTF8_IS_INVARIANT(*x))
362 else if (!UTF8_IS_START(*x))
365 /* ... and call is_utf8_char() only if really needed. */
368 if (IS_UTF8_CHAR_FAST(c)) {
369 if (!IS_UTF8_CHAR(x, c))
372 c = is_utf8_char_slow(x, c);
375 #endif /* #ifdef IS_UTF8_CHAR */
394 =for apidoc utf8n_to_uvuni
396 Bottom level UTF-8 decode routine.
397 Returns the Unicode code point value of the first character in the string C<s>
398 which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
399 C<retlen> will be set to the length, in bytes, of that character.
401 If C<s> does not point to a well-formed UTF-8 character, the behaviour
402 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
403 it is assumed that the caller will raise a warning, and this function
404 will silently just set C<retlen> to C<-1> and return zero. If the
405 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
406 malformations will be given, C<retlen> will be set to the expected
407 length of the UTF-8 character in bytes, and zero will be returned.
409 The C<flags> can also contain various flags to allow deviations from
410 the strict UTF-8 encoding (see F<utf8.h>).
412 Most code should use utf8_to_uvchr() rather than call this directly.
418 Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
421 const U8 * const s0 = s;
424 const bool dowarn = ckWARN_d(WARN_UTF8);
425 const UV startbyte = *s;
426 STRLEN expectlen = 0;
429 PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
431 /* This list is a superset of the UTF8_ALLOW_XXX. */
433 #define UTF8_WARN_EMPTY 1
434 #define UTF8_WARN_CONTINUATION 2
435 #define UTF8_WARN_NON_CONTINUATION 3
436 #define UTF8_WARN_FE_FF 4
437 #define UTF8_WARN_SHORT 5
438 #define UTF8_WARN_OVERFLOW 6
439 #define UTF8_WARN_SURROGATE 7
440 #define UTF8_WARN_LONG 8
441 #define UTF8_WARN_FFFF 9 /* Also FFFE. */
444 !(flags & UTF8_ALLOW_EMPTY)) {
445 warning = UTF8_WARN_EMPTY;
449 if (UTF8_IS_INVARIANT(uv)) {
452 return (UV) (NATIVE_TO_UTF(*s));
455 if (UTF8_IS_CONTINUATION(uv) &&
456 !(flags & UTF8_ALLOW_CONTINUATION)) {
457 warning = UTF8_WARN_CONTINUATION;
461 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
462 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
463 warning = UTF8_WARN_NON_CONTINUATION;
468 uv = NATIVE_TO_UTF(uv);
470 if ((uv == 0xfe || uv == 0xff) &&
471 !(flags & UTF8_ALLOW_FE_FF)) {
472 warning = UTF8_WARN_FE_FF;
477 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
478 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
479 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
480 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
482 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
483 else { len = 7; uv &= 0x01; }
485 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
486 else if (!(uv & 0x01)) { len = 7; uv = 0; }
487 else { len = 13; uv = 0; } /* whoa! */
495 if ((curlen < expectlen) &&
496 !(flags & UTF8_ALLOW_SHORT)) {
497 warning = UTF8_WARN_SHORT;
506 if (!UTF8_IS_CONTINUATION(*s) &&
507 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
509 warning = UTF8_WARN_NON_CONTINUATION;
513 uv = UTF8_ACCUMULATE(uv, *s);
515 /* These cannot be allowed. */
517 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
518 warning = UTF8_WARN_LONG;
522 else { /* uv < ouv */
523 /* This cannot be allowed. */
524 warning = UTF8_WARN_OVERFLOW;
532 if (UNICODE_IS_SURROGATE(uv) &&
533 !(flags & UTF8_ALLOW_SURROGATE)) {
534 warning = UTF8_WARN_SURROGATE;
536 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
537 !(flags & UTF8_ALLOW_LONG)) {
538 warning = UTF8_WARN_LONG;
540 } else if (UNICODE_IS_ILLEGAL(uv) &&
541 !(flags & UTF8_ALLOW_FFFF)) {
542 warning = UTF8_WARN_FFFF;
550 if (flags & UTF8_CHECK_ONLY) {
552 *retlen = ((STRLEN) -1);
557 SV* const sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
560 case 0: /* Intentionally empty. */ break;
561 case UTF8_WARN_EMPTY:
562 sv_catpvs(sv, "(empty string)");
564 case UTF8_WARN_CONTINUATION:
565 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
567 case UTF8_WARN_NON_CONTINUATION:
569 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
570 (UV)s[1], startbyte);
572 const int len = (int)(s-s0);
573 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
574 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
578 case UTF8_WARN_FE_FF:
579 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
581 case UTF8_WARN_SHORT:
582 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
583 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
584 expectlen = curlen; /* distance for caller to skip */
586 case UTF8_WARN_OVERFLOW:
587 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
590 case UTF8_WARN_SURROGATE:
591 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
594 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
595 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
598 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
601 sv_catpvs(sv, "(unknown reason)");
606 const char * const s = SvPVX_const(sv);
609 Perl_warner(aTHX_ packWARN(WARN_UTF8),
610 "%s in %s", s, OP_DESC(PL_op));
612 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
617 *retlen = expectlen ? expectlen : len;
623 =for apidoc utf8_to_uvchr
625 Returns the native character value of the first character in the string C<s>
626 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
627 length, in bytes, of that character.
629 If C<s> does not point to a well-formed UTF-8 character, zero is
630 returned and retlen is set, if possible, to -1.
636 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
638 PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
640 return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
641 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
645 =for apidoc utf8_to_uvuni
647 Returns the Unicode code point of the first character in the string C<s>
648 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
649 length, in bytes, of that character.
651 This function should only be used when returned UV is considered
652 an index into the Unicode semantic tables (e.g. swashes).
654 If C<s> does not point to a well-formed UTF-8 character, zero is
655 returned and retlen is set, if possible, to -1.
661 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
663 PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
665 /* Call the low level routine asking for checks */
666 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
667 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
671 =for apidoc utf8_length
673 Return the length of the UTF-8 char encoded string C<s> in characters.
674 Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
675 up past C<e>, croaks.
681 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
687 PERL_ARGS_ASSERT_UTF8_LENGTH;
689 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
690 * the bitops (especially ~) can create illegal UTF-8.
691 * In other words: in Perl UTF-8 is not just for Unicode. */
694 goto warn_and_return;
699 if (ckWARN_d(WARN_UTF8)) {
701 Perl_warner(aTHX_ packWARN(WARN_UTF8),
702 "%s in %s", unees, OP_DESC(PL_op));
704 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
716 =for apidoc utf8_distance
718 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
721 WARNING: use only if you *know* that the pointers point inside the
728 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
730 PERL_ARGS_ASSERT_UTF8_DISTANCE;
732 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
738 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
741 WARNING: do not use the following unless you *know* C<off> is within
742 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
743 on the first byte of character or just after the last byte of a character.
749 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
751 PERL_ARGS_ASSERT_UTF8_HOP;
754 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
755 * the bitops (especially ~) can create illegal UTF-8.
756 * In other words: in Perl UTF-8 is not just for Unicode. */
765 while (UTF8_IS_CONTINUATION(*s))
773 =for apidoc utf8_to_bytes
775 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
776 Unlike C<bytes_to_utf8>, this over-writes the original string, and
777 updates len to contain the new length.
778 Returns zero on failure, setting C<len> to -1.
780 If you need a copy of the string, see C<bytes_from_utf8>.
786 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
789 U8 * const send = s + *len;
792 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
794 /* ensure valid UTF-8 and chars < 256 before updating string */
798 if (!UTF8_IS_INVARIANT(c) &&
799 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
800 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
801 *len = ((STRLEN) -1);
809 *d++ = (U8)utf8_to_uvchr(s, &ulen);
818 =for apidoc bytes_from_utf8
820 Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
821 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
822 the newly-created string, and updates C<len> to contain the new
823 length. Returns the original string if no conversion occurs, C<len>
824 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
825 0 if C<s> is converted or contains all 7bit characters.
831 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
838 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
844 /* ensure valid UTF-8 and chars < 256 before converting string */
845 for (send = s + *len; s < send;) {
847 if (!UTF8_IS_INVARIANT(c)) {
848 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
849 (c = *s++) && UTF8_IS_CONTINUATION(c))
858 Newx(d, (*len) - count + 1, U8);
859 s = start; start = d;
862 if (!UTF8_IS_INVARIANT(c)) {
863 /* Then it is two-byte encoded */
864 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
865 c = ASCII_TO_NATIVE(c);
875 =for apidoc bytes_to_utf8
877 Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
878 Returns a pointer to the newly-created string, and sets C<len> to
879 reflect the new length.
881 If you want to convert to UTF-8 from other encodings than ASCII,
882 see sv_recode_to_utf8().
888 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
890 const U8 * const send = s + (*len);
894 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
897 Newx(d, (*len) * 2 + 1, U8);
901 const UV uv = NATIVE_TO_ASCII(*s++);
902 if (UNI_IS_INVARIANT(uv))
903 *d++ = (U8)UTF_TO_NATIVE(uv);
905 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
906 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
915 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
917 * Destination must be pre-extended to 3/2 source. Do not use in-place.
918 * We optimize for native, for obvious reasons. */
921 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
926 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
928 if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
935 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
940 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
944 *d++ = UNI_TO_NATIVE(uv);
951 *d++ = (U8)(( uv >> 6) | 0xc0);
952 *d++ = (U8)(( uv & 0x3f) | 0x80);
955 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
956 UV low = (p[0] << 8) + p[1];
958 if (low < 0xdc00 || low >= 0xdfff)
959 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
960 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
963 *d++ = (U8)(( uv >> 12) | 0xe0);
964 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
965 *d++ = (U8)(( uv & 0x3f) | 0x80);
969 *d++ = (U8)(( uv >> 18) | 0xf0);
970 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
971 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
972 *d++ = (U8)(( uv & 0x3f) | 0x80);
976 *newlen = d - dstart;
980 /* Note: this one is slightly destructive of the source. */
983 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
986 U8* const send = s + bytelen;
988 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
996 return utf16_to_utf8(p, d, bytelen, newlen);
999 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1002 Perl_is_uni_alnum(pTHX_ UV c)
1004 U8 tmpbuf[UTF8_MAXBYTES+1];
1005 uvchr_to_utf8(tmpbuf, c);
1006 return is_utf8_alnum(tmpbuf);
1010 Perl_is_uni_alnumc(pTHX_ UV c)
1012 U8 tmpbuf[UTF8_MAXBYTES+1];
1013 uvchr_to_utf8(tmpbuf, c);
1014 return is_utf8_alnumc(tmpbuf);
1018 Perl_is_uni_idfirst(pTHX_ UV c)
1020 U8 tmpbuf[UTF8_MAXBYTES+1];
1021 uvchr_to_utf8(tmpbuf, c);
1022 return is_utf8_idfirst(tmpbuf);
1026 Perl_is_uni_alpha(pTHX_ UV c)
1028 U8 tmpbuf[UTF8_MAXBYTES+1];
1029 uvchr_to_utf8(tmpbuf, c);
1030 return is_utf8_alpha(tmpbuf);
1034 Perl_is_uni_ascii(pTHX_ UV c)
1036 U8 tmpbuf[UTF8_MAXBYTES+1];
1037 uvchr_to_utf8(tmpbuf, c);
1038 return is_utf8_ascii(tmpbuf);
1042 Perl_is_uni_space(pTHX_ UV c)
1044 U8 tmpbuf[UTF8_MAXBYTES+1];
1045 uvchr_to_utf8(tmpbuf, c);
1046 return is_utf8_space(tmpbuf);
1050 Perl_is_uni_digit(pTHX_ UV c)
1052 U8 tmpbuf[UTF8_MAXBYTES+1];
1053 uvchr_to_utf8(tmpbuf, c);
1054 return is_utf8_digit(tmpbuf);
1058 Perl_is_uni_upper(pTHX_ UV c)
1060 U8 tmpbuf[UTF8_MAXBYTES+1];
1061 uvchr_to_utf8(tmpbuf, c);
1062 return is_utf8_upper(tmpbuf);
1066 Perl_is_uni_lower(pTHX_ UV c)
1068 U8 tmpbuf[UTF8_MAXBYTES+1];
1069 uvchr_to_utf8(tmpbuf, c);
1070 return is_utf8_lower(tmpbuf);
1074 Perl_is_uni_cntrl(pTHX_ UV c)
1076 U8 tmpbuf[UTF8_MAXBYTES+1];
1077 uvchr_to_utf8(tmpbuf, c);
1078 return is_utf8_cntrl(tmpbuf);
1082 Perl_is_uni_graph(pTHX_ UV c)
1084 U8 tmpbuf[UTF8_MAXBYTES+1];
1085 uvchr_to_utf8(tmpbuf, c);
1086 return is_utf8_graph(tmpbuf);
1090 Perl_is_uni_print(pTHX_ UV c)
1092 U8 tmpbuf[UTF8_MAXBYTES+1];
1093 uvchr_to_utf8(tmpbuf, c);
1094 return is_utf8_print(tmpbuf);
1098 Perl_is_uni_punct(pTHX_ UV c)
1100 U8 tmpbuf[UTF8_MAXBYTES+1];
1101 uvchr_to_utf8(tmpbuf, c);
1102 return is_utf8_punct(tmpbuf);
1106 Perl_is_uni_xdigit(pTHX_ UV c)
1108 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1109 uvchr_to_utf8(tmpbuf, c);
1110 return is_utf8_xdigit(tmpbuf);
1114 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1116 PERL_ARGS_ASSERT_TO_UNI_UPPER;
1118 uvchr_to_utf8(p, c);
1119 return to_utf8_upper(p, p, lenp);
1123 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1125 PERL_ARGS_ASSERT_TO_UNI_TITLE;
1127 uvchr_to_utf8(p, c);
1128 return to_utf8_title(p, p, lenp);
1132 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1134 PERL_ARGS_ASSERT_TO_UNI_LOWER;
1136 uvchr_to_utf8(p, c);
1137 return to_utf8_lower(p, p, lenp);
1141 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1143 PERL_ARGS_ASSERT_TO_UNI_FOLD;
1145 uvchr_to_utf8(p, c);
1146 return to_utf8_fold(p, p, lenp);
1149 /* for now these all assume no locale info available for Unicode > 255 */
1152 Perl_is_uni_alnum_lc(pTHX_ UV c)
1154 return is_uni_alnum(c); /* XXX no locale support yet */
1158 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1160 return is_uni_alnumc(c); /* XXX no locale support yet */
1164 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1166 return is_uni_idfirst(c); /* XXX no locale support yet */
1170 Perl_is_uni_alpha_lc(pTHX_ UV c)
1172 return is_uni_alpha(c); /* XXX no locale support yet */
1176 Perl_is_uni_ascii_lc(pTHX_ UV c)
1178 return is_uni_ascii(c); /* XXX no locale support yet */
1182 Perl_is_uni_space_lc(pTHX_ UV c)
1184 return is_uni_space(c); /* XXX no locale support yet */
1188 Perl_is_uni_digit_lc(pTHX_ UV c)
1190 return is_uni_digit(c); /* XXX no locale support yet */
1194 Perl_is_uni_upper_lc(pTHX_ UV c)
1196 return is_uni_upper(c); /* XXX no locale support yet */
1200 Perl_is_uni_lower_lc(pTHX_ UV c)
1202 return is_uni_lower(c); /* XXX no locale support yet */
1206 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1208 return is_uni_cntrl(c); /* XXX no locale support yet */
1212 Perl_is_uni_graph_lc(pTHX_ UV c)
1214 return is_uni_graph(c); /* XXX no locale support yet */
1218 Perl_is_uni_print_lc(pTHX_ UV c)
1220 return is_uni_print(c); /* XXX no locale support yet */
1224 Perl_is_uni_punct_lc(pTHX_ UV c)
1226 return is_uni_punct(c); /* XXX no locale support yet */
1230 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1232 return is_uni_xdigit(c); /* XXX no locale support yet */
1236 Perl_to_uni_upper_lc(pTHX_ U32 c)
1238 /* XXX returns only the first character -- do not use XXX */
1239 /* XXX no locale support yet */
1241 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1242 return (U32)to_uni_upper(c, tmpbuf, &len);
1246 Perl_to_uni_title_lc(pTHX_ U32 c)
1248 /* XXX returns only the first character XXX -- do not use XXX */
1249 /* XXX no locale support yet */
1251 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1252 return (U32)to_uni_title(c, tmpbuf, &len);
1256 Perl_to_uni_lower_lc(pTHX_ U32 c)
1258 /* XXX returns only the first character -- do not use XXX */
1259 /* XXX no locale support yet */
1261 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1262 return (U32)to_uni_lower(c, tmpbuf, &len);
1266 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1267 const char *const swashname)
1271 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1273 if (!is_utf8_char(p))
1276 *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1277 return swash_fetch(*swash, p, TRUE) != 0;
1281 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1285 PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1287 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1288 * descendant of isalnum(3), in other words, it doesn't
1289 * contain the '_'. --jhi */
1290 return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1294 Perl_is_utf8_alnumc(pTHX_ const U8 *p)
1298 PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
1300 return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnumC");
1304 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1308 PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1312 /* is_utf8_idstart would be more logical. */
1313 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1317 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1321 PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1325 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1329 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1333 PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1335 return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1339 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1343 PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1345 return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1349 Perl_is_utf8_space(pTHX_ const U8 *p)
1353 PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1355 return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1359 Perl_is_utf8_digit(pTHX_ const U8 *p)
1363 PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1365 return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1369 Perl_is_utf8_upper(pTHX_ const U8 *p)
1373 PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1375 return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1379 Perl_is_utf8_lower(pTHX_ const U8 *p)
1383 PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1385 return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1389 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1393 PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1395 return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1399 Perl_is_utf8_graph(pTHX_ const U8 *p)
1403 PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1405 return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1409 Perl_is_utf8_print(pTHX_ const U8 *p)
1413 PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1415 return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1419 Perl_is_utf8_punct(pTHX_ const U8 *p)
1423 PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1425 return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1429 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1433 PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1435 return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
1439 Perl_is_utf8_mark(pTHX_ const U8 *p)
1443 PERL_ARGS_ASSERT_IS_UTF8_MARK;
1445 return is_utf8_common(p, &PL_utf8_mark, "IsM");
1449 =for apidoc to_utf8_case
1451 The "p" contains the pointer to the UTF-8 string encoding
1452 the character that is being converted.
1454 The "ustrp" is a pointer to the character buffer to put the
1455 conversion result to. The "lenp" is a pointer to the length
1458 The "swashp" is a pointer to the swash to use.
1460 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1461 and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
1462 but not always, a multicharacter mapping), is tried first.
1464 The "special" is a string like "utf8::ToSpecLower", which means the
1465 hash %utf8::ToSpecLower. The access to the hash is through
1466 Perl_to_utf8_case().
1468 The "normal" is a string like "ToLower" which means the swash
1474 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1475 SV **swashp, const char *normal, const char *special)
1478 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1480 const UV uv0 = utf8_to_uvchr(p, NULL);
1481 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1482 * are necessary in EBCDIC, they are redundant no-ops
1483 * in ASCII-ish platforms, and hopefully optimized away. */
1484 const UV uv1 = NATIVE_TO_UNI(uv0);
1486 PERL_ARGS_ASSERT_TO_UTF8_CASE;
1488 uvuni_to_utf8(tmpbuf, uv1);
1490 if (!*swashp) /* load on-demand */
1491 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1493 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1494 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1495 /* It might be "special" (sometimes, but not always,
1496 * a multicharacter mapping) */
1497 HV * const hv = get_hv(special, FALSE);
1501 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1505 s = SvPV_const(*svp, len);
1507 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1510 /* If we have EBCDIC we need to remap the characters
1511 * since any characters in the low 256 are Unicode
1512 * code points, not EBCDIC. */
1513 U8 *t = (U8*)s, *tend = t + len, *d;
1520 const UV c = utf8_to_uvchr(t, &tlen);
1522 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1531 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1536 Copy(tmpbuf, ustrp, len, U8);
1538 Copy(s, ustrp, len, U8);
1544 if (!len && *swashp) {
1545 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1548 /* It was "normal" (a single character mapping). */
1549 const UV uv3 = UNI_TO_NATIVE(uv2);
1550 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1554 if (!len) /* Neither: just copy. */
1555 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1560 return len ? utf8_to_uvchr(ustrp, 0) : 0;
1564 =for apidoc to_utf8_upper
1566 Convert the UTF-8 encoded character at p to its uppercase version and
1567 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1568 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1569 the uppercase version may be longer than the original character.
1571 The first character of the uppercased version is returned
1572 (but note, as explained above, that there may be more.)
1577 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1581 PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1583 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1584 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1588 =for apidoc to_utf8_title
1590 Convert the UTF-8 encoded character at p to its titlecase version and
1591 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1592 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1593 titlecase version may be longer than the original character.
1595 The first character of the titlecased version is returned
1596 (but note, as explained above, that there may be more.)
1601 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1605 PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1607 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1608 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1612 =for apidoc to_utf8_lower
1614 Convert the UTF-8 encoded character at p to its lowercase version and
1615 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1616 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1617 lowercase version may be longer than the original character.
1619 The first character of the lowercased version is returned
1620 (but note, as explained above, that there may be more.)
1625 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1629 PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1631 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1632 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1636 =for apidoc to_utf8_fold
1638 Convert the UTF-8 encoded character at p to its foldcase version and
1639 store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1640 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1641 foldcase version may be longer than the original character (up to
1644 The first character of the foldcased version is returned
1645 (but note, as explained above, that there may be more.)
1650 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1654 PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1656 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1657 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1661 * A "swash" is a swatch hash.
1662 * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1663 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1664 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1667 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
1672 const size_t pkg_len = strlen(pkg);
1673 const size_t name_len = strlen(name);
1674 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
1677 PERL_ARGS_ASSERT_SWASH_INIT;
1679 PUSHSTACKi(PERLSI_MAGIC);
1684 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
1686 errsv_save = newSVsv(ERRSV);
1687 /* It is assumed that callers of this routine are not passing in any
1688 user derived data. */
1689 /* Need to do this after save_re_context() as it will set PL_tainted to
1690 1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1691 Even line to create errsv_save can turn on PL_tainted. */
1692 SAVEBOOL(PL_tainted);
1694 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1697 sv_setsv(ERRSV, errsv_save);
1698 SvREFCNT_dec(errsv_save);
1704 mPUSHp(pkg, pkg_len);
1705 mPUSHp(name, name_len);
1710 errsv_save = newSVsv(ERRSV);
1711 if (call_method("SWASHNEW", G_SCALAR))
1712 retval = newSVsv(*PL_stack_sp--);
1714 retval = &PL_sv_undef;
1716 sv_setsv(ERRSV, errsv_save);
1717 SvREFCNT_dec(errsv_save);
1720 if (IN_PERL_COMPILETIME) {
1721 CopHINTS_set(PL_curcop, PL_hints);
1723 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1725 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1727 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1733 /* This API is wrong for special case conversions since we may need to
1734 * return several Unicode characters for a single Unicode character
1735 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1736 * the lower-level routine, and it is similarly broken for returning
1737 * multiple values. --jhi */
1738 /* Now SWASHGET is recasted into S_swash_get in this file. */
1741 * Returns the value of property/mapping C<swash> for the first character
1742 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1743 * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1744 * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1747 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
1750 HV *const hv = MUTABLE_HV(SvRV(swash));
1755 const U8 *tmps = NULL;
1759 const UV c = NATIVE_TO_ASCII(*ptr);
1761 PERL_ARGS_ASSERT_SWASH_FETCH;
1763 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1764 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1765 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1768 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1769 * then the "swatch" is a vec() for al the chars which start
1771 * So the key in the hash (klen) is length of encoded char -1
1773 klen = UTF8SKIP(ptr) - 1;
1777 /* If char in invariant then swatch is for all the invariant chars
1778 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1780 needents = UTF_CONTINUATION_MARK;
1781 off = NATIVE_TO_UTF(ptr[klen]);
1784 /* If char is encoded then swatch is for the prefix */
1785 needents = (1 << UTF_ACCUMULATION_SHIFT);
1786 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1790 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1791 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1792 * it's nothing to sniff at.) Pity we usually come through at least
1793 * two function calls to get here...
1795 * NB: this code assumes that swatches are never modified, once generated!
1798 if (hv == PL_last_swash_hv &&
1799 klen == PL_last_swash_klen &&
1800 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1802 tmps = PL_last_swash_tmps;
1803 slen = PL_last_swash_slen;
1806 /* Try our second-level swatch cache, kept in a hash. */
1807 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
1809 /* If not cached, generate it via swash_get */
1810 if (!svp || !SvPOK(*svp)
1811 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
1812 /* We use utf8n_to_uvuni() as we want an index into
1813 Unicode tables, not a native character number.
1815 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
1817 0 : UTF8_ALLOW_ANY);
1818 swatch = swash_get(swash,
1819 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1820 (klen) ? (code_point & ~(needents - 1)) : 0,
1823 if (IN_PERL_COMPILETIME)
1824 CopHINTS_set(PL_curcop, PL_hints);
1826 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
1828 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1829 || (slen << 3) < needents)
1830 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
1833 PL_last_swash_hv = hv;
1834 assert(klen <= sizeof(PL_last_swash_key));
1835 PL_last_swash_klen = (U8)klen;
1836 /* FIXME change interpvar.h? */
1837 PL_last_swash_tmps = (U8 *) tmps;
1838 PL_last_swash_slen = slen;
1840 Copy(ptr, PL_last_swash_key, klen, U8);
1843 switch ((int)((slen << 3) / needents)) {
1845 bit = 1 << (off & 7);
1847 return (tmps[off] & bit) != 0;
1852 return (tmps[off] << 8) + tmps[off + 1] ;
1855 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1857 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
1858 NORETURN_FUNCTION_END;
1862 * Returns a swatch (a bit vector string) for a code point sequence
1863 * that starts from the value C<start> and comprises the number C<span>.
1864 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1865 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1868 S_swash_get(pTHX_ SV* swash, UV start, UV span)
1871 U8 *l, *lend, *x, *xend, *s;
1872 STRLEN lcur, xcur, scur;
1873 HV *const hv = MUTABLE_HV(SvRV(swash));
1874 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1875 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1876 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1877 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1878 SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
1879 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1880 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
1881 const STRLEN bits = SvUV(*bitssvp);
1882 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1883 const UV none = SvUV(*nonesvp);
1884 const UV end = start + span;
1886 PERL_ARGS_ASSERT_SWASH_GET;
1888 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1889 Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1893 /* create and initialize $swatch */
1894 scur = octets ? (span * octets) : (span + 7) / 8;
1895 swatch = newSV(scur);
1897 s = (U8*)SvPVX(swatch);
1898 if (octets && none) {
1899 const U8* const e = s + scur;
1902 *s++ = (U8)(none & 0xff);
1903 else if (bits == 16) {
1904 *s++ = (U8)((none >> 8) & 0xff);
1905 *s++ = (U8)( none & 0xff);
1907 else if (bits == 32) {
1908 *s++ = (U8)((none >> 24) & 0xff);
1909 *s++ = (U8)((none >> 16) & 0xff);
1910 *s++ = (U8)((none >> 8) & 0xff);
1911 *s++ = (U8)( none & 0xff);
1917 (void)memzero((U8*)s, scur + 1);
1919 SvCUR_set(swatch, scur);
1920 s = (U8*)SvPVX(swatch);
1922 /* read $swash->{LIST} */
1923 l = (U8*)SvPV(*listsvp, lcur);
1928 I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1930 U8* const nl = (U8*)memchr(l, '\n', lend - l);
1933 min = grok_hex((char *)l, &numlen, &flags, NULL);
1937 l = nl + 1; /* 1 is length of "\n" */
1941 l = lend; /* to LIST's end at which \n is not found */
1947 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1949 max = grok_hex((char *)l, &numlen, &flags, NULL);
1958 flags = PERL_SCAN_SILENT_ILLDIGIT |
1959 PERL_SCAN_DISALLOW_PREFIX;
1961 val = grok_hex((char *)l, &numlen, &flags, NULL);
1970 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1976 val = 0; /* bits == 1, then val should be ignored */
1983 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1987 val = 0; /* bits == 1, then val should be ignored */
2001 if (!none || val < none) {
2006 for (key = min; key <= max; key++) {
2010 /* offset must be non-negative (start <= min <= key < end) */
2011 offset = octets * (key - start);
2013 s[offset] = (U8)(val & 0xff);
2014 else if (bits == 16) {
2015 s[offset ] = (U8)((val >> 8) & 0xff);
2016 s[offset + 1] = (U8)( val & 0xff);
2018 else if (bits == 32) {
2019 s[offset ] = (U8)((val >> 24) & 0xff);
2020 s[offset + 1] = (U8)((val >> 16) & 0xff);
2021 s[offset + 2] = (U8)((val >> 8) & 0xff);
2022 s[offset + 3] = (U8)( val & 0xff);
2025 if (!none || val < none)
2029 else { /* bits == 1, then val should be ignored */
2033 for (key = min; key <= max; key++) {
2034 const STRLEN offset = (STRLEN)(key - start);
2037 s[offset >> 3] |= 1 << (offset & 7);
2043 /* read $swash->{EXTRAS} */
2044 x = (U8*)SvPV(*extssvp, xcur);
2052 SV **otherbitssvp, *other;
2056 const U8 opc = *x++;
2060 nl = (U8*)memchr(x, '\n', xend - x);
2062 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2064 x = nl + 1; /* 1 is length of "\n" */
2068 x = xend; /* to EXTRAS' end at which \n is not found */
2075 namelen = nl - namestr;
2079 namelen = xend - namestr;
2083 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2084 otherhv = MUTABLE_HV(SvRV(*othersvp));
2085 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2086 otherbits = (STRLEN)SvUV(*otherbitssvp);
2087 if (bits < otherbits)
2088 Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2090 /* The "other" swatch must be destroyed after. */
2091 other = swash_get(*othersvp, start, span);
2092 o = (U8*)SvPV(other, olen);
2095 Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2097 s = (U8*)SvPV(swatch, slen);
2098 if (bits == 1 && otherbits == 1) {
2100 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2124 STRLEN otheroctets = otherbits >> 3;
2126 U8* const send = s + slen;
2131 if (otherbits == 1) {
2132 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2136 STRLEN vlen = otheroctets;
2144 if (opc == '+' && otherval)
2145 NOOP; /* replace with otherval */
2146 else if (opc == '!' && !otherval)
2148 else if (opc == '-' && otherval)
2150 else if (opc == '&' && !otherval)
2153 s += octets; /* no replacement */
2158 *s++ = (U8)( otherval & 0xff);
2159 else if (bits == 16) {
2160 *s++ = (U8)((otherval >> 8) & 0xff);
2161 *s++ = (U8)( otherval & 0xff);
2163 else if (bits == 32) {
2164 *s++ = (U8)((otherval >> 24) & 0xff);
2165 *s++ = (U8)((otherval >> 16) & 0xff);
2166 *s++ = (U8)((otherval >> 8) & 0xff);
2167 *s++ = (U8)( otherval & 0xff);
2171 sv_free(other); /* through with it! */
2177 =for apidoc uvchr_to_utf8
2179 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2180 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2181 bytes available. The return value is the pointer to the byte after the
2182 end of the new character. In other words,
2184 d = uvchr_to_utf8(d, uv);
2186 is the recommended wide native character-aware way of saying
2193 /* On ASCII machines this is normally a macro but we want a
2194 real function in case XS code wants it
2197 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2199 PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2201 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2205 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2207 PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2209 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2213 =for apidoc utf8n_to_uvchr
2216 Returns the native character value of the first character in the string
2218 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2219 length, in bytes, of that character.
2221 Allows length and flags to be passed to low level routine.
2225 /* On ASCII machines this is normally a macro but we want
2226 a real function in case XS code wants it
2229 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2232 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2234 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2236 return UNI_TO_NATIVE(uv);
2240 =for apidoc pv_uni_display
2242 Build to the scalar dsv a displayable version of the string spv,
2243 length len, the displayable version being at most pvlim bytes long
2244 (if longer, the rest is truncated and "..." will be appended).
2246 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2247 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2248 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2249 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2250 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2251 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2253 The pointer to the PV of the dsv is returned.
2257 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2262 PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2266 for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2268 /* This serves double duty as a flag and a character to print after
2269 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2273 if (pvlim && SvCUR(dsv) >= pvlim) {
2277 u = utf8_to_uvchr((U8*)s, 0);
2279 const unsigned char c = (unsigned char)u & 0xFF;
2280 if (flags & UNI_DISPLAY_BACKSLASH) {
2297 const char string = ok;
2298 sv_catpvs(dsv, "\\");
2299 sv_catpvn(dsv, &string, 1);
2302 /* isPRINT() is the locale-blind version. */
2303 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2304 const char string = c;
2305 sv_catpvn(dsv, &string, 1);
2310 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2313 sv_catpvs(dsv, "...");
2319 =for apidoc sv_uni_display
2321 Build to the scalar dsv a displayable version of the scalar sv,
2322 the displayable version being at most pvlim bytes long
2323 (if longer, the rest is truncated and "..." will be appended).
2325 The flags argument is as in pv_uni_display().
2327 The pointer to the PV of the dsv is returned.
2332 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2334 PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2336 return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2337 SvCUR(ssv), pvlim, flags);
2341 =for apidoc ibcmp_utf8
2343 Return true if the strings s1 and s2 differ case-insensitively, false
2344 if not (if they are equal case-insensitively). If u1 is true, the
2345 string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
2346 the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
2347 are false, the respective string is assumed to be in native 8-bit
2350 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2351 in there (they will point at the beginning of the I<next> character).
2352 If the pointers behind pe1 or pe2 are non-NULL, they are the end
2353 pointers beyond which scanning will not continue under any
2354 circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
2355 s2+l2 will be used as goal end pointers that will also stop the scan,
2356 and which qualify towards defining a successful match: all the scans
2357 that define an explicit length must reach their goal pointers for
2358 a match to succeed).
2360 For case-insensitiveness, the "casefolding" of Unicode is used
2361 instead of upper/lowercasing both the characters, see
2362 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2366 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2369 register const U8 *p1 = (const U8*)s1;
2370 register const U8 *p2 = (const U8*)s2;
2371 register const U8 *f1 = NULL;
2372 register const U8 *f2 = NULL;
2373 register U8 *e1 = NULL;
2374 register U8 *q1 = NULL;
2375 register U8 *e2 = NULL;
2376 register U8 *q2 = NULL;
2377 STRLEN n1 = 0, n2 = 0;
2378 U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2379 U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2381 STRLEN foldlen1, foldlen2;
2384 PERL_ARGS_ASSERT_IBCMP_UTF8;
2388 /* assert(e1 || l1); */
2389 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2390 f1 = (const U8*)s1 + l1;
2393 /* assert(e2 || l2); */
2394 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2395 f2 = (const U8*)s2 + l2;
2397 /* This shouldn't happen. However, putting an assert() there makes some
2399 /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
2400 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2401 return 1; /* mismatch; possible infinite loop or false positive */
2404 natbuf[1] = 0; /* Need to terminate the buffer. */
2406 while ((e1 == 0 || p1 < e1) &&
2407 (f1 == 0 || p1 < f1) &&
2408 (e2 == 0 || p2 < e2) &&
2409 (f2 == 0 || p2 < f2)) {
2412 to_utf8_fold(p1, foldbuf1, &foldlen1);
2414 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2415 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2422 to_utf8_fold(p2, foldbuf2, &foldlen2);
2424 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2425 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2431 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2432 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2433 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
2434 return 1; /* mismatch */
2441 p1 += u1 ? UTF8SKIP(p1) : 1;
2443 p2 += u2 ? UTF8SKIP(p2) : 1;
2447 /* A match is defined by all the scans that specified
2448 * an explicit length reaching their final goals. */
2449 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
2458 return match ? 0 : 1; /* 0 match, 1 mismatch */
2463 * c-indentation-style: bsd
2465 * indent-tabs-mode: t
2468 * ex: set ts=8 sts=4 sw=4 noet: