This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't use EBCDIC macro for a C language escape
[perl5.git] / utf8.c
CommitLineData
a0ed51b3
LW
1/* utf8.c
2 *
1129b882 3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
b94e2f88 4 * by Larry Wall and others
a0ed51b3
LW
5 *
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.
8 *
9 */
10
11/*
4ac71550
TC
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.'
15 *
cdad3b53 16 * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
a0ed51b3
LW
17 *
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,
4ac71550 20 * as is the custom in the West, if you wish to be answered?'
cdad3b53 21 * --Gandalf, addressing Théoden's door wardens
4ac71550
TC
22 *
23 * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
24 *
25 * ...the travellers perceived that the floor was paved with stones of many
26 * hues; branching runes and strange devices intertwined beneath their feet.
4ac71550
TC
27 *
28 * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
29 */
30
31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_UTF8_C
a0ed51b3 33#include "perl.h"
81e983c1 34#include "inline_invlist.c"
a0ed51b3 35
a0c21aa1 36#ifndef EBCDIC
970ea3cb 37/* Separate prototypes needed because in ASCII systems these are
a0c21aa1
JH
38 * usually macros but they still are compiled as code, too. */
39PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
6dd9dce9 40PERL_CALLCONV UV Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen);
a0c21aa1
JH
41PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
42#endif
43
27da23d5
JH
44static const char unees[] =
45 "Malformed UTF-8 character (unexpected end of string)";
901b21bf 46
48ef279e 47/*
ccfc67b7 48=head1 Unicode Support
a0ed51b3 49
166f8a29
DM
50This file contains various utility functions for manipulating UTF8-encoded
51strings. For the uninitiated, this is a method of representing arbitrary
61296642 52Unicode characters as a variable number of bytes, in such a way that
56da48f7
DM
53characters in the ASCII range are unmodified, and a zero byte never appears
54within non-zero characters.
166f8a29 55
eaf7a4d2
CS
56=cut
57*/
58
59/*
60=for apidoc is_ascii_string
61
a1433954 62Returns true if the first C<len> bytes of the string C<s> are the same whether
970ea3cb
KW
63or not the string is encoded in UTF-8 (or UTF-EBCDIC on EBCDIC machines). That
64is, if they are invariant. On ASCII-ish machines, only ASCII characters
65fit this definition, hence the function's name.
eaf7a4d2 66
9f7e3d64
MH
67If C<len> is 0, it will be calculated using C<strlen(s)>.
68
a1433954 69See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
eaf7a4d2
CS
70
71=cut
72*/
73
74bool
668b6d8d 75Perl_is_ascii_string(const U8 *s, STRLEN len)
eaf7a4d2
CS
76{
77 const U8* const send = s + (len ? len : strlen((const char *)s));
78 const U8* x = s;
79
80 PERL_ARGS_ASSERT_IS_ASCII_STRING;
eaf7a4d2
CS
81
82 for (; x < send; ++x) {
83 if (!UTF8_IS_INVARIANT(*x))
84 break;
85 }
86
87 return x == send;
88}
89
90/*
87cea99e 91=for apidoc uvuni_to_utf8_flags
eebe1485 92
537124e4 93Adds the UTF-8 representation of the Unicode code point C<uv> to the end
6ee84de2 94of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
eebe1485 95bytes available. The return value is the pointer to the byte after the
9041c2e3 96end of the new character. In other words,
eebe1485 97
b851fbc1
JH
98 d = uvuni_to_utf8_flags(d, uv, flags);
99
100or, in most cases,
101
9041c2e3 102 d = uvuni_to_utf8(d, uv);
eebe1485 103
b851fbc1
JH
104(which is equivalent to)
105
106 d = uvuni_to_utf8_flags(d, uv, 0);
107
949cf498 108This is the recommended Unicode-aware way of saying
eebe1485
SC
109
110 *(d++) = uv;
111
537124e4
KW
112where uv is a code point expressed in Latin-1 or above, not the platform's
113native character set. B<Almost all code should instead use L</uvchr_to_utf8>
114or L</uvchr_to_utf8_flags>>.
115
949cf498
KW
116This function will convert to UTF-8 (and not warn) even code points that aren't
117legal Unicode or are problematic, unless C<flags> contains one or more of the
a1433954
KW
118following flags:
119
949cf498
KW
120If C<uv> is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set,
121the function will raise a warning, provided UTF8 warnings are enabled. If instead
122UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL.
123If both flags are set, the function will both warn and return NULL.
124
125The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags correspondingly
537124e4
KW
126affect how the function handles a Unicode non-character. And likewise, the
127UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, affect the handling of
128code points that are
949cf498
KW
129above the Unicode maximum of 0x10FFFF. Code points above 0x7FFF_FFFF (which are
130even less portable) can be warned and/or disallowed even if other above-Unicode
131code points are accepted by the UNICODE_WARN_FE_FF and UNICODE_DISALLOW_FE_FF
132flags.
133
134And finally, the flag UNICODE_WARN_ILLEGAL_INTERCHANGE selects all four of the
135above WARN flags; and UNICODE_DISALLOW_ILLEGAL_INTERCHANGE selects all four
136DISALLOW flags.
137
138
eebe1485
SC
139=cut
140*/
141
dfe13c55 142U8 *
b851fbc1 143Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
a0ed51b3 144{
7918f24d
NC
145 PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
146
979f77b6
KW
147 /* The first problematic code point is the first surrogate */
148 if (uv >= UNICODE_SURROGATE_FIRST
149 && ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
150 {
949cf498
KW
151 if (UNICODE_IS_SURROGATE(uv)) {
152 if (flags & UNICODE_WARN_SURROGATE) {
8457b38f 153 Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),
949cf498
KW
154 "UTF-16 surrogate U+%04"UVXf, uv);
155 }
156 if (flags & UNICODE_DISALLOW_SURROGATE) {
157 return NULL;
158 }
159 }
160 else if (UNICODE_IS_SUPER(uv)) {
161 if (flags & UNICODE_WARN_SUPER
162 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_WARN_FE_FF)))
163 {
8457b38f 164 Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE),
949cf498
KW
165 "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
166 }
167 if (flags & UNICODE_DISALLOW_SUPER
168 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF)))
169 {
170 return NULL;
171 }
172 }
173 else if (UNICODE_IS_NONCHAR(uv)) {
174 if (flags & UNICODE_WARN_NONCHAR) {
8457b38f 175 Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),
949cf498
KW
176 "Unicode non-character U+%04"UVXf" is illegal for open interchange",
177 uv);
178 }
179 if (flags & UNICODE_DISALLOW_NONCHAR) {
180 return NULL;
181 }
182 }
507b9800 183 }
c4d5f83a 184 if (UNI_IS_INVARIANT(uv)) {
bc3632a8 185 *d++ = (U8) I8_TO_NATIVE_UTF8(uv);
a0ed51b3
LW
186 return d;
187 }
2d331972 188#if defined(EBCDIC)
1d72bdf6
NIS
189 else {
190 STRLEN len = UNISKIP(uv);
191 U8 *p = d+len-1;
192 while (p > d) {
bc3632a8 193 *p-- = (U8) I8_TO_NATIVE_UTF8((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1d72bdf6
NIS
194 uv >>= UTF_ACCUMULATION_SHIFT;
195 }
bc3632a8 196 *p = (U8) I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1d72bdf6
NIS
197 return d+len;
198 }
199#else /* Non loop style */
a0ed51b3 200 if (uv < 0x800) {
eb160463
GS
201 *d++ = (U8)(( uv >> 6) | 0xc0);
202 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
203 return d;
204 }
205 if (uv < 0x10000) {
eb160463
GS
206 *d++ = (U8)(( uv >> 12) | 0xe0);
207 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
208 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
209 return d;
210 }
211 if (uv < 0x200000) {
eb160463
GS
212 *d++ = (U8)(( uv >> 18) | 0xf0);
213 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
214 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
215 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
216 return d;
217 }
218 if (uv < 0x4000000) {
eb160463
GS
219 *d++ = (U8)(( uv >> 24) | 0xf8);
220 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
221 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
222 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
223 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
224 return d;
225 }
226 if (uv < 0x80000000) {
eb160463
GS
227 *d++ = (U8)(( uv >> 30) | 0xfc);
228 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
229 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
230 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
231 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
232 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
233 return d;
234 }
6b8eaf93 235#ifdef HAS_QUAD
d7578b48 236 if (uv < UTF8_QUAD_MAX)
a0ed51b3
LW
237#endif
238 {
eb160463
GS
239 *d++ = 0xfe; /* Can't match U+FEFF! */
240 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
241 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
242 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
243 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
244 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
245 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
246 return d;
247 }
6b8eaf93 248#ifdef HAS_QUAD
a0ed51b3 249 {
eb160463
GS
250 *d++ = 0xff; /* Can't match U+FFFE! */
251 *d++ = 0x80; /* 6 Reserved bits */
252 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
253 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
254 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
255 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
256 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
257 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
258 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
259 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
260 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
261 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
262 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
263 return d;
264 }
265#endif
537124e4 266#endif /* Non loop style */
a0ed51b3 267}
9041c2e3 268
646ca15d
JH
269/*
270
f7d739d1 271Tests if the first C<len> bytes of string C<s> form a valid UTF-8
646ca15d 272character. Note that an INVARIANT (i.e. ASCII) character is a valid
f7d739d1 273UTF-8 character. The number of bytes in the UTF-8 character
646ca15d
JH
274will be returned if it is valid, otherwise 0.
275
276This is the "slow" version as opposed to the "fast" version which is
277the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed
278difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four
279or less you should use the IS_UTF8_CHAR(), for lengths of five or more
280you should use the _slow(). In practice this means that the _slow()
281will be used very rarely, since the maximum Unicode code point (as of
282Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
537124e4 283the "Perl extended UTF-8" (e.g, the infamous 'v-strings') will encode into
646ca15d
JH
284five bytes or more.
285
286=cut */
7af276bc 287PERL_STATIC_INLINE STRLEN
5f66b61c 288S_is_utf8_char_slow(const U8 *s, const STRLEN len)
646ca15d 289{
cd7e6c88 290 dTHX; /* The function called below requires thread context */
646ca15d 291
cd7e6c88 292 STRLEN actual_len;
646ca15d 293
cd7e6c88 294 PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
646ca15d 295
18712bce 296 utf8n_to_uvchr(s, len, &actual_len, UTF8_CHECK_ONLY);
646ca15d 297
cd7e6c88 298 return (actual_len == (STRLEN) -1) ? 0 : actual_len;
646ca15d 299}
9041c2e3
NIS
300
301/*
492a624f
KW
302=for apidoc is_utf8_char_buf
303
304Returns the number of bytes that comprise the first UTF-8 encoded character in
305buffer C<buf>. C<buf_end> should point to one position beyond the end of the
306buffer. 0 is returned if C<buf> does not point to a complete, valid UTF-8
307encoded character.
308
309Note that an INVARIANT character (i.e. ASCII on non-EBCDIC
310machines) is a valid UTF-8 character.
311
312=cut */
313
314STRLEN
315Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end)
316{
317
318 STRLEN len;
319
320 PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF;
321
322 if (buf_end <= buf) {
323 return 0;
324 }
325
326 len = buf_end - buf;
327 if (len > UTF8SKIP(buf)) {
328 len = UTF8SKIP(buf);
329 }
330
331#ifdef IS_UTF8_CHAR
332 if (IS_UTF8_CHAR_FAST(len))
333 return IS_UTF8_CHAR(buf, len) ? len : 0;
334#endif /* #ifdef IS_UTF8_CHAR */
335 return is_utf8_char_slow(buf, len);
336}
337
338/*
87cea99e 339=for apidoc is_utf8_char
eebe1485 340
5da9da9e 341Tests if some arbitrary number of bytes begins in a valid UTF-8
2bbc8d55
SP
342character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
343character is a valid UTF-8 character. The actual number of bytes in the UTF-8
344character will be returned if it is valid, otherwise 0.
9041c2e3 345
76848387 346This function is deprecated due to the possibility that malformed input could
a1433954 347cause reading beyond the end of the input buffer. Use L</is_utf8_char_buf>
76848387 348instead.
e0328548 349
82686b01 350=cut */
76848387 351
067a85ef 352STRLEN
668b6d8d 353Perl_is_utf8_char(const U8 *s)
386d01d6 354{
7918f24d 355 PERL_ARGS_ASSERT_IS_UTF8_CHAR;
492a624f 356
76848387 357 /* Assumes we have enough space, which is why this is deprecated */
492a624f 358 return is_utf8_char_buf(s, s + UTF8SKIP(s));
386d01d6
GS
359}
360
eaf7a4d2 361
6662521e 362/*
87cea99e 363=for apidoc is_utf8_string
6662521e 364
a1433954 365Returns true if the first C<len> bytes of string C<s> form a valid
9f7e3d64 366UTF-8 string, false otherwise. If C<len> is 0, it will be calculated
e0328548
KW
367using C<strlen(s)> (which means if you use this option, that C<s> has to have a
368terminating NUL byte). Note that all characters being ASCII constitute 'a
369valid UTF-8 string'.
6662521e 370
a1433954 371See also L</is_ascii_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
768c67ee 372
6662521e
GS
373=cut
374*/
375
8e84507e 376bool
668b6d8d 377Perl_is_utf8_string(const U8 *s, STRLEN len)
6662521e 378{
35da51f7 379 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 380 const U8* x = s;
067a85ef 381
7918f24d 382 PERL_ARGS_ASSERT_IS_UTF8_STRING;
1aa99e6b 383
6662521e 384 while (x < send) {
1acdb0da 385 /* Inline the easy bits of is_utf8_char() here for speed... */
e0328548
KW
386 if (UTF8_IS_INVARIANT(*x)) {
387 x++;
388 }
1acdb0da
JH
389 else {
390 /* ... and call is_utf8_char() only if really needed. */
e0328548
KW
391 const STRLEN c = UTF8SKIP(x);
392 const U8* const next_char_ptr = x + c;
393
394 if (next_char_ptr > send) {
395 return FALSE;
396 }
397
768c67ee
JH
398 if (IS_UTF8_CHAR_FAST(c)) {
399 if (!IS_UTF8_CHAR(x, c))
e0328548 400 return FALSE;
3c614e38 401 }
e0328548
KW
402 else if (! is_utf8_char_slow(x, c)) {
403 return FALSE;
404 }
405 x = next_char_ptr;
1acdb0da 406 }
6662521e 407 }
768c67ee 408
067a85ef 409 return TRUE;
6662521e
GS
410}
411
67e989fb 412/*
814fafa7
NC
413Implemented as a macro in utf8.h
414
87cea99e 415=for apidoc is_utf8_string_loc
814fafa7 416
a1433954
KW
417Like L</is_utf8_string> but stores the location of the failure (in the
418case of "utf8ness failure") or the location C<s>+C<len> (in the case of
814fafa7
NC
419"utf8ness success") in the C<ep>.
420
a1433954 421See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
814fafa7 422
87cea99e 423=for apidoc is_utf8_string_loclen
81cd54e3 424
a1433954
KW
425Like L</is_utf8_string>() but stores the location of the failure (in the
426case of "utf8ness failure") or the location C<s>+C<len> (in the case of
768c67ee
JH
427"utf8ness success") in the C<ep>, and the number of UTF-8
428encoded characters in the C<el>.
429
a1433954 430See also L</is_utf8_string_loc>() and L</is_utf8_string>().
81cd54e3
JH
431
432=cut
433*/
434
435bool
668b6d8d 436Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
81cd54e3 437{
35da51f7 438 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 439 const U8* x = s;
81cd54e3 440 STRLEN c;
3ebfea28 441 STRLEN outlen = 0;
7918f24d
NC
442
443 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
81cd54e3 444
81cd54e3 445 while (x < send) {
e0328548
KW
446 const U8* next_char_ptr;
447
81cd54e3
JH
448 /* Inline the easy bits of is_utf8_char() here for speed... */
449 if (UTF8_IS_INVARIANT(*x))
e0328548 450 next_char_ptr = x + 1;
81cd54e3 451 else {
768c67ee 452 /* ... and call is_utf8_char() only if really needed. */
768c67ee 453 c = UTF8SKIP(x);
e0328548
KW
454 next_char_ptr = c + x;
455 if (next_char_ptr > send) {
456 goto out;
457 }
768c67ee
JH
458 if (IS_UTF8_CHAR_FAST(c)) {
459 if (!IS_UTF8_CHAR(x, c))
460 c = 0;
461 } else
462 c = is_utf8_char_slow(x, c);
768c67ee
JH
463 if (!c)
464 goto out;
81cd54e3 465 }
e0328548 466 x = next_char_ptr;
3ebfea28 467 outlen++;
81cd54e3 468 }
768c67ee
JH
469
470 out:
3ebfea28
AL
471 if (el)
472 *el = outlen;
473
768c67ee
JH
474 if (ep)
475 *ep = x;
3ebfea28 476 return (x == send);
81cd54e3
JH
477}
478
479/*
768c67ee 480
87cea99e 481=for apidoc utf8n_to_uvuni
67e989fb 482
9041c2e3 483Bottom level UTF-8 decode routine.
746afd53
KW
484Returns the code point value of the first character in the string C<s>,
485which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
486C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
487the length, in bytes, of that character.
949cf498
KW
488
489The value of C<flags> determines the behavior when C<s> does not point to a
490well-formed UTF-8 character. If C<flags> is 0, when a malformation is found,
524080c4
KW
491zero is returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>) is the
492next possible position in C<s> that could begin a non-malformed character.
493Also, if UTF-8 warnings haven't been lexically disabled, a warning is raised.
949cf498
KW
494
495Various ALLOW flags can be set in C<flags> to allow (and not warn on)
496individual types of malformations, such as the sequence being overlong (that
497is, when there is a shorter sequence that can express the same code point;
498overlong sequences are expressly forbidden in the UTF-8 standard due to
499potential security issues). Another malformation example is the first byte of
500a character not being a legal first byte. See F<utf8.h> for the list of such
524080c4
KW
501flags. For allowed 0 length strings, this function returns 0; for allowed
502overlong sequences, the computed code point is returned; for all other allowed
503malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no
504determinable reasonable value.
949cf498
KW
505
506The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
507flags) malformation is found. If this flag is set, the routine assumes that
508the caller will raise a warning, and this function will silently just set
d088425d
KW
509C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
510
511Note that this API requires disambiguation between successful decoding a NUL
512character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as
513in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
514first byte of C<s> is 0 as well. If so, the input was a NUL; if not, the input
515had an error.
949cf498
KW
516
517Certain code points are considered problematic. These are Unicode surrogates,
746afd53 518Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
949cf498 519By default these are considered regular code points, but certain situations
5eafe189 520warrant special handling for them. If C<flags> contains
949cf498
KW
521UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
522malformations and handled as such. The flags UTF8_DISALLOW_SURROGATE,
523UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
524maximum) can be set to disallow these categories individually.
525
526The flags UTF8_WARN_ILLEGAL_INTERCHANGE, UTF8_WARN_SURROGATE,
527UTF8_WARN_NONCHAR, and UTF8_WARN_SUPER will cause warning messages to be raised
528for their respective categories, but otherwise the code points are considered
529valid (not malformations). To get a category to both be treated as a
530malformation and raise a warning, specify both the WARN and DISALLOW flags.
531(But note that warnings are not raised if lexically disabled nor if
532UTF8_CHECK_ONLY is also specified.)
533
534Very large code points (above 0x7FFF_FFFF) are considered more problematic than
535the others that are above the Unicode legal maximum. There are several
eb83ed87
KW
536reasons: they requre at least 32 bits to represent them on ASCII platforms, are
537not representable at all on EBCDIC platforms, and the original UTF-8
538specification never went above this number (the current 0x10FFFF limit was
539imposed later). (The smaller ones, those that fit into 32 bits, are
540representable by a UV on ASCII platforms, but not by an IV, which means that
541the number of operations that can be performed on them is quite restricted.)
542The UTF-8 encoding on ASCII platforms for these large code points begins with a
543byte containing 0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to
544be treated as malformations, while allowing smaller above-Unicode code points.
545(Of course UTF8_DISALLOW_SUPER will treat all above-Unicode code points,
546including these, as malformations.) Similarly, UTF8_WARN_FE_FF acts just like
547the other WARN flags, but applies just to these code points.
949cf498
KW
548
549All other code points corresponding to Unicode characters, including private
550use and those yet to be assigned, are never considered malformed and never
551warn.
67e989fb 552
ec5f19d0 553Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
9041c2e3 554
37607a96
PK
555=cut
556*/
67e989fb 557
a0ed51b3 558UV
7fc63493 559Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 560{
97aff369 561 dVAR;
d4c19fe8 562 const U8 * const s0 = s;
eb83ed87 563 U8 overflow_byte = '\0'; /* Save byte in case of overflow */
0b8d30e8 564 U8 * send;
eb83ed87
KW
565 UV uv = *s;
566 STRLEN expectlen;
949cf498 567 SV* sv = NULL;
eb83ed87
KW
568 UV outlier_ret = 0; /* return value when input is in error or problematic
569 */
570 UV pack_warn = 0; /* Save result of packWARN() for later */
571 bool unexpected_non_continuation = FALSE;
572 bool overflowed = FALSE;
2f8f112e 573 bool do_overlong_test = TRUE; /* May have to skip this test */
a0dbb045 574
eb83ed87 575 const char* const malformed_text = "Malformed UTF-8 character";
7918f24d 576
eb83ed87 577 PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
a0dbb045 578
eb83ed87
KW
579 /* The order of malformation tests here is important. We should consume as
580 * few bytes as possible in order to not skip any valid character. This is
581 * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
582 * http://unicode.org/reports/tr36 for more discussion as to why. For
583 * example, once we've done a UTF8SKIP, we can tell the expected number of
584 * bytes, and could fail right off the bat if the input parameters indicate
585 * that there are too few available. But it could be that just that first
586 * byte is garbled, and the intended character occupies fewer bytes. If we
587 * blindly assumed that the first byte is correct, and skipped based on
588 * that number, we could skip over a valid input character. So instead, we
589 * always examine the sequence byte-by-byte.
590 *
591 * We also should not consume too few bytes, otherwise someone could inject
592 * things. For example, an input could be deliberately designed to
593 * overflow, and if this code bailed out immediately upon discovering that,
594 * returning to the caller *retlen pointing to the very next byte (one
595 * which is actually part of of the overflowing sequence), that could look
596 * legitimate to the caller, which could discard the initial partial
597 * sequence and process the rest, inappropriately */
598
599 /* Zero length strings, if allowed, of necessity are zero */
b5b9af04 600 if (UNLIKELY(curlen == 0)) {
eb83ed87
KW
601 if (retlen) {
602 *retlen = 0;
603 }
a0dbb045 604
eb83ed87
KW
605 if (flags & UTF8_ALLOW_EMPTY) {
606 return 0;
607 }
608 if (! (flags & UTF8_CHECK_ONLY)) {
609 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
610 }
0c443dc2
JH
611 goto malformed;
612 }
613
eb83ed87
KW
614 expectlen = UTF8SKIP(s);
615
616 /* A well-formed UTF-8 character, as the vast majority of calls to this
617 * function will be for, has this expected length. For efficiency, set
618 * things up here to return it. It will be overriden only in those rare
619 * cases where a malformation is found */
620 if (retlen) {
621 *retlen = expectlen;
622 }
623
624 /* An invariant is trivially well-formed */
1d72bdf6 625 if (UTF8_IS_INVARIANT(uv)) {
bc3632a8 626 return (UV) (NATIVE_UTF8_TO_I8(*s));
a0ed51b3 627 }
67e989fb 628
eb83ed87 629 /* A continuation character can't start a valid sequence */
b5b9af04 630 if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
eb83ed87
KW
631 if (flags & UTF8_ALLOW_CONTINUATION) {
632 if (retlen) {
633 *retlen = 1;
634 }
635 return UNICODE_REPLACEMENT;
636 }
ba210ebe 637
eb83ed87
KW
638 if (! (flags & UTF8_CHECK_ONLY)) {
639 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
640 }
641 curlen = 1;
ba210ebe
JH
642 goto malformed;
643 }
9041c2e3 644
1d72bdf6 645#ifdef EBCDIC
bc3632a8 646 uv = NATIVE_UTF8_TO_I8(uv);
1d72bdf6
NIS
647#endif
648
eb83ed87
KW
649 /* Here is not a continuation byte, nor an invariant. The only thing left
650 * is a start byte (possibly for an overlong) */
ba210ebe 651
eb83ed87
KW
652 /* Remove the leading bits that indicate the number of bytes in the
653 * character's whole UTF-8 sequence, leaving just the bits that are part of
654 * the value */
655 uv &= UTF_START_MASK(expectlen);
ba210ebe 656
eb83ed87
KW
657 /* Now, loop through the remaining bytes in the character's sequence,
658 * accumulating each into the working value as we go. Be sure to not look
659 * past the end of the input string */
0b8d30e8
KW
660 send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
661
eb83ed87 662 for (s = s0 + 1; s < send; s++) {
b5b9af04 663 if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
eb83ed87
KW
664#ifndef EBCDIC /* Can't overflow in EBCDIC */
665 if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
666
667 /* The original implementors viewed this malformation as more
668 * serious than the others (though I, khw, don't understand
669 * why, since other malformations also give very very wrong
670 * results), so there is no way to turn off checking for it.
671 * Set a flag, but keep going in the loop, so that we absorb
672 * the rest of the bytes that comprise the character. */
673 overflowed = TRUE;
674 overflow_byte = *s; /* Save for warning message's use */
675 }
676#endif
8850bf83 677 uv = UTF8_ACCUMULATE(uv, *s);
eb83ed87
KW
678 }
679 else {
680 /* Here, found a non-continuation before processing all expected
681 * bytes. This byte begins a new character, so quit, even if
682 * allowing this malformation. */
683 unexpected_non_continuation = TRUE;
684 break;
685 }
686 } /* End of loop through the character's bytes */
687
688 /* Save how many bytes were actually in the character */
689 curlen = s - s0;
690
691 /* The loop above finds two types of malformations: non-continuation and/or
692 * overflow. The non-continuation malformation is really a too-short
693 * malformation, as it means that the current character ended before it was
694 * expected to (being terminated prematurely by the beginning of the next
695 * character, whereas in the too-short malformation there just are too few
696 * bytes available to hold the character. In both cases, the check below
697 * that we have found the expected number of bytes would fail if executed.)
698 * Thus the non-continuation malformation is really unnecessary, being a
699 * subset of the too-short malformation. But there may be existing
700 * applications that are expecting the non-continuation type, so we retain
701 * it, and return it in preference to the too-short malformation. (If this
702 * code were being written from scratch, the two types might be collapsed
703 * into one.) I, khw, am also giving priority to returning the
704 * non-continuation and too-short malformations over overflow when multiple
705 * ones are present. I don't know of any real reason to prefer one over
706 * the other, except that it seems to me that multiple-byte errors trumps
707 * errors from a single byte */
b5b9af04 708 if (UNLIKELY(unexpected_non_continuation)) {
eb83ed87
KW
709 if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
710 if (! (flags & UTF8_CHECK_ONLY)) {
711 if (curlen == 1) {
712 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
713 }
714 else {
715 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
a0dbb045
JH
716 }
717 }
eb83ed87
KW
718 goto malformed;
719 }
720 uv = UNICODE_REPLACEMENT;
2f8f112e
KW
721
722 /* Skip testing for overlongs, as the REPLACEMENT may not be the same
723 * as what the original expectations were. */
724 do_overlong_test = FALSE;
eb83ed87
KW
725 if (retlen) {
726 *retlen = curlen;
727 }
728 }
b5b9af04 729 else if (UNLIKELY(curlen < expectlen)) {
eb83ed87
KW
730 if (! (flags & UTF8_ALLOW_SHORT)) {
731 if (! (flags & UTF8_CHECK_ONLY)) {
732 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
a0dbb045 733 }
eb83ed87
KW
734 goto malformed;
735 }
736 uv = UNICODE_REPLACEMENT;
2f8f112e 737 do_overlong_test = FALSE;
eb83ed87
KW
738 if (retlen) {
739 *retlen = curlen;
740 }
741 }
742
743#ifndef EBCDIC /* EBCDIC allows FE, FF, can't overflow */
2f8f112e 744 if ((*s0 & 0xFE) == 0xFE /* matches both FE, FF */
eb83ed87
KW
745 && (flags & (UTF8_WARN_FE_FF|UTF8_DISALLOW_FE_FF)))
746 {
747 /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary
748 * generation of the sv, since no warnings are raised under CHECK */
749 if ((flags & (UTF8_WARN_FE_FF|UTF8_CHECK_ONLY)) == UTF8_WARN_FE_FF
750 && ckWARN_d(WARN_UTF8))
751 {
42303544
KW
752 /* This message is deliberately not of the same syntax as the other
753 * messages for malformations, for backwards compatibility in the
754 * unlikely event that code is relying on its precise earlier text
755 */
eb83ed87
KW
756 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s Code point beginning with byte 0x%02X is not Unicode, and not portable", malformed_text, *s0));
757 pack_warn = packWARN(WARN_UTF8);
758 }
759 if (flags & UTF8_DISALLOW_FE_FF) {
760 goto malformed;
ba210ebe 761 }
ba210ebe 762 }
b5b9af04 763 if (UNLIKELY(overflowed)) {
ba210ebe 764
eb83ed87
KW
765 /* If the first byte is FF, it will overflow a 32-bit word. If the
766 * first byte is FE, it will overflow a signed 32-bit word. The
767 * above preserves backward compatibility, since its message was used
768 * in earlier versions of this code in preference to overflow */
769 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0));
ba210ebe 770 goto malformed;
eb83ed87
KW
771 }
772#endif
773
2f8f112e
KW
774 if (do_overlong_test
775 && expectlen > (STRLEN)UNISKIP(uv)
776 && ! (flags & UTF8_ALLOW_LONG))
777 {
eb83ed87
KW
778 /* The overlong malformation has lower precedence than the others.
779 * Note that if this malformation is allowed, we return the actual
780 * value, instead of the replacement character. This is because this
781 * value is actually well-defined. */
782 if (! (flags & UTF8_CHECK_ONLY)) {
783 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), *s0));
784 }
785 goto malformed;
786 }
787
788 /* Here, the input is considered to be well-formed , but could be a
789 * problematic code point that is not allowed by the input parameters. */
790 if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */
791 && (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE
792 |UTF8_WARN_ILLEGAL_INTERCHANGE)))
793 {
949cf498 794 if (UNICODE_IS_SURROGATE(uv)) {
eb83ed87
KW
795 if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
796 && ckWARN2_d(WARN_UTF8, WARN_SURROGATE))
797 {
111d382d 798 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
eb83ed87 799 pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE);
949cf498
KW
800 }
801 if (flags & UTF8_DISALLOW_SURROGATE) {
802 goto disallowed;
803 }
804 }
949cf498 805 else if ((uv > PERL_UNICODE_MAX)) {
eb83ed87
KW
806 if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
807 && ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE))
808 {
111d382d 809 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
eb83ed87 810 pack_warn = packWARN2(WARN_UTF8, WARN_NON_UNICODE);
949cf498
KW
811 }
812 if (flags & UTF8_DISALLOW_SUPER) {
813 goto disallowed;
814 }
815 }
4190d317
KW
816 else if (UNICODE_IS_NONCHAR(uv)) {
817 if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
818 && ckWARN2_d(WARN_UTF8, WARN_NONCHAR))
819 {
820 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
821 pack_warn = packWARN2(WARN_UTF8, WARN_NONCHAR);
822 }
823 if (flags & UTF8_DISALLOW_NONCHAR) {
824 goto disallowed;
825 }
826 }
949cf498 827
eb83ed87
KW
828 if (sv) {
829 outlier_ret = uv;
830 goto do_warn;
831 }
832
949cf498
KW
833 /* Here, this is not considered a malformed character, so drop through
834 * to return it */
a0ed51b3 835 }
ba210ebe 836
a0ed51b3 837 return uv;
ba210ebe 838
eb83ed87
KW
839 /* There are three cases which get to beyond this point. In all 3 cases:
840 * <sv> if not null points to a string to print as a warning.
841 * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
842 * set.
843 * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
844 * This is done by initializing it to 0, and changing it only
845 * for case 1).
846 * The 3 cases are:
847 * 1) The input is valid but problematic, and to be warned about. The
848 * return value is the resultant code point; <*retlen> is set to
849 * <curlen>, the number of bytes that comprise the code point.
850 * <pack_warn> contains the result of packWARN() for the warning
851 * types. The entry point for this case is the label <do_warn>;
852 * 2) The input is a valid code point but disallowed by the parameters to
853 * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
854 * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
855 * comprise the code point. <pack_warn> contains the result of
856 * packWARN() for the warning types. The entry point for this case is
857 * the label <disallowed>.
858 * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
859 * is set, <*relen> is -1; otherwise it is <curlen>, the number of
860 * bytes that comprise the malformation. All such malformations are
861 * assumed to be warning type <utf8>. The entry point for this case
862 * is the label <malformed>.
863 */
949cf498 864
ba210ebe
JH
865malformed:
866
eb83ed87
KW
867 if (sv && ckWARN_d(WARN_UTF8)) {
868 pack_warn = packWARN(WARN_UTF8);
869 }
870
871disallowed:
872
fcc8fcf6 873 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 874 if (retlen)
10edeb5d 875 *retlen = ((STRLEN) -1);
ba210ebe
JH
876 return 0;
877 }
878
eb83ed87 879do_warn:
5b311467 880
eb83ed87
KW
881 if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
882 if warnings are to be raised. */
f555bc63 883 const char * const string = SvPVX_const(sv);
a0dbb045 884
f555bc63
KW
885 if (PL_op)
886 Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
887 else
888 Perl_warner(aTHX_ pack_warn, "%s", string);
a0dbb045
JH
889 }
890
eb83ed87
KW
891 if (retlen) {
892 *retlen = curlen;
893 }
ba210ebe 894
eb83ed87 895 return outlier_ret;
a0ed51b3
LW
896}
897
8e84507e 898/*
ec5f19d0
KW
899=for apidoc utf8_to_uvchr_buf
900
901Returns the native code point of the first character in the string C<s> which
902is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
524080c4 903C<*retlen> will be set to the length, in bytes, of that character.
ec5f19d0 904
524080c4
KW
905If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
906enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
173db420
KW
907NULL) to -1. If those warnings are off, the computed value, if well-defined
908(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
909C<*retlen> is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is
910the next possible position in C<s> that could begin a non-malformed character.
911See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is
912returned.
ec5f19d0
KW
913
914=cut
915*/
916
917
918UV
919Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
920{
921 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
922
923 assert(s < send);
924
925 return utf8n_to_uvchr(s, send - s, retlen,
926 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
927}
928
27d6c58a 929/* Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
3986bb7c 930 * there are no malformations in the input UTF-8 string C<s>. surrogates,
6dd9dce9
KW
931 * non-character code points, and non-Unicode code points are allowed. A macro
932 * in utf8.h is used to normally avoid this function wrapper */
27d6c58a
KW
933
934UV
935Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
936{
3986bb7c
KW
937 const UV uv = valid_utf8_to_uvuni(s, retlen);
938
27d6c58a
KW
939 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
940
3986bb7c 941 return UNI_TO_NATIVE(uv);
27d6c58a
KW
942}
943
ec5f19d0 944/*
87cea99e 945=for apidoc utf8_to_uvchr
9041c2e3 946
6ee84de2 947Returns the native code point of the first character in the string C<s>
1e54db1a 948which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
949length, in bytes, of that character.
950
4b88fb76 951Some, but not all, UTF-8 malformations are detected, and in fact, some
977c1d31
KW
952malformed input could cause reading beyond the end of the input buffer, which
953is why this function is deprecated. Use L</utf8_to_uvchr_buf> instead.
4b88fb76 954
524080c4
KW
955If C<s> points to one of the detected malformations, and UTF8 warnings are
956enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
957NULL) to -1. If those warnings are off, the computed value if well-defined (or
958the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
959is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
960next possible position in C<s> that could begin a non-malformed character.
961See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
9041c2e3
NIS
962
963=cut
964*/
965
966UV
7fc63493 967Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
9041c2e3 968{
7918f24d
NC
969 PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
970
2ff6c191 971 return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
9041c2e3
NIS
972}
973
974/*
ec5f19d0
KW
975=for apidoc utf8_to_uvuni_buf
976
977Returns the Unicode code point of the first character in the string C<s> which
978is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
979C<retlen> will be set to the length, in bytes, of that character.
980
981This function should only be used when the returned UV is considered
982an index into the Unicode semantic tables (e.g. swashes).
983
524080c4
KW
984If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
985enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
986NULL) to -1. If those warnings are off, the computed value if well-defined (or
987the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
988is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
989next possible position in C<s> that could begin a non-malformed character.
990See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
ec5f19d0
KW
991
992=cut
993*/
994
995UV
996Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
997{
998 PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
999
1000 assert(send > s);
1001
1002 /* Call the low level routine asking for checks */
1003 return Perl_utf8n_to_uvuni(aTHX_ s, send -s, retlen,
1004 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1005}
1006
27d6c58a 1007/* Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
2114036c 1008 * there are no malformations in the input UTF-8 string C<s>. Surrogates,
3986bb7c 1009 * non-character code points, and non-Unicode code points are allowed */
27d6c58a
KW
1010
1011UV
1012Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
1013{
3986bb7c
KW
1014 UV expectlen = UTF8SKIP(s);
1015 const U8* send = s + expectlen;
bc3632a8 1016 UV uv = NATIVE_UTF8_TO_I8(*s);
3986bb7c 1017
27d6c58a
KW
1018 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
1019
3986bb7c
KW
1020 if (retlen) {
1021 *retlen = expectlen;
1022 }
1023
1024 /* An invariant is trivially returned */
1025 if (expectlen == 1) {
1026 return uv;
1027 }
1028
1029 /* Remove the leading bits that indicate the number of bytes, leaving just
1030 * the bits that are part of the value */
1031 uv &= UTF_START_MASK(expectlen);
1032
1033 /* Now, loop through the remaining bytes, accumulating each into the
08bc774e
KW
1034 * working total as we go. (I khw tried unrolling the loop for up to 4
1035 * bytes, but there was no performance improvement) */
3986bb7c
KW
1036 for (++s; s < send; s++) {
1037 uv = UTF8_ACCUMULATE(uv, *s);
1038 }
1039
1040 return uv;
27d6c58a
KW
1041}
1042
ec5f19d0 1043/*
87cea99e 1044=for apidoc utf8_to_uvuni
9041c2e3
NIS
1045
1046Returns the Unicode code point of the first character in the string C<s>
1e54db1a 1047which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
1048length, in bytes, of that character.
1049
39e518fd
KW
1050This function should only be used when the returned UV is considered
1051an index into the Unicode semantic tables (e.g. swashes).
1052
4b88fb76 1053Some, but not all, UTF-8 malformations are detected, and in fact, some
977c1d31
KW
1054malformed input could cause reading beyond the end of the input buffer, which
1055is why this function is deprecated. Use L</utf8_to_uvuni_buf> instead.
9041c2e3 1056
524080c4
KW
1057If C<s> points to one of the detected malformations, and UTF8 warnings are
1058enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
1059NULL) to -1. If those warnings are off, the computed value if well-defined (or
1060the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
1061is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
1062next possible position in C<s> that could begin a non-malformed character.
1063See L</utf8n_to_uvuni> for details on when the REPLACEMENT CHARACTER is returned.
8e84507e
NIS
1064
1065=cut
1066*/
1067
1068UV
7fc63493 1069Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
8e84507e 1070{
7918f24d
NC
1071 PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
1072
4b88fb76 1073 return valid_utf8_to_uvuni(s, retlen);
8e84507e
NIS
1074}
1075
b76347f2 1076/*
87cea99e 1077=for apidoc utf8_length
b76347f2
JH
1078
1079Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
1080Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
1081up past C<e>, croaks.
b76347f2
JH
1082
1083=cut
1084*/
1085
1086STRLEN
35a4481c 1087Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2 1088{
97aff369 1089 dVAR;
b76347f2
JH
1090 STRLEN len = 0;
1091
7918f24d
NC
1092 PERL_ARGS_ASSERT_UTF8_LENGTH;
1093
8850bf83
JH
1094 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
1095 * the bitops (especially ~) can create illegal UTF-8.
1096 * In other words: in Perl UTF-8 is not just for Unicode. */
1097
a3b680e6
AL
1098 if (e < s)
1099 goto warn_and_return;
b76347f2 1100 while (s < e) {
4cbf4130 1101 s += UTF8SKIP(s);
8e91ec7f
AV
1102 len++;
1103 }
1104
1105 if (e != s) {
1106 len--;
1107 warn_and_return:
9b387841
NC
1108 if (PL_op)
1109 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1110 "%s in %s", unees, OP_DESC(PL_op));
1111 else
61a12c31 1112 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
b76347f2
JH
1113 }
1114
1115 return len;
1116}
1117
b06226ff 1118/*
87cea99e 1119=for apidoc utf8_distance
b06226ff 1120
1e54db1a 1121Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
b06226ff
JH
1122and C<b>.
1123
1124WARNING: use only if you *know* that the pointers point inside the
1125same UTF-8 buffer.
1126
37607a96
PK
1127=cut
1128*/
a0ed51b3 1129
02eb7b47 1130IV
35a4481c 1131Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
a0ed51b3 1132{
7918f24d
NC
1133 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1134
bf1665bc 1135 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
a0ed51b3
LW
1136}
1137
b06226ff 1138/*
87cea99e 1139=for apidoc utf8_hop
b06226ff 1140
8850bf83
JH
1141Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1142forward or backward.
b06226ff
JH
1143
1144WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
1145the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1146on the first byte of character or just after the last byte of a character.
b06226ff 1147
37607a96
PK
1148=cut
1149*/
a0ed51b3
LW
1150
1151U8 *
4373e329 1152Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
a0ed51b3 1153{
7918f24d
NC
1154 PERL_ARGS_ASSERT_UTF8_HOP;
1155
96a5add6 1156 PERL_UNUSED_CONTEXT;
8850bf83
JH
1157 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1158 * the bitops (especially ~) can create illegal UTF-8.
1159 * In other words: in Perl UTF-8 is not just for Unicode. */
1160
a0ed51b3
LW
1161 if (off >= 0) {
1162 while (off--)
1163 s += UTF8SKIP(s);
1164 }
1165 else {
1166 while (off++) {
1167 s--;
8850bf83
JH
1168 while (UTF8_IS_CONTINUATION(*s))
1169 s--;
a0ed51b3
LW
1170 }
1171 }
4373e329 1172 return (U8 *)s;
a0ed51b3
LW
1173}
1174
6940069f 1175/*
fed3ba5d
NC
1176=for apidoc bytes_cmp_utf8
1177
a1433954
KW
1178Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
1179sequence of characters (stored as UTF-8) in C<u>, C<ulen>. Returns 0 if they are
fed3ba5d
NC
1180equal, -1 or -2 if the first string is less than the second string, +1 or +2
1181if the first string is greater than the second string.
1182
1183-1 or +1 is returned if the shorter string was identical to the start of the
1184longer string. -2 or +2 is returned if the was a difference between characters
1185within the strings.
1186
1187=cut
1188*/
1189
1190int
1191Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
1192{
1193 const U8 *const bend = b + blen;
1194 const U8 *const uend = u + ulen;
1195
1196 PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
1197
1198 PERL_UNUSED_CONTEXT;
1199
1200 while (b < bend && u < uend) {
1201 U8 c = *u++;
1202 if (!UTF8_IS_INVARIANT(c)) {
1203 if (UTF8_IS_DOWNGRADEABLE_START(c)) {
1204 if (u < uend) {
1205 U8 c1 = *u++;
1206 if (UTF8_IS_CONTINUATION(c1)) {
356979f4 1207 c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1));
fed3ba5d
NC
1208 } else {
1209 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1210 "Malformed UTF-8 character "
1211 "(unexpected non-continuation byte 0x%02x"
1212 ", immediately after start byte 0x%02x)"
1213 /* Dear diag.t, it's in the pod. */
1214 "%s%s", c1, c,
1215 PL_op ? " in " : "",
1216 PL_op ? OP_DESC(PL_op) : "");
1217 return -2;
1218 }
1219 } else {
1220 if (PL_op)
1221 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1222 "%s in %s", unees, OP_DESC(PL_op));
1223 else
61a12c31 1224 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
fed3ba5d
NC
1225 return -2; /* Really want to return undef :-) */
1226 }
1227 } else {
1228 return -2;
1229 }
1230 }
1231 if (*b != c) {
1232 return *b < c ? -2 : +2;
1233 }
1234 ++b;
1235 }
1236
1237 if (b == bend && u == uend)
1238 return 0;
1239
1240 return b < bend ? +1 : -1;
1241}
1242
1243/*
87cea99e 1244=for apidoc utf8_to_bytes
6940069f 1245
2bbc8d55 1246Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954
KW
1247Unlike L</bytes_to_utf8>, this over-writes the original string, and
1248updates C<len> to contain the new length.
67e989fb 1249Returns zero on failure, setting C<len> to -1.
6940069f 1250
a1433954 1251If you need a copy of the string, see L</bytes_from_utf8>.
95be277c 1252
6940069f
GS
1253=cut
1254*/
1255
1256U8 *
37607a96 1257Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 1258{
d4c19fe8
AL
1259 U8 * const save = s;
1260 U8 * const send = s + *len;
6940069f 1261 U8 *d;
246fae53 1262
7918f24d
NC
1263 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
1264
1e54db1a 1265 /* ensure valid UTF-8 and chars < 256 before updating string */
d4c19fe8 1266 while (s < send) {
dcad2880
JH
1267 U8 c = *s++;
1268
1d72bdf6
NIS
1269 if (!UTF8_IS_INVARIANT(c) &&
1270 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
1271 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
10edeb5d 1272 *len = ((STRLEN) -1);
dcad2880
JH
1273 return 0;
1274 }
246fae53 1275 }
dcad2880
JH
1276
1277 d = s = save;
6940069f 1278 while (s < send) {
ed646e6e 1279 STRLEN ulen;
4b88fb76 1280 *d++ = (U8)utf8_to_uvchr_buf(s, send, &ulen);
ed646e6e 1281 s += ulen;
6940069f
GS
1282 }
1283 *d = '\0';
246fae53 1284 *len = d - save;
6940069f
GS
1285 return save;
1286}
1287
1288/*
87cea99e 1289=for apidoc bytes_from_utf8
f9a63242 1290
2bbc8d55 1291Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954 1292Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
1293the newly-created string, and updates C<len> to contain the new
1294length. Returns the original string if no conversion occurs, C<len>
1295is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
2bbc8d55
SP
12960 if C<s> is converted or consisted entirely of characters that are invariant
1297in utf8 (i.e., US-ASCII on non-EBCDIC machines).
f9a63242 1298
37607a96
PK
1299=cut
1300*/
f9a63242
JH
1301
1302U8 *
e1ec3a88 1303Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 1304{
f9a63242 1305 U8 *d;
e1ec3a88
AL
1306 const U8 *start = s;
1307 const U8 *send;
f9a63242
JH
1308 I32 count = 0;
1309
7918f24d
NC
1310 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
1311
96a5add6 1312 PERL_UNUSED_CONTEXT;
f9a63242 1313 if (!*is_utf8)
73d840c0 1314 return (U8 *)start;
f9a63242 1315
1e54db1a 1316 /* ensure valid UTF-8 and chars < 256 before converting string */
f9a63242 1317 for (send = s + *len; s < send;) {
e1ec3a88 1318 U8 c = *s++;
1d72bdf6 1319 if (!UTF8_IS_INVARIANT(c)) {
db42d148
NIS
1320 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
1321 (c = *s++) && UTF8_IS_CONTINUATION(c))
1322 count++;
1323 else
73d840c0 1324 return (U8 *)start;
db42d148 1325 }
f9a63242
JH
1326 }
1327
35da51f7 1328 *is_utf8 = FALSE;
f9a63242 1329
212542aa 1330 Newx(d, (*len) - count + 1, U8);
ef9edfd0 1331 s = start; start = d;
f9a63242
JH
1332 while (s < send) {
1333 U8 c = *s++;
c4d5f83a
NIS
1334 if (!UTF8_IS_INVARIANT(c)) {
1335 /* Then it is two-byte encoded */
356979f4 1336 c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, *s++));
c4d5f83a
NIS
1337 }
1338 *d++ = c;
f9a63242
JH
1339 }
1340 *d = '\0';
1341 *len = d - start;
73d840c0 1342 return (U8 *)start;
f9a63242
JH
1343}
1344
1345/*
87cea99e 1346=for apidoc bytes_to_utf8
6940069f 1347
ff97e5cf
KW
1348Converts a string C<s> of length C<len> bytes from the native encoding into
1349UTF-8.
6662521e 1350Returns a pointer to the newly-created string, and sets C<len> to
ff97e5cf 1351reflect the new length in bytes.
6940069f 1352
2bbc8d55
SP
1353A NUL character will be written after the end of the string.
1354
1355If you want to convert to UTF-8 from encodings other than
1356the native (Latin1 or EBCDIC),
a1433954 1357see L</sv_recode_to_utf8>().
c9ada85f 1358
497711e7 1359=cut
6940069f
GS
1360*/
1361
c682ebef
FC
1362/* This logic is duplicated in sv_catpvn_flags, so any bug fixes will
1363 likewise need duplication. */
1364
6940069f 1365U8*
35a4481c 1366Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
6940069f 1367{
35a4481c 1368 const U8 * const send = s + (*len);
6940069f
GS
1369 U8 *d;
1370 U8 *dst;
7918f24d
NC
1371
1372 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
96a5add6 1373 PERL_UNUSED_CONTEXT;
6940069f 1374
212542aa 1375 Newx(d, (*len) * 2 + 1, U8);
6940069f
GS
1376 dst = d;
1377
1378 while (s < send) {
35a4481c 1379 const UV uv = NATIVE_TO_ASCII(*s++);
c4d5f83a 1380 if (UNI_IS_INVARIANT(uv))
eb160463 1381 *d++ = (U8)UTF_TO_NATIVE(uv);
6940069f 1382 else {
eb160463
GS
1383 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1384 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
6940069f
GS
1385 }
1386 }
1387 *d = '\0';
6662521e 1388 *len = d-dst;
6940069f
GS
1389 return dst;
1390}
1391
a0ed51b3 1392/*
dea0fc0b 1393 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
1394 *
1395 * Destination must be pre-extended to 3/2 source. Do not use in-place.
1396 * We optimize for native, for obvious reasons. */
1397
1398U8*
dea0fc0b 1399Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 1400{
dea0fc0b
JH
1401 U8* pend;
1402 U8* dstart = d;
1403
7918f24d
NC
1404 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1405
dea0fc0b 1406 if (bytelen & 1)
f5992bc4 1407 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
dea0fc0b
JH
1408
1409 pend = p + bytelen;
1410
a0ed51b3 1411 while (p < pend) {
dea0fc0b
JH
1412 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1413 p += 2;
a0ed51b3 1414 if (uv < 0x80) {
e294cc5d 1415#ifdef EBCDIC
8e7c6e7d 1416 *d++ = LATIN1_TO_NATIVE(uv);
e294cc5d 1417#else
eb160463 1418 *d++ = (U8)uv;
e294cc5d 1419#endif
a0ed51b3
LW
1420 continue;
1421 }
1422 if (uv < 0x800) {
eb160463
GS
1423 *d++ = (U8)(( uv >> 6) | 0xc0);
1424 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1425 continue;
1426 }
46956fad
KW
1427#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
1428#define LAST_HIGH_SURROGATE 0xDBFF
1429#define FIRST_LOW_SURROGATE 0xDC00
1430#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
1431 if (uv >= FIRST_HIGH_SURROGATE && uv <= LAST_HIGH_SURROGATE) {
01ea242b 1432 if (p >= pend) {
dea0fc0b 1433 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
01ea242b
NC
1434 } else {
1435 UV low = (p[0] << 8) + p[1];
1436 p += 2;
46956fad 1437 if (low < FIRST_LOW_SURROGATE || low > LAST_LOW_SURROGATE)
01ea242b 1438 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
46956fad
KW
1439 uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
1440 + (low - FIRST_LOW_SURROGATE) + 0x10000;
01ea242b 1441 }
46956fad 1442 } else if (uv >= FIRST_LOW_SURROGATE && uv <= LAST_LOW_SURROGATE) {
dbde1951 1443 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
a0ed51b3
LW
1444 }
1445 if (uv < 0x10000) {
eb160463
GS
1446 *d++ = (U8)(( uv >> 12) | 0xe0);
1447 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1448 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1449 continue;
1450 }
1451 else {
eb160463
GS
1452 *d++ = (U8)(( uv >> 18) | 0xf0);
1453 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1454 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1455 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1456 continue;
1457 }
1458 }
dea0fc0b 1459 *newlen = d - dstart;
a0ed51b3
LW
1460 return d;
1461}
1462
1463/* Note: this one is slightly destructive of the source. */
1464
1465U8*
dea0fc0b 1466Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
1467{
1468 U8* s = (U8*)p;
d4c19fe8 1469 U8* const send = s + bytelen;
7918f24d
NC
1470
1471 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1472
e0ea5e2d
NC
1473 if (bytelen & 1)
1474 Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1475 (UV)bytelen);
1476
a0ed51b3 1477 while (s < send) {
d4c19fe8 1478 const U8 tmp = s[0];
a0ed51b3
LW
1479 s[0] = s[1];
1480 s[1] = tmp;
1481 s += 2;
1482 }
dea0fc0b 1483 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
1484}
1485
922e8cb4
KW
1486bool
1487Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
1488{
1489 U8 tmpbuf[UTF8_MAXBYTES+1];
1490 uvchr_to_utf8(tmpbuf, c);
1491 return _is_utf8_FOO(classnum, tmpbuf);
1492}
1493
c3fd2246
KW
1494/* for now these are all defined (inefficiently) in terms of the utf8 versions.
1495 * Note that the macros in handy.h that call these short-circuit calling them
1496 * for Latin-1 range inputs */
a0ed51b3
LW
1497
1498bool
84afefe6 1499Perl_is_uni_alnum(pTHX_ UV c)
a0ed51b3 1500{
89ebb4a3 1501 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1502 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1503 return _is_utf8_FOO(_CC_WORDCHAR, tmpbuf);
a0ed51b3
LW
1504}
1505
1506bool
5092f92a
KW
1507Perl_is_uni_alnumc(pTHX_ UV c)
1508{
1509 U8 tmpbuf[UTF8_MAXBYTES+1];
1510 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1511 return _is_utf8_FOO(_CC_ALPHANUMERIC, tmpbuf);
5092f92a
KW
1512}
1513
f9ae8fb6
JD
1514/* Internal function so we can deprecate the external one, and call
1515 this one from other deprecated functions in this file */
1516
1517PERL_STATIC_INLINE bool
61b19385
KW
1518S_is_utf8_idfirst(pTHX_ const U8 *p)
1519{
1520 dVAR;
1521
1522 if (*p == '_')
1523 return TRUE;
1524 /* is_utf8_idstart would be more logical. */
1525 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1526}
1527
5092f92a 1528bool
84afefe6 1529Perl_is_uni_idfirst(pTHX_ UV c)
a0ed51b3 1530{
89ebb4a3 1531 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1532 uvchr_to_utf8(tmpbuf, c);
61b19385 1533 return S_is_utf8_idfirst(aTHX_ tmpbuf);
a0ed51b3
LW
1534}
1535
1536bool
eba68aa0
KW
1537Perl__is_uni_perl_idcont(pTHX_ UV c)
1538{
1539 U8 tmpbuf[UTF8_MAXBYTES+1];
1540 uvchr_to_utf8(tmpbuf, c);
1541 return _is_utf8_perl_idcont(tmpbuf);
1542}
1543
1544bool
f91dcd13
KW
1545Perl__is_uni_perl_idstart(pTHX_ UV c)
1546{
1547 U8 tmpbuf[UTF8_MAXBYTES+1];
1548 uvchr_to_utf8(tmpbuf, c);
1549 return _is_utf8_perl_idstart(tmpbuf);
1550}
1551
1552bool
84afefe6 1553Perl_is_uni_alpha(pTHX_ UV c)
a0ed51b3 1554{
89ebb4a3 1555 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1556 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1557 return _is_utf8_FOO(_CC_ALPHA, tmpbuf);
a0ed51b3
LW
1558}
1559
1560bool
84afefe6 1561Perl_is_uni_ascii(pTHX_ UV c)
4d61ec05 1562{
bc39fe24 1563 return isASCII(c);
4d61ec05
GS
1564}
1565
1566bool
bdd8600f
KW
1567Perl_is_uni_blank(pTHX_ UV c)
1568{
2cafb56b 1569 return isBLANK_uni(c);
bdd8600f
KW
1570}
1571
1572bool
84afefe6 1573Perl_is_uni_space(pTHX_ UV c)
a0ed51b3 1574{
add4123a 1575 return isSPACE_uni(c);
a0ed51b3
LW
1576}
1577
1578bool
84afefe6 1579Perl_is_uni_digit(pTHX_ UV c)
a0ed51b3 1580{
89ebb4a3 1581 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1582 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1583 return _is_utf8_FOO(_CC_DIGIT, tmpbuf);
a0ed51b3
LW
1584}
1585
1586bool
84afefe6 1587Perl_is_uni_upper(pTHX_ UV c)
a0ed51b3 1588{
89ebb4a3 1589 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1590 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1591 return _is_utf8_FOO(_CC_UPPER, tmpbuf);
a0ed51b3
LW
1592}
1593
1594bool
84afefe6 1595Perl_is_uni_lower(pTHX_ UV c)
a0ed51b3 1596{
89ebb4a3 1597 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1598 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1599 return _is_utf8_FOO(_CC_LOWER, tmpbuf);
a0ed51b3
LW
1600}
1601
1602bool
84afefe6 1603Perl_is_uni_cntrl(pTHX_ UV c)
b8c5462f 1604{
7b952154 1605 return isCNTRL_L1(c);
b8c5462f
JH
1606}
1607
1608bool
84afefe6 1609Perl_is_uni_graph(pTHX_ UV c)
b8c5462f 1610{
89ebb4a3 1611 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1612 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1613 return _is_utf8_FOO(_CC_GRAPH, tmpbuf);
b8c5462f
JH
1614}
1615
1616bool
84afefe6 1617Perl_is_uni_print(pTHX_ UV c)
a0ed51b3 1618{
89ebb4a3 1619 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1620 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1621 return _is_utf8_FOO(_CC_PRINT, tmpbuf);
a0ed51b3
LW
1622}
1623
b8c5462f 1624bool
84afefe6 1625Perl_is_uni_punct(pTHX_ UV c)
b8c5462f 1626{
89ebb4a3 1627 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1628 uvchr_to_utf8(tmpbuf, c);
922e8cb4 1629 return _is_utf8_FOO(_CC_PUNCT, tmpbuf);
b8c5462f
JH
1630}
1631
4d61ec05 1632bool
84afefe6 1633Perl_is_uni_xdigit(pTHX_ UV c)
4d61ec05 1634{
4ac6419d 1635 return isXDIGIT_uni(c);
4d61ec05
GS
1636}
1637
3a4c58c9
KW
1638UV
1639Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
1640{
1641 /* We have the latin1-range values compiled into the core, so just use
1642 * those, converting the result to utf8. The only difference between upper
1643 * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
1644 * either "SS" or "Ss". Which one to use is passed into the routine in
1645 * 'S_or_s' to avoid a test */
1646
1647 UV converted = toUPPER_LATIN1_MOD(c);
1648
1649 PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
1650
1651 assert(S_or_s == 'S' || S_or_s == 's');
1652
1653 if (UNI_IS_INVARIANT(converted)) { /* No difference between the two for
1654 characters in this range */
1655 *p = (U8) converted;
1656 *lenp = 1;
1657 return converted;
1658 }
1659
1660 /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
1661 * which it maps to one of them, so as to only have to have one check for
1662 * it in the main case */
1663 if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
1664 switch (c) {
1665 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
1666 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
1667 break;
1668 case MICRO_SIGN:
1669 converted = GREEK_CAPITAL_LETTER_MU;
1670 break;
1671 case LATIN_SMALL_LETTER_SHARP_S:
1672 *(p)++ = 'S';
1673 *p = S_or_s;
1674 *lenp = 2;
1675 return 'S';
1676 default:
1677 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
118e2215 1678 assert(0); /* NOTREACHED */
3a4c58c9
KW
1679 }
1680 }
1681
1682 *(p)++ = UTF8_TWO_BYTE_HI(converted);
1683 *p = UTF8_TWO_BYTE_LO(converted);
1684 *lenp = 2;
1685
1686 return converted;
1687}
1688
50bda2c3
KW
1689/* Call the function to convert a UTF-8 encoded character to the specified case.
1690 * Note that there may be more than one character in the result.
1691 * INP is a pointer to the first byte of the input character
1692 * OUTP will be set to the first byte of the string of changed characters. It
1693 * needs to have space for UTF8_MAXBYTES_CASE+1 bytes
1694 * LENP will be set to the length in bytes of the string of changed characters
1695 *
1696 * The functions return the ordinal of the first character in the string of OUTP */
f90a9a02
KW
1697#define CALL_UPPER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_toupper, "ToUc", "utf8::ToSpecUc")
1698#define CALL_TITLE_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_totitle, "ToTc", "utf8::ToSpecTc")
1699#define CALL_LOWER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tolower, "ToLc", "utf8::ToSpecLc")
50bda2c3
KW
1700
1701/* This additionally has the input parameter SPECIALS, which if non-zero will
1702 * cause this to use the SPECIALS hash for folding (meaning get full case
1703 * folding); otherwise, when zero, this implies a simple case fold */
f90a9a02 1704#define CALL_FOLD_CASE(INP, OUTP, LENP, SPECIALS) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tofold, "ToCf", (SPECIALS) ? "utf8::ToSpecCf" : NULL)
c3fd2246 1705
84afefe6
JH
1706UV
1707Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1708{
3a4c58c9
KW
1709 dVAR;
1710
a1433954
KW
1711 /* Convert the Unicode character whose ordinal is <c> to its uppercase
1712 * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
1713 * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
c3fd2246
KW
1714 * the changed version may be longer than the original character.
1715 *
1716 * The ordinal of the first character of the changed version is returned
1717 * (but note, as explained above, that there may be more.) */
1718
7918f24d
NC
1719 PERL_ARGS_ASSERT_TO_UNI_UPPER;
1720
3a4c58c9
KW
1721 if (c < 256) {
1722 return _to_upper_title_latin1((U8) c, p, lenp, 'S');
1723 }
1724
0ebc6274 1725 uvchr_to_utf8(p, c);
3a4c58c9 1726 return CALL_UPPER_CASE(p, p, lenp);
a0ed51b3
LW
1727}
1728
84afefe6
JH
1729UV
1730Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1731{
3a4c58c9
KW
1732 dVAR;
1733
7918f24d
NC
1734 PERL_ARGS_ASSERT_TO_UNI_TITLE;
1735
3a4c58c9
KW
1736 if (c < 256) {
1737 return _to_upper_title_latin1((U8) c, p, lenp, 's');
1738 }
1739
0ebc6274 1740 uvchr_to_utf8(p, c);
3a4c58c9 1741 return CALL_TITLE_CASE(p, p, lenp);
a0ed51b3
LW
1742}
1743
afc16117
KW
1744STATIC U8
1745S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
1746{
1747 /* We have the latin1-range values compiled into the core, so just use
1748 * those, converting the result to utf8. Since the result is always just
a1433954 1749 * one character, we allow <p> to be NULL */
afc16117
KW
1750
1751 U8 converted = toLOWER_LATIN1(c);
1752
1753 if (p != NULL) {
1754 if (UNI_IS_INVARIANT(converted)) {
1755 *p = converted;
1756 *lenp = 1;
1757 }
1758 else {
1759 *p = UTF8_TWO_BYTE_HI(converted);
1760 *(p+1) = UTF8_TWO_BYTE_LO(converted);
1761 *lenp = 2;
1762 }
1763 }
1764 return converted;
1765}
1766
84afefe6
JH
1767UV
1768Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1769{
968c5e6a
KW
1770 dVAR;
1771
7918f24d
NC
1772 PERL_ARGS_ASSERT_TO_UNI_LOWER;
1773
afc16117
KW
1774 if (c < 256) {
1775 return to_lower_latin1((U8) c, p, lenp);
bca00c02
KW
1776 }
1777
afc16117 1778 uvchr_to_utf8(p, c);
968c5e6a 1779 return CALL_LOWER_CASE(p, p, lenp);
a0ed51b3
LW
1780}
1781
84afefe6 1782UV
51910141 1783Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int flags)
a1dde8de 1784{
51910141 1785 /* Corresponds to to_lower_latin1(); <flags> bits meanings:
1ca267a5 1786 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
51910141 1787 * FOLD_FLAGS_FULL iff full folding is to be used;
1ca267a5
KW
1788 *
1789 * Not to be used for locale folds
51910141 1790 */
f673fad4 1791
a1dde8de
KW
1792 UV converted;
1793
1794 PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
1795
1ca267a5
KW
1796 assert (! (flags & FOLD_FLAGS_LOCALE));
1797
a1dde8de
KW
1798 if (c == MICRO_SIGN) {
1799 converted = GREEK_SMALL_LETTER_MU;
1800 }
51910141 1801 else if ((flags & FOLD_FLAGS_FULL) && c == LATIN_SMALL_LETTER_SHARP_S) {
1ca267a5
KW
1802
1803 /* If can't cross 127/128 boundary, can't return "ss"; instead return
1804 * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}")
1805 * under those circumstances. */
1806 if (flags & FOLD_FLAGS_NOMIX_ASCII) {
1807 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
1808 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
1809 p, *lenp, U8);
1810 return LATIN_SMALL_LETTER_LONG_S;
1811 }
1812 else {
4f489194
KW
1813 *(p)++ = 's';
1814 *p = 's';
1815 *lenp = 2;
1816 return 's';
1ca267a5 1817 }
a1dde8de
KW
1818 }
1819 else { /* In this range the fold of all other characters is their lower
1820 case */
1821 converted = toLOWER_LATIN1(c);
1822 }
1823
1824 if (UNI_IS_INVARIANT(converted)) {
1825 *p = (U8) converted;
1826 *lenp = 1;
1827 }
1828 else {
1829 *(p)++ = UTF8_TWO_BYTE_HI(converted);
1830 *p = UTF8_TWO_BYTE_LO(converted);
1831 *lenp = 2;
1832 }
1833
1834 return converted;
1835}
1836
1837UV
a0270393 1838Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const U8 flags)
84afefe6 1839{
4b593389 1840
a0270393
KW
1841 /* Not currently externally documented, and subject to change
1842 * <flags> bits meanings:
1843 * FOLD_FLAGS_FULL iff full folding is to be used;
1844 * FOLD_FLAGS_LOCALE iff in locale
1845 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
1846 */
4b593389 1847
36bb2ab6 1848 PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
7918f24d 1849
a1dde8de 1850 if (c < 256) {
a0270393 1851 UV result = _to_fold_latin1((U8) c, p, lenp,
1ca267a5 1852 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
a0270393
KW
1853 /* It is illegal for the fold to cross the 255/256 boundary under
1854 * locale; in this case return the original */
1855 return (result > 256 && flags & FOLD_FLAGS_LOCALE)
1856 ? c
1857 : result;
a1dde8de
KW
1858 }
1859
a0270393
KW
1860 /* If no special needs, just use the macro */
1861 if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
1862 uvchr_to_utf8(p, c);
1863 return CALL_FOLD_CASE(p, p, lenp, flags & FOLD_FLAGS_FULL);
1864 }
1865 else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with
1866 the special flags. */
1867 U8 utf8_c[UTF8_MAXBYTES + 1];
1868 uvchr_to_utf8(utf8_c, c);
1869 return _to_utf8_fold_flags(utf8_c, p, lenp, flags, NULL);
1870 }
84afefe6
JH
1871}
1872
a0ed51b3 1873bool
84afefe6 1874Perl_is_uni_alnum_lc(pTHX_ UV c)
a0ed51b3 1875{
edfb3318
KW
1876 if (c < 256) {
1877 return isALNUM_LC(UNI_TO_NATIVE(c));
1878 }
922e8cb4 1879 return _is_uni_FOO(_CC_WORDCHAR, c);
a0ed51b3
LW
1880}
1881
1882bool
5092f92a
KW
1883Perl_is_uni_alnumc_lc(pTHX_ UV c)
1884{
1885 if (c < 256) {
15861f94 1886 return isALPHANUMERIC_LC(UNI_TO_NATIVE(c));
5092f92a 1887 }
922e8cb4 1888 return _is_uni_FOO(_CC_ALPHANUMERIC, c);
5092f92a
KW
1889}
1890
1891bool
84afefe6 1892Perl_is_uni_idfirst_lc(pTHX_ UV c)
a0ed51b3 1893{
edfb3318
KW
1894 if (c < 256) {
1895 return isIDFIRST_LC(UNI_TO_NATIVE(c));
1896 }
1897 return _is_uni_perl_idstart(c);
a0ed51b3
LW
1898}
1899
1900bool
84afefe6 1901Perl_is_uni_alpha_lc(pTHX_ UV c)
a0ed51b3 1902{
edfb3318
KW
1903 if (c < 256) {
1904 return isALPHA_LC(UNI_TO_NATIVE(c));
1905 }
922e8cb4 1906 return _is_uni_FOO(_CC_ALPHA, c);
a0ed51b3
LW
1907}
1908
1909bool
84afefe6 1910Perl_is_uni_ascii_lc(pTHX_ UV c)
4d61ec05 1911{
edfb3318
KW
1912 if (c < 256) {
1913 return isASCII_LC(UNI_TO_NATIVE(c));
1914 }
1915 return 0;
4d61ec05
GS
1916}
1917
1918bool
bdd8600f
KW
1919Perl_is_uni_blank_lc(pTHX_ UV c)
1920{
edfb3318
KW
1921 if (c < 256) {
1922 return isBLANK_LC(UNI_TO_NATIVE(c));
1923 }
61b19385 1924 return isBLANK_uni(c);
bdd8600f
KW
1925}
1926
1927bool
84afefe6 1928Perl_is_uni_space_lc(pTHX_ UV c)
a0ed51b3 1929{
edfb3318
KW
1930 if (c < 256) {
1931 return isSPACE_LC(UNI_TO_NATIVE(c));
1932 }
61b19385 1933 return isSPACE_uni(c);
a0ed51b3
LW
1934}
1935
1936bool
84afefe6 1937Perl_is_uni_digit_lc(pTHX_ UV c)
a0ed51b3 1938{
edfb3318
KW
1939 if (c < 256) {
1940 return isDIGIT_LC(UNI_TO_NATIVE(c));
1941 }
922e8cb4 1942 return _is_uni_FOO(_CC_DIGIT, c);
a0ed51b3
LW
1943}
1944
1945bool
84afefe6 1946Perl_is_uni_upper_lc(pTHX_ UV c)
a0ed51b3 1947{
edfb3318
KW
1948 if (c < 256) {
1949 return isUPPER_LC(UNI_TO_NATIVE(c));
1950 }
922e8cb4 1951 return _is_uni_FOO(_CC_UPPER, c);
a0ed51b3
LW
1952}
1953
1954bool
84afefe6 1955Perl_is_uni_lower_lc(pTHX_ UV c)
a0ed51b3 1956{
edfb3318
KW
1957 if (c < 256) {
1958 return isLOWER_LC(UNI_TO_NATIVE(c));
1959 }
922e8cb4 1960 return _is_uni_FOO(_CC_LOWER, c);
a0ed51b3
LW
1961}
1962
1963bool
84afefe6 1964Perl_is_uni_cntrl_lc(pTHX_ UV c)
b8c5462f 1965{
edfb3318
KW
1966 if (c < 256) {
1967 return isCNTRL_LC(UNI_TO_NATIVE(c));
1968 }
61b19385 1969 return 0;
b8c5462f
JH
1970}
1971
1972bool
84afefe6 1973Perl_is_uni_graph_lc(pTHX_ UV c)
b8c5462f 1974{
edfb3318
KW
1975 if (c < 256) {
1976 return isGRAPH_LC(UNI_TO_NATIVE(c));
1977 }
922e8cb4 1978 return _is_uni_FOO(_CC_GRAPH, c);
b8c5462f
JH
1979}
1980
1981bool
84afefe6 1982Perl_is_uni_print_lc(pTHX_ UV c)
a0ed51b3 1983{
edfb3318
KW
1984 if (c < 256) {
1985 return isPRINT_LC(UNI_TO_NATIVE(c));
1986 }
922e8cb4 1987 return _is_uni_FOO(_CC_PRINT, c);
a0ed51b3
LW
1988}
1989
b8c5462f 1990bool
84afefe6 1991Perl_is_uni_punct_lc(pTHX_ UV c)
b8c5462f 1992{
edfb3318
KW
1993 if (c < 256) {
1994 return isPUNCT_LC(UNI_TO_NATIVE(c));
1995 }
922e8cb4 1996 return _is_uni_FOO(_CC_PUNCT, c);
b8c5462f
JH
1997}
1998
4d61ec05 1999bool
84afefe6 2000Perl_is_uni_xdigit_lc(pTHX_ UV c)
4d61ec05 2001{
edfb3318
KW
2002 if (c < 256) {
2003 return isXDIGIT_LC(UNI_TO_NATIVE(c));
2004 }
61b19385 2005 return isXDIGIT_uni(c);
4d61ec05
GS
2006}
2007
b7ac61fa
JH
2008U32
2009Perl_to_uni_upper_lc(pTHX_ U32 c)
2010{
ee099d14
JH
2011 /* XXX returns only the first character -- do not use XXX */
2012 /* XXX no locale support yet */
2013 STRLEN len;
89ebb4a3 2014 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 2015 return (U32)to_uni_upper(c, tmpbuf, &len);
b7ac61fa
JH
2016}
2017
2018U32
2019Perl_to_uni_title_lc(pTHX_ U32 c)
2020{
ee099d14
JH
2021 /* XXX returns only the first character XXX -- do not use XXX */
2022 /* XXX no locale support yet */
2023 STRLEN len;
89ebb4a3 2024 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 2025 return (U32)to_uni_title(c, tmpbuf, &len);
b7ac61fa
JH
2026}
2027
2028U32
2029Perl_to_uni_lower_lc(pTHX_ U32 c)
2030{
ee099d14
JH
2031 /* XXX returns only the first character -- do not use XXX */
2032 /* XXX no locale support yet */
2033 STRLEN len;
89ebb4a3 2034 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 2035 return (U32)to_uni_lower(c, tmpbuf, &len);
b7ac61fa
JH
2036}
2037
26483009 2038PERL_STATIC_INLINE bool
5141f98e 2039S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
bde6a22d
NC
2040 const char *const swashname)
2041{
ea317ccb
KW
2042 /* returns a boolean giving whether or not the UTF8-encoded character that
2043 * starts at <p> is in the swash indicated by <swashname>. <swash>
2044 * contains a pointer to where the swash indicated by <swashname>
2045 * is to be stored; which this routine will do, so that future calls will
2046 * look at <*swash> and only generate a swash if it is not null
2047 *
2048 * Note that it is assumed that the buffer length of <p> is enough to
2049 * contain all the bytes that comprise the character. Thus, <*p> should
2050 * have been checked before this call for mal-formedness enough to assure
2051 * that. */
2052
97aff369 2053 dVAR;
7918f24d
NC
2054
2055 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
2056
492a624f 2057 /* The API should have included a length for the UTF-8 character in <p>,
28123549 2058 * but it doesn't. We therefore assume that p has been validated at least
492a624f
KW
2059 * as far as there being enough bytes available in it to accommodate the
2060 * character without reading beyond the end, and pass that number on to the
2061 * validating routine */
28123549
KW
2062 if (! is_utf8_char_buf(p, p + UTF8SKIP(p))) {
2063 if (ckWARN_d(WARN_UTF8)) {
2064 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED,WARN_UTF8),
9816f121 2065 "Passing malformed UTF-8 to \"%s\" is deprecated", swashname);
28123549
KW
2066 if (ckWARN(WARN_UTF8)) { /* This will output details as to the
2067 what the malformation is */
2068 utf8_to_uvchr_buf(p, p + UTF8SKIP(p), NULL);
2069 }
2070 }
2071 return FALSE;
2072 }
87367d5f
KW
2073 if (!*swash) {
2074 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2075 *swash = _core_swash_init("utf8", swashname, &PL_sv_undef, 1, 0, NULL, &flags);
2076 }
28123549 2077
bde6a22d
NC
2078 return swash_fetch(*swash, p, TRUE) != 0;
2079}
2080
2081bool
922e8cb4
KW
2082Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
2083{
2084 dVAR;
2085
2086 PERL_ARGS_ASSERT__IS_UTF8_FOO;
2087
2088 assert(classnum < _FIRST_NON_SWASH_CC);
2089
2090 return is_utf8_common(p, &PL_utf8_swash_ptrs[classnum], swash_property_names[classnum]);
2091}
2092
2093bool
7fc63493 2094Perl_is_utf8_alnum(pTHX_ const U8 *p)
a0ed51b3 2095{
97aff369 2096 dVAR;
7918f24d
NC
2097
2098 PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
2099
671c33bf
NC
2100 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
2101 * descendant of isalnum(3), in other words, it doesn't
2102 * contain the '_'. --jhi */
03940dc2 2103 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_WORDCHAR], "IsWord");
a0ed51b3
LW
2104}
2105
2106bool
5092f92a
KW
2107Perl_is_utf8_alnumc(pTHX_ const U8 *p)
2108{
2109 dVAR;
2110
2111 PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
2112
03940dc2 2113 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHANUMERIC], "IsAlnum");
5092f92a
KW
2114}
2115
2116bool
7fc63493 2117Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
a0ed51b3 2118{
97aff369 2119 dVAR;
7918f24d
NC
2120
2121 PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
2122
61b19385 2123 return S_is_utf8_idfirst(aTHX_ p);
82686b01
JH
2124}
2125
2126bool
c11ff943
KW
2127Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
2128{
2129 dVAR;
2130
2131 PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
2132
2133 if (*p == '_')
2134 return TRUE;
2135 /* is_utf8_idstart would be more logical. */
2136 return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart");
2137}
2138
2139bool
d65654cb 2140Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
b6912c02
KW
2141{
2142 dVAR;
2143
d65654cb 2144 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
b6912c02
KW
2145
2146 return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart");
2147}
2148
2149bool
eba68aa0
KW
2150Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
2151{
2152 dVAR;
2153
2154 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
2155
2156 return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont");
2157}
2158
2159
2160bool
7fc63493 2161Perl_is_utf8_idcont(pTHX_ const U8 *p)
82686b01 2162{
97aff369 2163 dVAR;
7918f24d
NC
2164
2165 PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
2166
d4c19fe8 2167 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
a0ed51b3
LW
2168}
2169
2170bool
c11ff943
KW
2171Perl_is_utf8_xidcont(pTHX_ const U8 *p)
2172{
2173 dVAR;
2174
2175 PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
2176
c11ff943
KW
2177 return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue");
2178}
2179
2180bool
7fc63493 2181Perl_is_utf8_alpha(pTHX_ const U8 *p)
a0ed51b3 2182{
97aff369 2183 dVAR;
7918f24d
NC
2184
2185 PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
2186
03940dc2 2187 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_ALPHA], "IsAlpha");
a0ed51b3
LW
2188}
2189
2190bool
7fc63493 2191Perl_is_utf8_ascii(pTHX_ const U8 *p)
b8c5462f 2192{
97aff369 2193 dVAR;
7918f24d
NC
2194
2195 PERL_ARGS_ASSERT_IS_UTF8_ASCII;
2196
bc39fe24
KW
2197 /* ASCII characters are the same whether in utf8 or not. So the macro
2198 * works on both utf8 and non-utf8 representations. */
2199 return isASCII(*p);
b8c5462f
JH
2200}
2201
2202bool
bdd8600f
KW
2203Perl_is_utf8_blank(pTHX_ const U8 *p)
2204{
2205 dVAR;
2206
2207 PERL_ARGS_ASSERT_IS_UTF8_BLANK;
2208
2cafb56b 2209 return isBLANK_utf8(p);
bdd8600f
KW
2210}
2211
2212bool
7fc63493 2213Perl_is_utf8_space(pTHX_ const U8 *p)
a0ed51b3 2214{
97aff369 2215 dVAR;
7918f24d
NC
2216
2217 PERL_ARGS_ASSERT_IS_UTF8_SPACE;
2218
add4123a 2219 return isSPACE_utf8(p);
a0ed51b3
LW
2220}
2221
2222bool
d1eb3177
YO
2223Perl_is_utf8_perl_space(pTHX_ const U8 *p)
2224{
2225 dVAR;
2226
2227 PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
2228
c4428693
KW
2229 /* Only true if is an ASCII space-like character, and ASCII is invariant
2230 * under utf8, so can just use the macro */
2231 return isSPACE_A(*p);
d1eb3177
YO
2232}
2233
2234bool
2235Perl_is_utf8_perl_word(pTHX_ const U8 *p)
2236{
2237 dVAR;
2238
2239 PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
2240
c4428693
KW
2241 /* Only true if is an ASCII word character, and ASCII is invariant
2242 * under utf8, so can just use the macro */
2243 return isWORDCHAR_A(*p);
d1eb3177
YO
2244}
2245
2246bool
7fc63493 2247Perl_is_utf8_digit(pTHX_ const U8 *p)
a0ed51b3 2248{
97aff369 2249 dVAR;
7918f24d
NC
2250
2251 PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
2252
03940dc2 2253 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_DIGIT], "IsDigit");
a0ed51b3
LW
2254}
2255
2256bool
d1eb3177
YO
2257Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
2258{
2259 dVAR;
2260
2261 PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
2262
c4428693
KW
2263 /* Only true if is an ASCII digit character, and ASCII is invariant
2264 * under utf8, so can just use the macro */
2265 return isDIGIT_A(*p);
d1eb3177
YO
2266}
2267
2268bool
7fc63493 2269Perl_is_utf8_upper(pTHX_ const U8 *p)
a0ed51b3 2270{
97aff369 2271 dVAR;
7918f24d
NC
2272
2273 PERL_ARGS_ASSERT_IS_UTF8_UPPER;
2274
03940dc2 2275 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_UPPER], "IsUppercase");
a0ed51b3
LW
2276}
2277
2278bool
7fc63493 2279Perl_is_utf8_lower(pTHX_ const U8 *p)
a0ed51b3 2280{
97aff369 2281 dVAR;
7918f24d
NC
2282
2283 PERL_ARGS_ASSERT_IS_UTF8_LOWER;
2284
03940dc2 2285 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_LOWER], "IsLowercase");
a0ed51b3
LW
2286}
2287
2288bool
7fc63493 2289Perl_is_utf8_cntrl(pTHX_ const U8 *p)
b8c5462f 2290{
97aff369 2291 dVAR;
7918f24d
NC
2292
2293 PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
2294
a35d759a 2295 return isCNTRL_utf8(p);
b8c5462f
JH
2296}
2297
2298bool
7fc63493 2299Perl_is_utf8_graph(pTHX_ const U8 *p)
b8c5462f 2300{
97aff369 2301 dVAR;
7918f24d
NC
2302
2303 PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
2304
03940dc2 2305 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_GRAPH], "IsGraph");
b8c5462f
JH
2306}
2307
2308bool
7fc63493 2309Perl_is_utf8_print(pTHX_ const U8 *p)
a0ed51b3 2310{
97aff369 2311 dVAR;
7918f24d
NC
2312
2313 PERL_ARGS_ASSERT_IS_UTF8_PRINT;
2314
03940dc2 2315 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PRINT], "IsPrint");
a0ed51b3
LW
2316}
2317
2318bool
7fc63493 2319Perl_is_utf8_punct(pTHX_ const U8 *p)
b8c5462f 2320{
97aff369 2321 dVAR;
7918f24d
NC
2322
2323 PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
2324
03940dc2 2325 return is_utf8_common(p, &PL_utf8_swash_ptrs[_CC_PUNCT], "IsPunct");
b8c5462f
JH
2326}
2327
2328bool
7fc63493 2329Perl_is_utf8_xdigit(pTHX_ const U8 *p)
b8c5462f 2330{
97aff369 2331 dVAR;
7918f24d
NC
2332
2333 PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
2334
4ac6419d 2335 return is_XDIGIT_utf8(p);
b8c5462f
JH
2336}
2337
2338bool
7dbf68d2
KW
2339Perl__is_utf8_mark(pTHX_ const U8 *p)
2340{
2341 dVAR;
2342
2343 PERL_ARGS_ASSERT__IS_UTF8_MARK;
2344
2345 return is_utf8_common(p, &PL_utf8_mark, "IsM");
2346}
2347
2348
2349bool
7fc63493 2350Perl_is_utf8_mark(pTHX_ const U8 *p)
a0ed51b3 2351{
97aff369 2352 dVAR;
7918f24d
NC
2353
2354 PERL_ARGS_ASSERT_IS_UTF8_MARK;
2355
7dbf68d2 2356 return _is_utf8_mark(p);
a0ed51b3
LW
2357}
2358
6b5c0936 2359/*
87cea99e 2360=for apidoc to_utf8_case
6b5c0936 2361
a1433954
KW
2362The C<p> contains the pointer to the UTF-8 string encoding
2363the character that is being converted. This routine assumes that the character
2364at C<p> is well-formed.
6b5c0936 2365
a1433954
KW
2366The C<ustrp> is a pointer to the character buffer to put the
2367conversion result to. The C<lenp> is a pointer to the length
6b5c0936
JH
2368of the result.
2369
a1433954 2370The C<swashp> is a pointer to the swash to use.
6b5c0936 2371
a1433954
KW
2372Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
2373and loaded by SWASHNEW, using F<lib/utf8_heavy.pl>. The C<special> (usually,
0134edef 2374but not always, a multicharacter mapping), is tried first.
6b5c0936 2375
a1433954 2376The C<special> is a string like "utf8::ToSpecLower", which means the
0134edef
JH
2377hash %utf8::ToSpecLower. The access to the hash is through
2378Perl_to_utf8_case().
6b5c0936 2379
a1433954 2380The C<normal> is a string like "ToLower" which means the swash
0134edef
JH
2381%utf8::ToLower.
2382
2383=cut */
6b5c0936 2384
2104c8d9 2385UV
9a957fbc
AL
2386Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
2387 SV **swashp, const char *normal, const char *special)
a0ed51b3 2388{
97aff369 2389 dVAR;
89ebb4a3 2390 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
0134edef 2391 STRLEN len = 0;
4b88fb76 2392 const UV uv0 = valid_utf8_to_uvchr(p, NULL);
1feea2c7
JH
2393 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
2394 * are necessary in EBCDIC, they are redundant no-ops
2395 * in ASCII-ish platforms, and hopefully optimized away. */
f54cb97a 2396 const UV uv1 = NATIVE_TO_UNI(uv0);
7918f24d
NC
2397
2398 PERL_ARGS_ASSERT_TO_UTF8_CASE;
2399
9ae3ac1a
KW
2400 /* Note that swash_fetch() doesn't output warnings for these because it
2401 * assumes we will */
8457b38f 2402 if (uv1 >= UNICODE_SURROGATE_FIRST) {
9ae3ac1a 2403 if (uv1 <= UNICODE_SURROGATE_LAST) {
8457b38f
KW
2404 if (ckWARN_d(WARN_SURROGATE)) {
2405 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2406 Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
2407 "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1);
2408 }
9ae3ac1a
KW
2409 }
2410 else if (UNICODE_IS_SUPER(uv1)) {
8457b38f
KW
2411 if (ckWARN_d(WARN_NON_UNICODE)) {
2412 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2413 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
2414 "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1);
2415 }
9ae3ac1a
KW
2416 }
2417
2418 /* Note that non-characters are perfectly legal, so no warning should
2419 * be given */
2420 }
2421
1feea2c7 2422 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
2423
2424 if (!*swashp) /* load on-demand */
5ab9d2ef 2425 *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
0134edef 2426
a6f87d8c 2427 if (special) {
0134edef 2428 /* It might be "special" (sometimes, but not always,
2a37f04d 2429 * a multicharacter mapping) */
6673a63c 2430 HV * const hv = get_hv(special, 0);
b08cf34e
JH
2431 SV **svp;
2432
35da51f7 2433 if (hv &&
b08cf34e
JH
2434 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
2435 (*svp)) {
cfd0369c 2436 const char *s;
47654450 2437
cfd0369c 2438 s = SvPV_const(*svp, len);
47654450
JH
2439 if (len == 1)
2440 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 2441 else {
2f9475ad
JH
2442#ifdef EBCDIC
2443 /* If we have EBCDIC we need to remap the characters
2444 * since any characters in the low 256 are Unicode
2445 * code points, not EBCDIC. */
7cda7a3d 2446 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
2447
2448 d = tmpbuf;
b08cf34e 2449 if (SvUTF8(*svp)) {
2f9475ad
JH
2450 STRLEN tlen = 0;
2451
2452 while (t < tend) {
6bd1c396 2453 const UV c = utf8_to_uvchr_buf(t, tend, &tlen);
2f9475ad
JH
2454 if (tlen > 0) {
2455 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
2456 t += tlen;
2457 }
2458 else
2459 break;
2460 }
2461 }
2462 else {
36fec512
JH
2463 while (t < tend) {
2464 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
2465 t++;
2466 }
2f9475ad
JH
2467 }
2468 len = d - tmpbuf;
2469 Copy(tmpbuf, ustrp, len, U8);
2470#else
d2dcd0fb 2471 Copy(s, ustrp, len, U8);
2f9475ad 2472#endif
29e98929 2473 }
983ffd37 2474 }
0134edef
JH
2475 }
2476
2477 if (!len && *swashp) {
2114036c 2478 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE /* => is utf8 */);
d4c19fe8 2479
0134edef
JH
2480 if (uv2) {
2481 /* It was "normal" (a single character mapping). */
d4c19fe8 2482 const UV uv3 = UNI_TO_NATIVE(uv2);
e9101d72 2483 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2a37f04d
JH
2484 }
2485 }
1feea2c7 2486
cbe07460
KW
2487 if (len) {
2488 if (lenp) {
2489 *lenp = len;
2490 }
2491 return valid_utf8_to_uvchr(ustrp, 0);
2492 }
2493
2494 /* Here, there was no mapping defined, which means that the code point maps
2495 * to itself. Return the inputs */
bfdf22ec 2496 len = UTF8SKIP(p);
ca9fab46
KW
2497 if (p != ustrp) { /* Don't copy onto itself */
2498 Copy(p, ustrp, len, U8);
2499 }
0134edef 2500
2a37f04d
JH
2501 if (lenp)
2502 *lenp = len;
2503
cbe07460
KW
2504 return uv0;
2505
a0ed51b3
LW
2506}
2507
051a06d4
KW
2508STATIC UV
2509S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
2510{
2511 /* This is called when changing the case of a utf8-encoded character above
2512 * the Latin1 range, and the operation is in locale. If the result
2513 * contains a character that crosses the 255/256 boundary, disallow the
2514 * change, and return the original code point. See L<perlfunc/lc> for why;
2515 *
a1433954
KW
2516 * p points to the original string whose case was changed; assumed
2517 * by this routine to be well-formed
051a06d4
KW
2518 * result the code point of the first character in the changed-case string
2519 * ustrp points to the changed-case string (<result> represents its first char)
2520 * lenp points to the length of <ustrp> */
2521
2522 UV original; /* To store the first code point of <p> */
2523
2524 PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
2525
a4f12ed7 2526 assert(UTF8_IS_ABOVE_LATIN1(*p));
051a06d4
KW
2527
2528 /* We know immediately if the first character in the string crosses the
2529 * boundary, so can skip */
2530 if (result > 255) {
2531
2532 /* Look at every character in the result; if any cross the
2533 * boundary, the whole thing is disallowed */
2534 U8* s = ustrp + UTF8SKIP(ustrp);
2535 U8* e = ustrp + *lenp;
2536 while (s < e) {
a4f12ed7 2537 if (! UTF8_IS_ABOVE_LATIN1(*s)) {
051a06d4
KW
2538 goto bad_crossing;
2539 }
2540 s += UTF8SKIP(s);
2541 }
2542
2543 /* Here, no characters crossed, result is ok as-is */
2544 return result;
2545 }
2546
2547bad_crossing:
2548
2549 /* Failed, have to return the original */
4b88fb76 2550 original = valid_utf8_to_uvchr(p, lenp);
051a06d4
KW
2551 Copy(p, ustrp, *lenp, char);
2552 return original;
2553}
2554
d3e79532 2555/*
87cea99e 2556=for apidoc to_utf8_upper
d3e79532 2557
1f607577 2558Instead use L</toUPPER_utf8>.
a1433954 2559
d3e79532
JH
2560=cut */
2561
051a06d4
KW
2562/* Not currently externally documented, and subject to change:
2563 * <flags> is set iff locale semantics are to be used for code points < 256
2564 * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2565 * were used in the calculation; otherwise unchanged. */
2566
2104c8d9 2567UV
051a06d4 2568Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
a0ed51b3 2569{
97aff369 2570 dVAR;
7918f24d 2571
051a06d4
KW
2572 UV result;
2573
2574 PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
7918f24d 2575
3a4c58c9 2576 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
2577 if (flags) {
2578 result = toUPPER_LC(*p);
2579 }
2580 else {
81c6c7ce 2581 return _to_upper_title_latin1(*p, ustrp, lenp, 'S');
051a06d4 2582 }
3a4c58c9
KW
2583 }
2584 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4
KW
2585 if (flags) {
2586 result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2587 }
2588 else {
81c6c7ce
KW
2589 return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2590 ustrp, lenp, 'S');
051a06d4
KW
2591 }
2592 }
2593 else { /* utf8, ord above 255 */
2594 result = CALL_UPPER_CASE(p, ustrp, lenp);
2595
2596 if (flags) {
2597 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2598 }
2599 return result;
2600 }
2601
2602 /* Here, used locale rules. Convert back to utf8 */
2603 if (UTF8_IS_INVARIANT(result)) {
2604 *ustrp = (U8) result;
2605 *lenp = 1;
2606 }
2607 else {
2608 *ustrp = UTF8_EIGHT_BIT_HI(result);
2609 *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2610 *lenp = 2;
3a4c58c9
KW
2611 }
2612
051a06d4
KW
2613 if (tainted_ptr) {
2614 *tainted_ptr = TRUE;
2615 }
2616 return result;
983ffd37 2617}
a0ed51b3 2618
d3e79532 2619/*
87cea99e 2620=for apidoc to_utf8_title
d3e79532 2621
1f607577 2622Instead use L</toTITLE_utf8>.
a1433954 2623
d3e79532
JH
2624=cut */
2625
051a06d4
KW
2626/* Not currently externally documented, and subject to change:
2627 * <flags> is set iff locale semantics are to be used for code points < 256
2628 * Since titlecase is not defined in POSIX, uppercase is used instead
2629 * for these/
2630 * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2631 * were used in the calculation; otherwise unchanged. */
2632
983ffd37 2633UV
051a06d4 2634Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
983ffd37 2635{
97aff369 2636 dVAR;
7918f24d 2637
051a06d4
KW
2638 UV result;
2639
2640 PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
7918f24d 2641
3a4c58c9 2642 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
2643 if (flags) {
2644 result = toUPPER_LC(*p);
2645 }
2646 else {
81c6c7ce 2647 return _to_upper_title_latin1(*p, ustrp, lenp, 's');
051a06d4 2648 }
3a4c58c9
KW
2649 }
2650 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4
KW
2651 if (flags) {
2652 result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2653 }
2654 else {
81c6c7ce
KW
2655 return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2656 ustrp, lenp, 's');
051a06d4
KW
2657 }
2658 }
2659 else { /* utf8, ord above 255 */
2660 result = CALL_TITLE_CASE(p, ustrp, lenp);
2661
2662 if (flags) {
2663 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2664 }
2665 return result;
2666 }
2667
2668 /* Here, used locale rules. Convert back to utf8 */
2669 if (UTF8_IS_INVARIANT(result)) {
2670 *ustrp = (U8) result;
2671 *lenp = 1;
2672 }
2673 else {
2674 *ustrp = UTF8_EIGHT_BIT_HI(result);
2675 *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2676 *lenp = 2;
3a4c58c9
KW
2677 }
2678
051a06d4
KW
2679 if (tainted_ptr) {
2680 *tainted_ptr = TRUE;
2681 }
2682 return result;
a0ed51b3
LW
2683}
2684
d3e79532 2685/*
87cea99e 2686=for apidoc to_utf8_lower
d3e79532 2687
1f607577 2688Instead use L</toLOWER_utf8>.
a1433954 2689
d3e79532
JH
2690=cut */
2691
051a06d4
KW
2692/* Not currently externally documented, and subject to change:
2693 * <flags> is set iff locale semantics are to be used for code points < 256
2694 * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2695 * were used in the calculation; otherwise unchanged. */
2696
2104c8d9 2697UV
051a06d4 2698Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
a0ed51b3 2699{
051a06d4
KW
2700 UV result;
2701
97aff369 2702 dVAR;
7918f24d 2703
051a06d4 2704 PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
7918f24d 2705
968c5e6a 2706 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
2707 if (flags) {
2708 result = toLOWER_LC(*p);
2709 }
2710 else {
81c6c7ce 2711 return to_lower_latin1(*p, ustrp, lenp);
051a06d4 2712 }
968c5e6a
KW
2713 }
2714 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4
KW
2715 if (flags) {
2716 result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2717 }
2718 else {
81c6c7ce
KW
2719 return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2720 ustrp, lenp);
051a06d4 2721 }
968c5e6a 2722 }
051a06d4
KW
2723 else { /* utf8, ord above 255 */
2724 result = CALL_LOWER_CASE(p, ustrp, lenp);
2725
2726 if (flags) {
2727 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2728 }
968c5e6a 2729
051a06d4
KW
2730 return result;
2731 }
2732
2733 /* Here, used locale rules. Convert back to utf8 */
2734 if (UTF8_IS_INVARIANT(result)) {
2735 *ustrp = (U8) result;
2736 *lenp = 1;
2737 }
2738 else {
2739 *ustrp = UTF8_EIGHT_BIT_HI(result);
2740 *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2741 *lenp = 2;
2742 }
2743
2744 if (tainted_ptr) {
2745 *tainted_ptr = TRUE;
2746 }
2747 return result;
b4e400f9
JH
2748}
2749
d3e79532 2750/*
87cea99e 2751=for apidoc to_utf8_fold
d3e79532 2752
1f607577 2753Instead use L</toFOLD_utf8>.
a1433954 2754
d3e79532
JH
2755=cut */
2756
051a06d4
KW
2757/* Not currently externally documented, and subject to change,
2758 * in <flags>
2759 * bit FOLD_FLAGS_LOCALE is set iff locale semantics are to be used for code
2760 * points < 256. Since foldcase is not defined in
2761 * POSIX, lowercase is used instead
2762 * bit FOLD_FLAGS_FULL is set iff full case folds are to be used;
2763 * otherwise simple folds
a0270393
KW
2764 * bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are
2765 * prohibited
051a06d4
KW
2766 * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2767 * were used in the calculation; otherwise unchanged. */
36bb2ab6 2768
b4e400f9 2769UV
051a06d4 2770Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr)
b4e400f9 2771{
97aff369 2772 dVAR;
7918f24d 2773
051a06d4
KW
2774 UV result;
2775
36bb2ab6 2776 PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
7918f24d 2777
a0270393
KW
2778 /* These are mutually exclusive */
2779 assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
2780
50ba90ff
KW
2781 assert(p != ustrp); /* Otherwise overwrites */
2782
a1dde8de 2783 if (UTF8_IS_INVARIANT(*p)) {
051a06d4 2784 if (flags & FOLD_FLAGS_LOCALE) {
d22b930b 2785 result = toFOLD_LC(*p);
051a06d4
KW
2786 }
2787 else {
81c6c7ce 2788 return _to_fold_latin1(*p, ustrp, lenp,
1ca267a5 2789 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
051a06d4 2790 }
a1dde8de
KW
2791 }
2792 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4 2793 if (flags & FOLD_FLAGS_LOCALE) {
d22b930b 2794 result = toFOLD_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
051a06d4
KW
2795 }
2796 else {
81c6c7ce 2797 return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
51910141 2798 ustrp, lenp,
1ca267a5 2799 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
051a06d4 2800 }
a1dde8de 2801 }
051a06d4 2802 else { /* utf8, ord above 255 */
a0270393 2803 result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
a1dde8de 2804
1ca267a5
KW
2805 if (flags & FOLD_FLAGS_LOCALE) {
2806
2807 /* Special case this character, as what normally gets returned
2808 * under locale doesn't work */
2809 if (UTF8SKIP(p) == sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1
2810 && memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
2811 sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1))
2812 {
2813 goto return_long_s;
2814 }
a0270393 2815 return check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4 2816 }
a0270393
KW
2817 else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
2818 return result;
2819 }
2820 else {
2821 /* This is called when changing the case of a utf8-encoded
2822 * character above the Latin1 range, and the result should not
2823 * contain an ASCII character. */
2824
2825 UV original; /* To store the first code point of <p> */
2826
2827 /* Look at every character in the result; if any cross the
2828 * boundary, the whole thing is disallowed */
2829 U8* s = ustrp;
2830 U8* e = ustrp + *lenp;
2831 while (s < e) {
2832 if (isASCII(*s)) {
2833 /* Crossed, have to return the original */
2834 original = valid_utf8_to_uvchr(p, lenp);
1ca267a5
KW
2835
2836 /* But in this one instance, there is an alternative we can
2837 * return that is valid */
2838 if (original == LATIN_CAPITAL_LETTER_SHARP_S) {
2839 goto return_long_s;
2840 }
a0270393
KW
2841 Copy(p, ustrp, *lenp, char);
2842 return original;
2843 }
2844 s += UTF8SKIP(s);
2845 }
051a06d4 2846
a0270393
KW
2847 /* Here, no characters crossed, result is ok as-is */
2848 return result;
2849 }
051a06d4
KW
2850 }
2851
2852 /* Here, used locale rules. Convert back to utf8 */
2853 if (UTF8_IS_INVARIANT(result)) {
2854 *ustrp = (U8) result;
2855 *lenp = 1;
2856 }
2857 else {
2858 *ustrp = UTF8_EIGHT_BIT_HI(result);
2859 *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2860 *lenp = 2;
2861 }
2862
2863 if (tainted_ptr) {
2864 *tainted_ptr = TRUE;
2865 }
2866 return result;
1ca267a5
KW
2867
2868 return_long_s:
2869 /* Certain folds to 'ss' are prohibited by the options, but they do allow
2870 * folds to a string of two of these characters. By returning this
2871 * instead, then, e.g.,
2872 * fc("\x{1E9E}") eq fc("\x{17F}\x{17F}")
2873 * works. */
2874
2875 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
2876 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
2877 ustrp, *lenp, U8);
2878 return LATIN_SMALL_LETTER_LONG_S;
a0ed51b3
LW
2879}
2880
711a919c 2881/* Note:
f90a9a02 2882 * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().
711a919c
ST
2883 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
2884 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
2885 */
c4a5db0c 2886
a0ed51b3 2887SV*
7fc63493 2888Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3 2889{
c4a5db0c
KW
2890 PERL_ARGS_ASSERT_SWASH_INIT;
2891
2892 /* Returns a copy of a swash initiated by the called function. This is the
2893 * public interface, and returning a copy prevents others from doing
2894 * mischief on the original */
2895
5d3d13d1 2896 return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, NULL, NULL));
c4a5db0c
KW
2897}
2898
2899SV*
5d3d13d1 2900Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
c4a5db0c
KW
2901{
2902 /* Initialize and return a swash, creating it if necessary. It does this
87367d5f
KW
2903 * by calling utf8_heavy.pl in the general case. The returned value may be
2904 * the swash's inversion list instead if the input parameters allow it.
2905 * Which is returned should be immaterial to callers, as the only
923b6d4e
KW
2906 * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
2907 * and swash_to_invlist() handle both these transparently.
c4a5db0c
KW
2908 *
2909 * This interface should only be used by functions that won't destroy or
2910 * adversely change the swash, as doing so affects all other uses of the
2911 * swash in the program; the general public should use 'Perl_swash_init'
2912 * instead.
2913 *
2914 * pkg is the name of the package that <name> should be in.
2915 * name is the name of the swash to find. Typically it is a Unicode
2916 * property name, including user-defined ones
2917 * listsv is a string to initialize the swash with. It must be of the form
2918 * documented as the subroutine return value in
2919 * L<perlunicode/User-Defined Character Properties>
2920 * minbits is the number of bits required to represent each data element.
2921 * It is '1' for binary properties.
2922 * none I (khw) do not understand this one, but it is used only in tr///.
9a53f6cf 2923 * invlist is an inversion list to initialize the swash with (or NULL)
83199d38
KW
2924 * flags_p if non-NULL is the address of various input and output flag bits
2925 * to the routine, as follows: ('I' means is input to the routine;
2926 * 'O' means output from the routine. Only flags marked O are
2927 * meaningful on return.)
2928 * _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
2929 * came from a user-defined property. (I O)
5d3d13d1
KW
2930 * _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
2931 * when the swash cannot be located, to simply return NULL. (I)
87367d5f
KW
2932 * _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
2933 * return of an inversion list instead of a swash hash if this routine
2934 * thinks that would result in faster execution of swash_fetch() later
2935 * on. (I)
9a53f6cf
KW
2936 *
2937 * Thus there are three possible inputs to find the swash: <name>,
2938 * <listsv>, and <invlist>. At least one must be specified. The result
2939 * will be the union of the specified ones, although <listsv>'s various
2940 * actions can intersect, etc. what <name> gives.
2941 *
2942 * <invlist> is only valid for binary properties */
c4a5db0c 2943
27da23d5 2944 dVAR;
c4a5db0c 2945 SV* retval = &PL_sv_undef;
83199d38 2946 HV* swash_hv = NULL;
87367d5f
KW
2947 const int invlist_swash_boundary =
2948 (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
2949 ? 512 /* Based on some benchmarking, but not extensive, see commit
2950 message */
2951 : -1; /* Never return just an inversion list */
9a53f6cf
KW
2952
2953 assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
2954 assert(! invlist || minbits == 1);
2955
2956 /* If data was passed in to go out to utf8_heavy to find the swash of, do
2957 * so */
2958 if (listsv != &PL_sv_undef || strNE(name, "")) {
69794297
KW
2959 dSP;
2960 const size_t pkg_len = strlen(pkg);
2961 const size_t name_len = strlen(name);
2962 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
2963 SV* errsv_save;
2964 GV *method;
2965
2966 PERL_ARGS_ASSERT__CORE_SWASH_INIT;
2967
2968 PUSHSTACKi(PERLSI_MAGIC);
ce3b816e 2969 ENTER;
69794297
KW
2970 SAVEHINTS();
2971 save_re_context();
650f067c
JL
2972 /* We might get here via a subroutine signature which uses a utf8
2973 * parameter name, at which point PL_subname will have been set
2974 * but not yet used. */
2975 save_item(PL_subname);
69794297
KW
2976 if (PL_parser && PL_parser->error_count)
2977 SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
2978 method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
2979 if (!method) { /* demand load utf8 */
2980 ENTER;
db2c6cb3
FC
2981 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
2982 GvSV(PL_errgv) = NULL;
69794297
KW
2983 /* It is assumed that callers of this routine are not passing in
2984 * any user derived data. */
2985 /* Need to do this after save_re_context() as it will set
2986 * PL_tainted to 1 while saving $1 etc (see the code after getrx:
2987 * in Perl_magic_get). Even line to create errsv_save can turn on
2988 * PL_tainted. */
284167a5
SM
2989#ifndef NO_TAINT_SUPPORT
2990 SAVEBOOL(TAINT_get);
2991 TAINT_NOT;
2992#endif
69794297
KW
2993 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
2994 NULL);
eed484f9 2995 {
db2c6cb3
FC
2996 /* Not ERRSV, as there is no need to vivify a scalar we are
2997 about to discard. */
2998 SV * const errsv = GvSV(PL_errgv);
2999 if (!SvTRUE(errsv)) {
3000 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
3001 SvREFCNT_dec(errsv);
3002 }
eed484f9 3003 }
69794297
KW
3004 LEAVE;
3005 }
3006 SPAGAIN;
3007 PUSHMARK(SP);
3008 EXTEND(SP,5);
3009 mPUSHp(pkg, pkg_len);
3010 mPUSHp(name, name_len);
3011 PUSHs(listsv);
3012 mPUSHi(minbits);
3013 mPUSHi(none);
3014 PUTBACK;
db2c6cb3
FC
3015 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
3016 GvSV(PL_errgv) = NULL;
69794297
KW
3017 /* If we already have a pointer to the method, no need to use
3018 * call_method() to repeat the lookup. */
c41800a8
KW
3019 if (method
3020 ? call_sv(MUTABLE_SV(method), G_SCALAR)
69794297
KW
3021 : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
3022 {
3023 retval = *PL_stack_sp--;
3024 SvREFCNT_inc(retval);
3025 }
eed484f9 3026 {
db2c6cb3
FC
3027 /* Not ERRSV. See above. */
3028 SV * const errsv = GvSV(PL_errgv);
3029 if (!SvTRUE(errsv)) {
3030 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
3031 SvREFCNT_dec(errsv);
3032 }
eed484f9 3033 }
ce3b816e 3034 LEAVE;
69794297
KW
3035 POPSTACK;
3036 if (IN_PERL_COMPILETIME) {
3037 CopHINTS_set(PL_curcop, PL_hints);
3038 }
3039 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
3040 if (SvPOK(retval))
3041
3042 /* If caller wants to handle missing properties, let them */
5d3d13d1 3043 if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
69794297
KW
3044 return NULL;
3045 }
3046 Perl_croak(aTHX_
3047 "Can't find Unicode property definition \"%"SVf"\"",
3048 SVfARG(retval));
3049 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
3050 }
9a53f6cf 3051 } /* End of calling the module to find the swash */
36eb48b4 3052
83199d38
KW
3053 /* If this operation fetched a swash, and we will need it later, get it */
3054 if (retval != &PL_sv_undef
3055 && (minbits == 1 || (flags_p
3056 && ! (*flags_p
3057 & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
3058 {
3059 swash_hv = MUTABLE_HV(SvRV(retval));
3060
3061 /* If we don't already know that there is a user-defined component to
3062 * this swash, and the user has indicated they wish to know if there is
3063 * one (by passing <flags_p>), find out */
3064 if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
3065 SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
3066 if (user_defined && SvUV(*user_defined)) {
3067 *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
3068 }
3069 }
3070 }
3071
36eb48b4
KW
3072 /* Make sure there is an inversion list for binary properties */
3073 if (minbits == 1) {
3074 SV** swash_invlistsvp = NULL;
3075 SV* swash_invlist = NULL;
9a53f6cf 3076 bool invlist_in_swash_is_valid = FALSE;
02c85471
FC
3077 bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
3078 an unclaimed reference count */
36eb48b4 3079
9a53f6cf 3080 /* If this operation fetched a swash, get its already existing
83199d38 3081 * inversion list, or create one for it */
36eb48b4 3082
83199d38 3083 if (swash_hv) {
5c9f4bd2 3084 swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
9a53f6cf
KW
3085 if (swash_invlistsvp) {
3086 swash_invlist = *swash_invlistsvp;
3087 invlist_in_swash_is_valid = TRUE;
3088 }
3089 else {
36eb48b4 3090 swash_invlist = _swash_to_invlist(retval);
02c85471 3091 swash_invlist_unclaimed = TRUE;
9a53f6cf
KW
3092 }
3093 }
3094
3095 /* If an inversion list was passed in, have to include it */
3096 if (invlist) {
3097
3098 /* Any fetched swash will by now have an inversion list in it;
3099 * otherwise <swash_invlist> will be NULL, indicating that we
3100 * didn't fetch a swash */
3101 if (swash_invlist) {
3102
3103 /* Add the passed-in inversion list, which invalidates the one
3104 * already stored in the swash */
3105 invlist_in_swash_is_valid = FALSE;
3106 _invlist_union(invlist, swash_invlist, &swash_invlist);
3107 }
3108 else {
3109
87367d5f
KW
3110 /* Here, there is no swash already. Set up a minimal one, if
3111 * we are going to return a swash */
3112 if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
971d486f 3113 swash_hv = newHV();
4aca0fe6 3114 retval = newRV_noinc(MUTABLE_SV(swash_hv));
87367d5f 3115 }
9a53f6cf
KW
3116 swash_invlist = invlist;
3117 }
9a53f6cf
KW
3118 }
3119
3120 /* Here, we have computed the union of all the passed-in data. It may
3121 * be that there was an inversion list in the swash which didn't get
3122 * touched; otherwise save the one computed one */
87367d5f
KW
3123 if (! invlist_in_swash_is_valid
3124 && (int) _invlist_len(swash_invlist) > invlist_swash_boundary)
3125 {
5c9f4bd2 3126 if (! hv_stores(MUTABLE_HV(SvRV(retval)), "V", swash_invlist))
69794297
KW
3127 {
3128 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3129 }
cc34d8c5
FC
3130 /* We just stole a reference count. */
3131 if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
3132 else SvREFCNT_inc_simple_void_NN(swash_invlist);
9a53f6cf 3133 }
87367d5f 3134
c41800a8 3135 /* Use the inversion list stand-alone if small enough */
87367d5f
KW
3136 if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
3137 SvREFCNT_dec(retval);
02c85471
FC
3138 if (!swash_invlist_unclaimed)
3139 SvREFCNT_inc_simple_void_NN(swash_invlist);
3140 retval = newRV_noinc(swash_invlist);
87367d5f 3141 }
36eb48b4
KW
3142 }
3143
a0ed51b3
LW
3144 return retval;
3145}
3146
035d37be
JH
3147
3148/* This API is wrong for special case conversions since we may need to
3149 * return several Unicode characters for a single Unicode character
3150 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
3151 * the lower-level routine, and it is similarly broken for returning
38684baa
KW
3152 * multiple values. --jhi
3153 * For those, you should use to_utf8_case() instead */
b0e3252e 3154/* Now SWASHGET is recasted into S_swatch_get in this file. */
680c470c
ST
3155
3156/* Note:
3157 * Returns the value of property/mapping C<swash> for the first character
3158 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
3159 * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
3160 * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
af2af982
KW
3161 *
3162 * A "swash" is a hash which contains initially the keys/values set up by
3163 * SWASHNEW. The purpose is to be able to completely represent a Unicode
3164 * property for all possible code points. Things are stored in a compact form
3165 * (see utf8_heavy.pl) so that calculation is required to find the actual
3166 * property value for a given code point. As code points are looked up, new
3167 * key/value pairs are added to the hash, so that the calculation doesn't have
3168 * to ever be re-done. Further, each calculation is done, not just for the
3169 * desired one, but for a whole block of code points adjacent to that one.
3170 * For binary properties on ASCII machines, the block is usually for 64 code
3171 * points, starting with a code point evenly divisible by 64. Thus if the
3172 * property value for code point 257 is requested, the code goes out and
3173 * calculates the property values for all 64 code points between 256 and 319,
3174 * and stores these as a single 64-bit long bit vector, called a "swatch",
3175 * under the key for code point 256. The key is the UTF-8 encoding for code
3176 * point 256, minus the final byte. Thus, if the length of the UTF-8 encoding
3177 * for a code point is 13 bytes, the key will be 12 bytes long. If the value
3178 * for code point 258 is then requested, this code realizes that it would be
3179 * stored under the key for 256, and would find that value and extract the
3180 * relevant bit, offset from 256.
3181 *
3182 * Non-binary properties are stored in as many bits as necessary to represent
3183 * their values (32 currently, though the code is more general than that), not
3184 * as single bits, but the principal is the same: the value for each key is a
3185 * vector that encompasses the property values for all code points whose UTF-8
3186 * representations are represented by the key. That is, for all code points
3187 * whose UTF-8 representations are length N bytes, and the key is the first N-1
3188 * bytes of that.
680c470c 3189 */
a0ed51b3 3190UV
680c470c 3191Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
a0ed51b3 3192{
27da23d5 3193 dVAR;
ef8f7699 3194 HV *const hv = MUTABLE_HV(SvRV(swash));
3568d838
JH
3195 U32 klen;
3196 U32 off;
a0ed51b3 3197 STRLEN slen;
7d85a32c 3198 STRLEN needents;
cfd0369c 3199 const U8 *tmps = NULL;
a0ed51b3 3200 U32 bit;
979f2922 3201 SV *swatch;
3568d838 3202 U8 tmputf8[2];
35da51f7 3203 const UV c = NATIVE_TO_ASCII(*ptr);
3568d838 3204
7918f24d
NC
3205 PERL_ARGS_ASSERT_SWASH_FETCH;
3206
87367d5f
KW
3207 /* If it really isn't a hash, it isn't really swash; must be an inversion
3208 * list */
3209 if (SvTYPE(hv) != SVt_PVHV) {
3210 return _invlist_contains_cp((SV*)hv,
3211 (do_utf8)
3212 ? valid_utf8_to_uvchr(ptr, NULL)
3213 : c);
3214 }
3215
dbe7a391 3216 /* Convert to utf8 if not already */
3568d838 3217 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
979f2922
ST
3218 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
3219 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
3220 ptr = tmputf8;
3568d838
JH
3221 }
3222 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
37e2e78e 3223 * then the "swatch" is a vec() for all the chars which start
3568d838
JH
3224 * with 0xAA..0xYY
3225 * So the key in the hash (klen) is length of encoded char -1
3226 */
3227 klen = UTF8SKIP(ptr) - 1;
a0ed51b3 3228
979f2922 3229 if (klen == 0) {
37e2e78e 3230 /* If char is invariant then swatch is for all the invariant chars
1e54db1a 3231 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
7d85a32c 3232 */
979f2922 3233 needents = UTF_CONTINUATION_MARK;
bc3632a8 3234 off = NATIVE_UTF8_TO_I8(ptr[klen]);
979f2922
ST
3235 }
3236 else {
7d85a32c 3237 /* If char is encoded then swatch is for the prefix */
979f2922 3238 needents = (1 << UTF_ACCUMULATION_SHIFT);
bc3632a8 3239 off = NATIVE_UTF8_TO_I8(ptr[klen]) & UTF_CONTINUATION_MASK;
979f2922 3240 }
7d85a32c 3241
a0ed51b3
LW
3242 /*
3243 * This single-entry cache saves about 1/3 of the utf8 overhead in test
3244 * suite. (That is, only 7-8% overall over just a hash cache. Still,
3245 * it's nothing to sniff at.) Pity we usually come through at least
3246 * two function calls to get here...
3247 *
3248 * NB: this code assumes that swatches are never modified, once generated!
3249 */
3250
3568d838 3251 if (hv == PL_last_swash_hv &&
a0ed51b3 3252 klen == PL_last_swash_klen &&
27da23d5 3253 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
3254 {
3255 tmps = PL_last_swash_tmps;
3256 slen = PL_last_swash_slen;
3257 }
3258 else {
3259 /* Try our second-level swatch cache, kept in a hash. */
e1ec3a88 3260 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
a0ed51b3 3261
b0e3252e 3262 /* If not cached, generate it via swatch_get */
979f2922
ST
3263 if (!svp || !SvPOK(*svp)
3264 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2b9d42f0
NIS
3265 /* We use utf8n_to_uvuni() as we want an index into
3266 Unicode tables, not a native character number.
3267 */
aec46f14 3268 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
872c91ae
JH
3269 ckWARN(WARN_UTF8) ?
3270 0 : UTF8_ALLOW_ANY);
b0e3252e 3271 swatch = swatch_get(swash,
979f2922 3272 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
361ee0fe 3273 (klen) ? (code_point & ~((UV)needents - 1)) : 0,
979f2922
ST
3274 needents);
3275
923e4eb5 3276 if (IN_PERL_COMPILETIME)
623e6609 3277 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 3278
979f2922 3279 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
a0ed51b3 3280
979f2922
ST
3281 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
3282 || (slen << 3) < needents)
5637ef5b
NC
3283 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch, "
3284 "svp=%p, tmps=%p, slen=%"UVuf", needents=%"UVuf,
3285 svp, tmps, (UV)slen, (UV)needents);
a0ed51b3
LW
3286 }
3287
3288 PL_last_swash_hv = hv;
16d8f38a 3289 assert(klen <= sizeof(PL_last_swash_key));
eac04b2e 3290 PL_last_swash_klen = (U8)klen;
cfd0369c
NC
3291 /* FIXME change interpvar.h? */
3292 PL_last_swash_tmps = (U8 *) tmps;
a0ed51b3
LW
3293 PL_last_swash_slen = slen;
3294 if (klen)
3295 Copy(ptr, PL_last_swash_key, klen, U8);
3296 }
3297
9faf8d75 3298 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
3299 case 1:
3300 bit = 1 << (off & 7);
3301 off >>= 3;
3302 return (tmps[off] & bit) != 0;
3303 case 8:
3304 return tmps[off];
3305 case 16:
3306 off <<= 1;
3307 return (tmps[off] << 8) + tmps[off + 1] ;
3308 case 32:
3309 off <<= 2;
3310 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
3311 }
5637ef5b
NC
3312 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
3313 "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);
670f1322 3314 NORETURN_FUNCTION_END;
a0ed51b3 3315}
2b9d42f0 3316
319009ee
KW
3317/* Read a single line of the main body of the swash input text. These are of
3318 * the form:
3319 * 0053 0056 0073
3320 * where each number is hex. The first two numbers form the minimum and
3321 * maximum of a range, and the third is the value associated with the range.
3322 * Not all swashes should have a third number
3323 *
3324 * On input: l points to the beginning of the line to be examined; it points
3325 * to somewhere in the string of the whole input text, and is
3326 * terminated by a \n or the null string terminator.
3327 * lend points to the null terminator of that string
3328 * wants_value is non-zero if the swash expects a third number
3329 * typestr is the name of the swash's mapping, like 'ToLower'
3330 * On output: *min, *max, and *val are set to the values read from the line.
3331 * returns a pointer just beyond the line examined. If there was no
3332 * valid min number on the line, returns lend+1
3333 */
3334
3335STATIC U8*
3336S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
3337 const bool wants_value, const U8* const typestr)
3338{
3339 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
3340 STRLEN numlen; /* Length of the number */
02470786
KW
3341 I32 flags = PERL_SCAN_SILENT_ILLDIGIT
3342 | PERL_SCAN_DISALLOW_PREFIX
3343 | PERL_SCAN_SILENT_NON_PORTABLE;
319009ee
KW
3344
3345 /* nl points to the next \n in the scan */
3346 U8* const nl = (U8*)memchr(l, '\n', lend - l);
3347
3348 /* Get the first number on the line: the range minimum */
3349 numlen = lend - l;
3350 *min = grok_hex((char *)l, &numlen, &flags, NULL);
3351 if (numlen) /* If found a hex number, position past it */
3352 l += numlen;
3353 else if (nl) { /* Else, go handle next line, if any */
3354 return nl + 1; /* 1 is length of "\n" */
3355 }
3356 else { /* Else, no next line */
3357 return lend + 1; /* to LIST's end at which \n is not found */
3358 }
3359
3360 /* The max range value follows, separated by a BLANK */
3361 if (isBLANK(*l)) {
3362 ++l;
02470786
KW
3363 flags = PERL_SCAN_SILENT_ILLDIGIT
3364 | PERL_SCAN_DISALLOW_PREFIX
3365 | PERL_SCAN_SILENT_NON_PORTABLE;
319009ee
KW
3366 numlen = lend - l;
3367 *max = grok_hex((char *)l, &numlen, &flags, NULL);
3368 if (numlen)
3369 l += numlen;
3370 else /* If no value here, it is a single element range */
3371 *max = *min;
3372
3373 /* Non-binary tables have a third entry: what the first element of the
3374 * range maps to */
3375 if (wants_value) {
3376 if (isBLANK(*l)) {
3377 ++l;
f90a9a02
KW
3378
3379 /* The ToLc, etc table mappings are not in hex, and must be
3380 * corrected by adding the code point to them */
3381 if (typeto) {
3382 char *after_strtol = (char *) lend;
3383 *val = Strtol((char *)l, &after_strtol, 10);
3384 l = (U8 *) after_strtol;
f90a9a02
KW
3385 }
3386 else { /* Other tables are in hex, and are the correct result
3387 without tweaking */
a9d188b3
KW
3388 flags = PERL_SCAN_SILENT_ILLDIGIT
3389 | PERL_SCAN_DISALLOW_PREFIX
3390 | PERL_SCAN_SILENT_NON_PORTABLE;
3391 numlen = lend - l;
3392 *val = grok_hex((char *)l, &numlen, &flags, NULL);
3393 if (numlen)
3394 l += numlen;
3395 else
3396 *val = 0;
f90a9a02 3397 }
319009ee
KW
3398 }
3399 else {
3400 *val = 0;
3401 if (typeto) {
dcbac5bb 3402 /* diag_listed_as: To%s: illegal mapping '%s' */
319009ee
KW
3403 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
3404 typestr, l);
3405 }
3406 }
3407 }
3408 else
3409 *val = 0; /* bits == 1, then any val should be ignored */
3410 }
3411 else { /* Nothing following range min, should be single element with no
3412 mapping expected */
3413 *max = *min;
3414 if (wants_value) {
3415 *val = 0;
3416 if (typeto) {
dcbac5bb 3417 /* diag_listed_as: To%s: illegal mapping '%s' */
319009ee
KW
3418 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
3419 }
3420 }
3421 else
3422 *val = 0; /* bits == 1, then val should be ignored */
3423 }
3424
3425 /* Position to next line if any, or EOF */
3426 if (nl)
3427 l = nl + 1;
3428 else
3429 l = lend;
3430
3431 return l;
3432}
3433
979f2922
ST
3434/* Note:
3435 * Returns a swatch (a bit vector string) for a code point sequence
3436 * that starts from the value C<start> and comprises the number C<span>.
3437 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
3438 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
3439 */
3440STATIC SV*
b0e3252e 3441S_swatch_get(pTHX_ SV* swash, UV start, UV span)
979f2922
ST
3442{
3443 SV *swatch;
77f9f126 3444 U8 *l, *lend, *x, *xend, *s, *send;
979f2922 3445 STRLEN lcur, xcur, scur;
ef8f7699 3446 HV *const hv = MUTABLE_HV(SvRV(swash));
5c9f4bd2 3447 SV** const invlistsvp = hv_fetchs(hv, "V", FALSE);
36eb48b4 3448
88d45d28
KW
3449 SV** listsvp = NULL; /* The string containing the main body of the table */
3450 SV** extssvp = NULL;
3451 SV** invert_it_svp = NULL;
3452 U8* typestr = NULL;
786861f5
KW
3453 STRLEN bits;
3454 STRLEN octets; /* if bits == 1, then octets == 0 */
3455 UV none;
3456 UV end = start + span;
972dd592 3457
36eb48b4 3458 if (invlistsvp == NULL) {
786861f5
KW
3459 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3460 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
3461 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3462 extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
3463 listsvp = hv_fetchs(hv, "LIST", FALSE);
3464 invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
3465
3466 bits = SvUV(*bitssvp);
3467 none = SvUV(*nonesvp);
3468 typestr = (U8*)SvPV_nolen(*typesvp);
3469 }
36eb48b4
KW
3470 else {
3471 bits = 1;
3472 none = 0;
3473 }
786861f5 3474 octets = bits >> 3; /* if bits == 1, then octets == 0 */
979f2922 3475
b0e3252e 3476 PERL_ARGS_ASSERT_SWATCH_GET;
7918f24d 3477
979f2922 3478 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
b0e3252e 3479 Perl_croak(aTHX_ "panic: swatch_get doesn't expect bits %"UVuf,
660a4616 3480 (UV)bits);
979f2922
ST
3481 }
3482
84ea5ef6
KW
3483 /* If overflowed, use the max possible */
3484 if (end < start) {
3485 end = UV_MAX;
3486 span = end - start;
3487 }
3488
979f2922 3489 /* create and initialize $swatch */
979f2922 3490 scur = octets ? (span * octets) : (span + 7) / 8;
e524fe40
NC
3491 swatch = newSV(scur);
3492 SvPOK_on(swatch);
979f2922
ST
3493 s = (U8*)SvPVX(swatch);
3494 if (octets && none) {
0bd48802 3495 const U8* const e = s + scur;
979f2922
ST
3496 while (s < e) {
3497 if (bits == 8)
3498 *s++ = (U8)(none & 0xff);
3499 else if (bits == 16) {
3500 *s++ = (U8)((none >> 8) & 0xff);
3501 *s++ = (U8)( none & 0xff);
3502 }
3503 else if (bits == 32) {
3504 *s++ = (U8)((none >> 24) & 0xff);
3505 *s++ = (U8)((none >> 16) & 0xff);
3506 *s++ = (U8)((none >> 8) & 0xff);
3507 *s++ = (U8)( none & 0xff);
3508 }
3509 }
3510 *s = '\0';
3511 }
3512 else {
3513 (void)memzero((U8*)s, scur + 1);
3514 }
3515 SvCUR_set(swatch, scur);
3516 s = (U8*)SvPVX(swatch);
3517
36eb48b4
KW
3518 if (invlistsvp) { /* If has an inversion list set up use that */
3519 _invlist_populate_swatch(*invlistsvp, start, end, s);
3520 return swatch;
3521 }
3522
3523 /* read $swash->{LIST} */
979f2922
ST
3524 l = (U8*)SvPV(*listsvp, lcur);
3525 lend = l + lcur;
3526 while (l < lend) {
8ed25d53 3527 UV min, max, val, upper;
319009ee
KW
3528 l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
3529 cBOOL(octets), typestr);
3530 if (l > lend) {
979f2922
ST
3531 break;
3532 }
3533
972dd592 3534 /* If looking for something beyond this range, go try the next one */
979f2922
ST
3535 if (max < start)
3536 continue;
3537
8ed25d53
KW
3538 /* <end> is generally 1 beyond where we want to set things, but at the
3539 * platform's infinity, where we can't go any higher, we want to
3540 * include the code point at <end> */
3541 upper = (max < end)
3542 ? max
3543 : (max != UV_MAX || end != UV_MAX)
3544 ? end - 1
3545 : end;
3546
979f2922 3547 if (octets) {
35da51f7 3548 UV key;
979f2922
ST
3549 if (min < start) {
3550 if (!none || val < none) {
3551 val += start - min;
3552 }
3553 min = start;
3554 }
8ed25d53 3555 for (key = min; key <= upper; key++) {
979f2922 3556 STRLEN offset;
979f2922
ST
3557 /* offset must be non-negative (start <= min <= key < end) */
3558 offset = octets * (key - start);
3559 if (bits == 8)
3560 s[offset] = (U8)(val & 0xff);
3561 else if (bits == 16) {
3562 s[offset ] = (U8)((val >> 8) & 0xff);
3563 s[offset + 1] = (U8)( val & 0xff);
3564 }
3565 else if (bits == 32) {
3566 s[offset ] = (U8)((val >> 24) & 0xff);
3567 s[offset + 1] = (U8)((val >> 16) & 0xff);
3568 s[offset + 2] = (U8)((val >> 8) & 0xff);
3569 s[offset + 3] = (U8)( val & 0xff);
3570 }
3571
3572 if (!none || val < none)
3573 ++val;
3574 }
3575 }
711a919c 3576 else { /* bits == 1, then val should be ignored */
35da51f7 3577 UV key;
979f2922
ST
3578 if (min < start)
3579 min = start;
6cb05c12 3580
8ed25d53 3581 for (key = min; key <= upper; key++) {
0bd48802 3582 const STRLEN offset = (STRLEN)(key - start);
979f2922
ST
3583 s[offset >> 3] |= 1 << (offset & 7);
3584 }
3585 }
3586 } /* while */
979f2922 3587
9479a769 3588 /* Invert if the data says it should be. Assumes that bits == 1 */
77f9f126 3589 if (invert_it_svp && SvUV(*invert_it_svp)) {
0bda3001
KW
3590
3591 /* Unicode properties should come with all bits above PERL_UNICODE_MAX
3592 * be 0, and their inversion should also be 0, as we don't succeed any
3593 * Unicode property matches for non-Unicode code points */
3594 if (start <= PERL_UNICODE_MAX) {
3595
3596 /* The code below assumes that we never cross the
3597 * Unicode/above-Unicode boundary in a range, as otherwise we would
3598 * have to figure out where to stop flipping the bits. Since this
3599 * boundary is divisible by a large power of 2, and swatches comes
3600 * in small powers of 2, this should be a valid assumption */
3601 assert(start + span - 1 <= PERL_UNICODE_MAX);
3602
507a8485
KW
3603 send = s + scur;
3604 while (s < send) {
3605 *s = ~(*s);
3606 s++;
3607 }
0bda3001 3608 }
77f9f126
KW
3609 }
3610
d73c39c5
KW
3611 /* read $swash->{EXTRAS}
3612 * This code also copied to swash_to_invlist() below */
979f2922
ST
3613 x = (U8*)SvPV(*extssvp, xcur);
3614 xend = x + xcur;
3615 while (x < xend) {
3616 STRLEN namelen;
3617 U8 *namestr;
3618 SV** othersvp;
3619 HV* otherhv;
3620 STRLEN otherbits;
3621 SV **otherbitssvp, *other;
711a919c 3622 U8 *s, *o, *nl;
979f2922
ST
3623 STRLEN slen, olen;
3624
35da51f7 3625 const U8 opc = *x++;
979f2922
ST
3626 if (opc == '\n')
3627 continue;
3628
3629 nl = (U8*)memchr(x, '\n', xend - x);
3630
3631 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
3632 if (nl) {
3633 x = nl + 1; /* 1 is length of "\n" */
3634 continue;
3635 }
3636 else {
3637 x = xend; /* to EXTRAS' end at which \n is not found */
3638 break;
3639 }
3640 }
3641
3642 namestr = x;
3643 if (nl) {
3644 namelen = nl - namestr;
3645 x = nl + 1;
3646 }
3647 else {
3648 namelen = xend - namestr;
3649 x = xend;
3650 }
3651
3652 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
ef8f7699 3653 otherhv = MUTABLE_HV(SvRV(*othersvp));
017a3ce5 3654 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
979f2922
ST
3655 otherbits = (STRLEN)SvUV(*otherbitssvp);
3656 if (bits < otherbits)
5637ef5b
NC
3657 Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch, "
3658 "bits=%"UVuf", otherbits=%"UVuf, (UV)bits, (UV)otherbits);
979f2922
ST
3659
3660 /* The "other" swatch must be destroyed after. */
b0e3252e 3661 other = swatch_get(*othersvp, start, span);
979f2922
ST
3662 o = (U8*)SvPV(other, olen);
3663
3664 if (!olen)
b0e3252e 3665 Perl_croak(aTHX_ "panic: swatch_get got improper swatch");
979f2922
ST
3666
3667 s = (U8*)SvPV(swatch, slen);
3668 if (bits == 1 && otherbits == 1) {
3669 if (slen != olen)
5637ef5b
NC
3670 Perl_croak(aTHX_ "panic: swatch_get found swatch length "
3671 "mismatch, slen=%"UVuf", olen=%"UVuf,
3672 (UV)slen, (UV)olen