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