This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Expose utf16_to_utf8{,reversed} via XS::APItest, and provide some basic tests.
[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 *
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
TC
20 * as is the custom in the West, if you wish to be answered?'
21 * --Gandalf, addressing Théoden's door wardens
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
LW
33#include "perl.h"
34
a0c21aa1
JH
35#ifndef EBCDIC
36/* Separate prototypes needed because in ASCII systems these
37 * usually macros but they still are compiled as code, too. */
38PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
39PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
40#endif
41
27da23d5
JH
42static const char unees[] =
43 "Malformed UTF-8 character (unexpected end of string)";
901b21bf 44
ccfc67b7
JH
45/*
46=head1 Unicode Support
a0ed51b3 47
166f8a29
DM
48This file contains various utility functions for manipulating UTF8-encoded
49strings. For the uninitiated, this is a method of representing arbitrary
61296642 50Unicode characters as a variable number of bytes, in such a way that
56da48f7
DM
51characters in the ASCII range are unmodified, and a zero byte never appears
52within non-zero characters.
166f8a29 53
eaf7a4d2
CS
54=cut
55*/
56
57/*
58=for apidoc is_ascii_string
59
60Returns true if first C<len> bytes of the given string are ASCII (i.e. none
61of them even raise the question of UTF-8-ness).
62
63See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
64
65=cut
66*/
67
68bool
668b6d8d 69Perl_is_ascii_string(const U8 *s, STRLEN len)
eaf7a4d2
CS
70{
71 const U8* const send = s + (len ? len : strlen((const char *)s));
72 const U8* x = s;
73
74 PERL_ARGS_ASSERT_IS_ASCII_STRING;
eaf7a4d2
CS
75
76 for (; x < send; ++x) {
77 if (!UTF8_IS_INVARIANT(*x))
78 break;
79 }
80
81 return x == send;
82}
83
84/*
87cea99e 85=for apidoc uvuni_to_utf8_flags
eebe1485 86
1e54db1a 87Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
89ebb4a3 88of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
eebe1485 89bytes available. The return value is the pointer to the byte after the
9041c2e3 90end of the new character. In other words,
eebe1485 91
b851fbc1
JH
92 d = uvuni_to_utf8_flags(d, uv, flags);
93
94or, in most cases,
95
9041c2e3 96 d = uvuni_to_utf8(d, uv);
eebe1485 97
b851fbc1
JH
98(which is equivalent to)
99
100 d = uvuni_to_utf8_flags(d, uv, 0);
101
eebe1485
SC
102is the recommended Unicode-aware way of saying
103
104 *(d++) = uv;
105
106=cut
107*/
108
dfe13c55 109U8 *
b851fbc1 110Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
a0ed51b3 111{
7918f24d
NC
112 PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
113
62961d2e 114 if (ckWARN(WARN_UTF8)) {
b851fbc1
JH
115 if (UNICODE_IS_SURROGATE(uv) &&
116 !(flags & UNICODE_ALLOW_SURROGATE))
9014280d 117 Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
b851fbc1
JH
118 else if (
119 ((uv >= 0xFDD0 && uv <= 0xFDEF &&
120 !(flags & UNICODE_ALLOW_FDD0))
121 ||
c867b360 122 ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
b851fbc1
JH
123 !(flags & UNICODE_ALLOW_FFFF))) &&
124 /* UNICODE_ALLOW_SUPER includes
2a20b9da 125 * FFFEs and FFFFs beyond 0x10FFFF. */
b851fbc1
JH
126 ((uv <= PERL_UNICODE_MAX) ||
127 !(flags & UNICODE_ALLOW_SUPER))
128 )
9014280d 129 Perl_warner(aTHX_ packWARN(WARN_UTF8),
6f6ac1de 130 "Unicode non-character 0x%04"UVxf" is illegal for interchange", uv);
507b9800 131 }
c4d5f83a 132 if (UNI_IS_INVARIANT(uv)) {
eb160463 133 *d++ = (U8)UTF_TO_NATIVE(uv);
a0ed51b3
LW
134 return d;
135 }
2d331972 136#if defined(EBCDIC)
1d72bdf6
NIS
137 else {
138 STRLEN len = UNISKIP(uv);
139 U8 *p = d+len-1;
140 while (p > d) {
eb160463 141 *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1d72bdf6
NIS
142 uv >>= UTF_ACCUMULATION_SHIFT;
143 }
eb160463 144 *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1d72bdf6
NIS
145 return d+len;
146 }
147#else /* Non loop style */
a0ed51b3 148 if (uv < 0x800) {
eb160463
GS
149 *d++ = (U8)(( uv >> 6) | 0xc0);
150 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
151 return d;
152 }
153 if (uv < 0x10000) {
eb160463
GS
154 *d++ = (U8)(( uv >> 12) | 0xe0);
155 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
156 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
157 return d;
158 }
159 if (uv < 0x200000) {
eb160463
GS
160 *d++ = (U8)(( uv >> 18) | 0xf0);
161 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
162 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
163 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
164 return d;
165 }
166 if (uv < 0x4000000) {
eb160463
GS
167 *d++ = (U8)(( uv >> 24) | 0xf8);
168 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
169 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
170 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
171 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
172 return d;
173 }
174 if (uv < 0x80000000) {
eb160463
GS
175 *d++ = (U8)(( uv >> 30) | 0xfc);
176 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
177 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
178 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
179 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
180 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
181 return d;
182 }
6b8eaf93 183#ifdef HAS_QUAD
d7578b48 184 if (uv < UTF8_QUAD_MAX)
a0ed51b3
LW
185#endif
186 {
eb160463
GS
187 *d++ = 0xfe; /* Can't match U+FEFF! */
188 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
189 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
190 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
191 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
192 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
193 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
194 return d;
195 }
6b8eaf93 196#ifdef HAS_QUAD
a0ed51b3 197 {
eb160463
GS
198 *d++ = 0xff; /* Can't match U+FFFE! */
199 *d++ = 0x80; /* 6 Reserved bits */
200 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
201 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
202 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
203 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
204 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
205 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
206 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
207 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
208 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
209 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
210 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
211 return d;
212 }
213#endif
1d72bdf6 214#endif /* Loop style */
a0ed51b3 215}
9041c2e3 216
646ca15d
JH
217/*
218
219Tests if some arbitrary number of bytes begins in a valid UTF-8
220character. Note that an INVARIANT (i.e. ASCII) character is a valid
221UTF-8 character. The actual number of bytes in the UTF-8 character
222will be returned if it is valid, otherwise 0.
223
224This is the "slow" version as opposed to the "fast" version which is
225the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed
226difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four
227or less you should use the IS_UTF8_CHAR(), for lengths of five or more
228you should use the _slow(). In practice this means that the _slow()
229will be used very rarely, since the maximum Unicode code point (as of
230Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
231the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
232five bytes or more.
233
234=cut */
c053b435 235STATIC STRLEN
5f66b61c 236S_is_utf8_char_slow(const U8 *s, const STRLEN len)
646ca15d
JH
237{
238 U8 u = *s;
239 STRLEN slen;
240 UV uv, ouv;
241
7918f24d
NC
242 PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
243
646ca15d
JH
244 if (UTF8_IS_INVARIANT(u))
245 return 1;
246
247 if (!UTF8_IS_START(u))
248 return 0;
249
250 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
251 return 0;
252
253 slen = len - 1;
254 s++;
77263263
ST
255#ifdef EBCDIC
256 u = NATIVE_TO_UTF(u);
257#endif
646ca15d
JH
258 u &= UTF_START_MASK(len);
259 uv = u;
260 ouv = uv;
261 while (slen--) {
262 if (!UTF8_IS_CONTINUATION(*s))
263 return 0;
264 uv = UTF8_ACCUMULATE(uv, *s);
265 if (uv < ouv)
266 return 0;
267 ouv = uv;
268 s++;
269 }
270
271 if ((STRLEN)UNISKIP(uv) < len)
272 return 0;
273
274 return len;
275}
9041c2e3
NIS
276
277/*
87cea99e 278=for apidoc is_utf8_char
eebe1485 279
5da9da9e 280Tests if some arbitrary number of bytes begins in a valid UTF-8
2bbc8d55
SP
281character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
282character is a valid UTF-8 character. The actual number of bytes in the UTF-8
283character will be returned if it is valid, otherwise 0.
9041c2e3 284
82686b01 285=cut */
067a85ef 286STRLEN
668b6d8d 287Perl_is_utf8_char(const U8 *s)
386d01d6 288{
44f8325f 289 const STRLEN len = UTF8SKIP(s);
7918f24d
NC
290
291 PERL_ARGS_ASSERT_IS_UTF8_CHAR;
3b0fc154 292#ifdef IS_UTF8_CHAR
768c67ee 293 if (IS_UTF8_CHAR_FAST(len))
3b0fc154
JH
294 return IS_UTF8_CHAR(s, len) ? len : 0;
295#endif /* #ifdef IS_UTF8_CHAR */
2c0c5f92 296 return is_utf8_char_slow(s, len);
386d01d6
GS
297}
298
eaf7a4d2 299
6662521e 300/*
87cea99e 301=for apidoc is_utf8_string
6662521e 302
c9ada85f 303Returns true if first C<len> bytes of the given string form a valid
1e54db1a
JH
304UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
305not mean 'a string that contains code points above 0x7F encoded in UTF-8'
306because a valid ASCII string is a valid UTF-8 string.
6662521e 307
eaf7a4d2 308See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
768c67ee 309
6662521e
GS
310=cut
311*/
312
8e84507e 313bool
668b6d8d 314Perl_is_utf8_string(const U8 *s, STRLEN len)
6662521e 315{
35da51f7 316 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 317 const U8* x = s;
067a85ef 318
7918f24d 319 PERL_ARGS_ASSERT_IS_UTF8_STRING;
1aa99e6b 320
6662521e 321 while (x < send) {
a3b680e6 322 STRLEN c;
1acdb0da
JH
323 /* Inline the easy bits of is_utf8_char() here for speed... */
324 if (UTF8_IS_INVARIANT(*x))
325 c = 1;
326 else if (!UTF8_IS_START(*x))
768c67ee 327 goto out;
1acdb0da
JH
328 else {
329 /* ... and call is_utf8_char() only if really needed. */
646ca15d
JH
330#ifdef IS_UTF8_CHAR
331 c = UTF8SKIP(x);
768c67ee
JH
332 if (IS_UTF8_CHAR_FAST(c)) {
333 if (!IS_UTF8_CHAR(x, c))
3c614e38
AD
334 c = 0;
335 }
336 else
337 c = is_utf8_char_slow(x, c);
646ca15d
JH
338#else
339 c = is_utf8_char(x);
340#endif /* #ifdef IS_UTF8_CHAR */
1acdb0da 341 if (!c)
768c67ee 342 goto out;
1acdb0da 343 }
6662521e 344 x += c;
6662521e 345 }
768c67ee
JH
346
347 out:
60006e79
JH
348 if (x != send)
349 return FALSE;
067a85ef
A
350
351 return TRUE;
6662521e
GS
352}
353
67e989fb 354/*
814fafa7
NC
355Implemented as a macro in utf8.h
356
87cea99e 357=for apidoc is_utf8_string_loc
814fafa7
NC
358
359Like is_utf8_string() but stores the location of the failure (in the
360case of "utf8ness failure") or the location s+len (in the case of
361"utf8ness success") in the C<ep>.
362
363See also is_utf8_string_loclen() and is_utf8_string().
364
87cea99e 365=for apidoc is_utf8_string_loclen
81cd54e3 366
e3e4599f 367Like is_utf8_string() but stores the location of the failure (in the
768c67ee
JH
368case of "utf8ness failure") or the location s+len (in the case of
369"utf8ness success") in the C<ep>, and the number of UTF-8
370encoded characters in the C<el>.
371
372See also is_utf8_string_loc() and is_utf8_string().
81cd54e3
JH
373
374=cut
375*/
376
377bool
668b6d8d 378Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
81cd54e3 379{
35da51f7 380 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 381 const U8* x = s;
81cd54e3 382 STRLEN c;
3ebfea28 383 STRLEN outlen = 0;
7918f24d
NC
384
385 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
81cd54e3 386
81cd54e3
JH
387 while (x < send) {
388 /* Inline the easy bits of is_utf8_char() here for speed... */
389 if (UTF8_IS_INVARIANT(*x))
768c67ee
JH
390 c = 1;
391 else if (!UTF8_IS_START(*x))
392 goto out;
81cd54e3 393 else {
768c67ee
JH
394 /* ... and call is_utf8_char() only if really needed. */
395#ifdef IS_UTF8_CHAR
396 c = UTF8SKIP(x);
397 if (IS_UTF8_CHAR_FAST(c)) {
398 if (!IS_UTF8_CHAR(x, c))
399 c = 0;
400 } else
401 c = is_utf8_char_slow(x, c);
402#else
403 c = is_utf8_char(x);
404#endif /* #ifdef IS_UTF8_CHAR */
405 if (!c)
406 goto out;
81cd54e3 407 }
768c67ee 408 x += c;
3ebfea28 409 outlen++;
81cd54e3 410 }
768c67ee
JH
411
412 out:
3ebfea28
AL
413 if (el)
414 *el = outlen;
415
768c67ee
JH
416 if (ep)
417 *ep = x;
3ebfea28 418 return (x == send);
81cd54e3
JH
419}
420
421/*
768c67ee 422
87cea99e 423=for apidoc utf8n_to_uvuni
67e989fb 424
9041c2e3 425Bottom level UTF-8 decode routine.
38a44b82 426Returns the Unicode code point value of the first character in the string C<s>
1e54db1a 427which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
7df053ec 428C<retlen> will be set to the length, in bytes, of that character.
67e989fb 429
1e54db1a 430If C<s> does not point to a well-formed UTF-8 character, the behaviour
dcad2880
JH
431is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
432it is assumed that the caller will raise a warning, and this function
28d3d195
JH
433will silently just set C<retlen> to C<-1> and return zero. If the
434C<flags> does not contain UTF8_CHECK_ONLY, warnings about
435malformations will be given, C<retlen> will be set to the expected
436length of the UTF-8 character in bytes, and zero will be returned.
437
438The C<flags> can also contain various flags to allow deviations from
439the strict UTF-8 encoding (see F<utf8.h>).
67e989fb 440
9041c2e3
NIS
441Most code should use utf8_to_uvchr() rather than call this directly.
442
37607a96
PK
443=cut
444*/
67e989fb 445
a0ed51b3 446UV
7fc63493 447Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 448{
97aff369 449 dVAR;
d4c19fe8 450 const U8 * const s0 = s;
9c5ffd7c 451 UV uv = *s, ouv = 0;
ba210ebe 452 STRLEN len = 1;
7fc63493
AL
453 const bool dowarn = ckWARN_d(WARN_UTF8);
454 const UV startbyte = *s;
ba210ebe 455 STRLEN expectlen = 0;
a0dbb045
JH
456 U32 warning = 0;
457
7918f24d
NC
458 PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
459
a0dbb045
JH
460/* This list is a superset of the UTF8_ALLOW_XXX. */
461
462#define UTF8_WARN_EMPTY 1
463#define UTF8_WARN_CONTINUATION 2
464#define UTF8_WARN_NON_CONTINUATION 3
465#define UTF8_WARN_FE_FF 4
466#define UTF8_WARN_SHORT 5
467#define UTF8_WARN_OVERFLOW 6
468#define UTF8_WARN_SURROGATE 7
c867b360
JH
469#define UTF8_WARN_LONG 8
470#define UTF8_WARN_FFFF 9 /* Also FFFE. */
a0dbb045
JH
471
472 if (curlen == 0 &&
473 !(flags & UTF8_ALLOW_EMPTY)) {
474 warning = UTF8_WARN_EMPTY;
0c443dc2
JH
475 goto malformed;
476 }
477
1d72bdf6 478 if (UTF8_IS_INVARIANT(uv)) {
a0ed51b3
LW
479 if (retlen)
480 *retlen = 1;
c4d5f83a 481 return (UV) (NATIVE_TO_UTF(*s));
a0ed51b3 482 }
67e989fb 483
421a8bf2 484 if (UTF8_IS_CONTINUATION(uv) &&
fcc8fcf6 485 !(flags & UTF8_ALLOW_CONTINUATION)) {
a0dbb045 486 warning = UTF8_WARN_CONTINUATION;
ba210ebe
JH
487 goto malformed;
488 }
489
421a8bf2 490 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
fcc8fcf6 491 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045 492 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe
JH
493 goto malformed;
494 }
9041c2e3 495
1d72bdf6 496#ifdef EBCDIC
75383841 497 uv = NATIVE_TO_UTF(uv);
1d72bdf6 498#else
fcc8fcf6
JH
499 if ((uv == 0xfe || uv == 0xff) &&
500 !(flags & UTF8_ALLOW_FE_FF)) {
a0dbb045 501 warning = UTF8_WARN_FE_FF;
ba210ebe 502 goto malformed;
a0ed51b3 503 }
1d72bdf6
NIS
504#endif
505
ba210ebe
JH
506 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
507 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
508 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
509 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
1d72bdf6
NIS
510#ifdef EBCDIC
511 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
512 else { len = 7; uv &= 0x01; }
513#else
ba210ebe
JH
514 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
515 else if (!(uv & 0x01)) { len = 7; uv = 0; }
1d72bdf6
NIS
516 else { len = 13; uv = 0; } /* whoa! */
517#endif
518
a0ed51b3
LW
519 if (retlen)
520 *retlen = len;
9041c2e3 521
ba210ebe
JH
522 expectlen = len;
523
fcc8fcf6
JH
524 if ((curlen < expectlen) &&
525 !(flags & UTF8_ALLOW_SHORT)) {
a0dbb045 526 warning = UTF8_WARN_SHORT;
ba210ebe
JH
527 goto malformed;
528 }
529
530 len--;
a0ed51b3 531 s++;
ba210ebe
JH
532 ouv = uv;
533
a0ed51b3 534 while (len--) {
421a8bf2
JH
535 if (!UTF8_IS_CONTINUATION(*s) &&
536 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045
JH
537 s--;
538 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe 539 goto malformed;
a0ed51b3
LW
540 }
541 else
8850bf83 542 uv = UTF8_ACCUMULATE(uv, *s);
a0dbb045
JH
543 if (!(uv > ouv)) {
544 /* These cannot be allowed. */
545 if (uv == ouv) {
75dbc644 546 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
a0dbb045
JH
547 warning = UTF8_WARN_LONG;
548 goto malformed;
549 }
550 }
551 else { /* uv < ouv */
552 /* This cannot be allowed. */
553 warning = UTF8_WARN_OVERFLOW;
554 goto malformed;
555 }
ba210ebe
JH
556 }
557 s++;
558 ouv = uv;
559 }
560
421a8bf2 561 if (UNICODE_IS_SURROGATE(uv) &&
fcc8fcf6 562 !(flags & UTF8_ALLOW_SURROGATE)) {
a0dbb045 563 warning = UTF8_WARN_SURROGATE;
ba210ebe 564 goto malformed;
eb160463 565 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
fcc8fcf6 566 !(flags & UTF8_ALLOW_LONG)) {
a0dbb045 567 warning = UTF8_WARN_LONG;
ba210ebe 568 goto malformed;
421a8bf2 569 } else if (UNICODE_IS_ILLEGAL(uv) &&
a9917092 570 !(flags & UTF8_ALLOW_FFFF)) {
a0dbb045 571 warning = UTF8_WARN_FFFF;
a9917092 572 goto malformed;
a0ed51b3 573 }
ba210ebe 574
a0ed51b3 575 return uv;
ba210ebe
JH
576
577malformed:
578
fcc8fcf6 579 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 580 if (retlen)
10edeb5d 581 *retlen = ((STRLEN) -1);
ba210ebe
JH
582 return 0;
583 }
584
a0dbb045 585 if (dowarn) {
84bafc02 586 SV* const sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
a0dbb045
JH
587
588 switch (warning) {
589 case 0: /* Intentionally empty. */ break;
590 case UTF8_WARN_EMPTY:
396482e1 591 sv_catpvs(sv, "(empty string)");
a0dbb045
JH
592 break;
593 case UTF8_WARN_CONTINUATION:
097fb8e2 594 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
a0dbb045
JH
595 break;
596 case UTF8_WARN_NON_CONTINUATION:
097fb8e2
JH
597 if (s == s0)
598 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
599 (UV)s[1], startbyte);
551405c4
AL
600 else {
601 const int len = (int)(s-s0);
097fb8e2 602 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
551405c4
AL
603 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
604 }
605
a0dbb045
JH
606 break;
607 case UTF8_WARN_FE_FF:
608 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
609 break;
610 case UTF8_WARN_SHORT:
097fb8e2 611 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
5d7488b2 612 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
b31f83c2 613 expectlen = curlen; /* distance for caller to skip */
a0dbb045
JH
614 break;
615 case UTF8_WARN_OVERFLOW:
097fb8e2
JH
616 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
617 ouv, *s, startbyte);
a0dbb045
JH
618 break;
619 case UTF8_WARN_SURROGATE:
620 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
621 break;
a0dbb045 622 case UTF8_WARN_LONG:
097fb8e2 623 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
5d7488b2 624 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
a0dbb045
JH
625 break;
626 case UTF8_WARN_FFFF:
627 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
628 break;
629 default:
396482e1 630 sv_catpvs(sv, "(unknown reason)");
a0dbb045
JH
631 break;
632 }
633
634 if (warning) {
44f8325f 635 const char * const s = SvPVX_const(sv);
a0dbb045
JH
636
637 if (PL_op)
9014280d 638 Perl_warner(aTHX_ packWARN(WARN_UTF8),
53e06cf0 639 "%s in %s", s, OP_DESC(PL_op));
a0dbb045 640 else
9014280d 641 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
a0dbb045
JH
642 }
643 }
644
ba210ebe 645 if (retlen)
28d3d195 646 *retlen = expectlen ? expectlen : len;
ba210ebe 647
28d3d195 648 return 0;
a0ed51b3
LW
649}
650
8e84507e 651/*
87cea99e 652=for apidoc utf8_to_uvchr
9041c2e3
NIS
653
654Returns the native character value of the first character in the string C<s>
1e54db1a 655which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
656length, in bytes, of that character.
657
1e54db1a 658If C<s> does not point to a well-formed UTF-8 character, zero is
9041c2e3
NIS
659returned and retlen is set, if possible, to -1.
660
661=cut
662*/
663
664UV
7fc63493 665Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
9041c2e3 666{
7918f24d
NC
667 PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
668
1754c1a1
NC
669 return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
670 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
9041c2e3
NIS
671}
672
673/*
87cea99e 674=for apidoc utf8_to_uvuni
9041c2e3
NIS
675
676Returns the Unicode code point of the first character in the string C<s>
1e54db1a 677which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
678length, in bytes, of that character.
679
2bbc8d55 680This function should only be used when the returned UV is considered
9041c2e3
NIS
681an index into the Unicode semantic tables (e.g. swashes).
682
1e54db1a 683If C<s> does not point to a well-formed UTF-8 character, zero is
ba210ebe 684returned and retlen is set, if possible, to -1.
8e84507e
NIS
685
686=cut
687*/
688
689UV
7fc63493 690Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
8e84507e 691{
7918f24d
NC
692 PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
693
9041c2e3 694 /* Call the low level routine asking for checks */
89ebb4a3 695 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
872c91ae 696 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
8e84507e
NIS
697}
698
b76347f2 699/*
87cea99e 700=for apidoc utf8_length
b76347f2
JH
701
702Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
703Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
704up past C<e>, croaks.
b76347f2
JH
705
706=cut
707*/
708
709STRLEN
35a4481c 710Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2 711{
97aff369 712 dVAR;
b76347f2
JH
713 STRLEN len = 0;
714
7918f24d
NC
715 PERL_ARGS_ASSERT_UTF8_LENGTH;
716
8850bf83
JH
717 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
718 * the bitops (especially ~) can create illegal UTF-8.
719 * In other words: in Perl UTF-8 is not just for Unicode. */
720
a3b680e6
AL
721 if (e < s)
722 goto warn_and_return;
b76347f2 723 while (s < e) {
8e91ec7f
AV
724 if (!UTF8_IS_INVARIANT(*s))
725 s += UTF8SKIP(s);
726 else
727 s++;
728 len++;
729 }
730
731 if (e != s) {
732 len--;
733 warn_and_return:
9b387841
NC
734 if (PL_op)
735 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
736 "%s in %s", unees, OP_DESC(PL_op));
737 else
738 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
b76347f2
JH
739 }
740
741 return len;
742}
743
b06226ff 744/*
87cea99e 745=for apidoc utf8_distance
b06226ff 746
1e54db1a 747Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
b06226ff
JH
748and C<b>.
749
750WARNING: use only if you *know* that the pointers point inside the
751same UTF-8 buffer.
752
37607a96
PK
753=cut
754*/
a0ed51b3 755
02eb7b47 756IV
35a4481c 757Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
a0ed51b3 758{
7918f24d
NC
759 PERL_ARGS_ASSERT_UTF8_DISTANCE;
760
bf1665bc 761 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
a0ed51b3
LW
762}
763
b06226ff 764/*
87cea99e 765=for apidoc utf8_hop
b06226ff 766
8850bf83
JH
767Return the UTF-8 pointer C<s> displaced by C<off> characters, either
768forward or backward.
b06226ff
JH
769
770WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
771the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
772on the first byte of character or just after the last byte of a character.
b06226ff 773
37607a96
PK
774=cut
775*/
a0ed51b3
LW
776
777U8 *
4373e329 778Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
a0ed51b3 779{
7918f24d
NC
780 PERL_ARGS_ASSERT_UTF8_HOP;
781
96a5add6 782 PERL_UNUSED_CONTEXT;
8850bf83
JH
783 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
784 * the bitops (especially ~) can create illegal UTF-8.
785 * In other words: in Perl UTF-8 is not just for Unicode. */
786
a0ed51b3
LW
787 if (off >= 0) {
788 while (off--)
789 s += UTF8SKIP(s);
790 }
791 else {
792 while (off++) {
793 s--;
8850bf83
JH
794 while (UTF8_IS_CONTINUATION(*s))
795 s--;
a0ed51b3
LW
796 }
797 }
4373e329 798 return (U8 *)s;
a0ed51b3
LW
799}
800
6940069f 801/*
87cea99e 802=for apidoc utf8_to_bytes
6940069f 803
2bbc8d55 804Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
246fae53
MG
805Unlike C<bytes_to_utf8>, this over-writes the original string, and
806updates len to contain the new length.
67e989fb 807Returns zero on failure, setting C<len> to -1.
6940069f 808
95be277c
NC
809If you need a copy of the string, see C<bytes_from_utf8>.
810
6940069f
GS
811=cut
812*/
813
814U8 *
37607a96 815Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 816{
d4c19fe8
AL
817 U8 * const save = s;
818 U8 * const send = s + *len;
6940069f 819 U8 *d;
246fae53 820
7918f24d
NC
821 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
822
1e54db1a 823 /* ensure valid UTF-8 and chars < 256 before updating string */
d4c19fe8 824 while (s < send) {
dcad2880
JH
825 U8 c = *s++;
826
1d72bdf6
NIS
827 if (!UTF8_IS_INVARIANT(c) &&
828 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
829 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
10edeb5d 830 *len = ((STRLEN) -1);
dcad2880
JH
831 return 0;
832 }
246fae53 833 }
dcad2880
JH
834
835 d = s = save;
6940069f 836 while (s < send) {
ed646e6e 837 STRLEN ulen;
9041c2e3 838 *d++ = (U8)utf8_to_uvchr(s, &ulen);
ed646e6e 839 s += ulen;
6940069f
GS
840 }
841 *d = '\0';
246fae53 842 *len = d - save;
6940069f
GS
843 return save;
844}
845
846/*
87cea99e 847=for apidoc bytes_from_utf8
f9a63242 848
2bbc8d55 849Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
35a4481c 850Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
851the newly-created string, and updates C<len> to contain the new
852length. Returns the original string if no conversion occurs, C<len>
853is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
2bbc8d55
SP
8540 if C<s> is converted or consisted entirely of characters that are invariant
855in utf8 (i.e., US-ASCII on non-EBCDIC machines).
f9a63242 856
37607a96
PK
857=cut
858*/
f9a63242
JH
859
860U8 *
e1ec3a88 861Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 862{
f9a63242 863 U8 *d;
e1ec3a88
AL
864 const U8 *start = s;
865 const U8 *send;
f9a63242
JH
866 I32 count = 0;
867
7918f24d
NC
868 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
869
96a5add6 870 PERL_UNUSED_CONTEXT;
f9a63242 871 if (!*is_utf8)
73d840c0 872 return (U8 *)start;
f9a63242 873
1e54db1a 874 /* ensure valid UTF-8 and chars < 256 before converting string */
f9a63242 875 for (send = s + *len; s < send;) {
e1ec3a88 876 U8 c = *s++;
1d72bdf6 877 if (!UTF8_IS_INVARIANT(c)) {
db42d148
NIS
878 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
879 (c = *s++) && UTF8_IS_CONTINUATION(c))
880 count++;
881 else
73d840c0 882 return (U8 *)start;
db42d148 883 }
f9a63242
JH
884 }
885
35da51f7 886 *is_utf8 = FALSE;
f9a63242 887
212542aa 888 Newx(d, (*len) - count + 1, U8);
ef9edfd0 889 s = start; start = d;
f9a63242
JH
890 while (s < send) {
891 U8 c = *s++;
c4d5f83a
NIS
892 if (!UTF8_IS_INVARIANT(c)) {
893 /* Then it is two-byte encoded */
894 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
895 c = ASCII_TO_NATIVE(c);
896 }
897 *d++ = c;
f9a63242
JH
898 }
899 *d = '\0';
900 *len = d - start;
73d840c0 901 return (U8 *)start;
f9a63242
JH
902}
903
904/*
87cea99e 905=for apidoc bytes_to_utf8
6940069f 906
2bbc8d55 907Converts a string C<s> of length C<len> from the native encoding into UTF-8.
6662521e
GS
908Returns a pointer to the newly-created string, and sets C<len> to
909reflect the new length.
6940069f 910
2bbc8d55
SP
911A NUL character will be written after the end of the string.
912
913If you want to convert to UTF-8 from encodings other than
914the native (Latin1 or EBCDIC),
c9ada85f
JH
915see sv_recode_to_utf8().
916
497711e7 917=cut
6940069f
GS
918*/
919
920U8*
35a4481c 921Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
6940069f 922{
35a4481c 923 const U8 * const send = s + (*len);
6940069f
GS
924 U8 *d;
925 U8 *dst;
7918f24d
NC
926
927 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
96a5add6 928 PERL_UNUSED_CONTEXT;
6940069f 929
212542aa 930 Newx(d, (*len) * 2 + 1, U8);
6940069f
GS
931 dst = d;
932
933 while (s < send) {
35a4481c 934 const UV uv = NATIVE_TO_ASCII(*s++);
c4d5f83a 935 if (UNI_IS_INVARIANT(uv))
eb160463 936 *d++ = (U8)UTF_TO_NATIVE(uv);
6940069f 937 else {
eb160463
GS
938 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
939 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
6940069f
GS
940 }
941 }
942 *d = '\0';
6662521e 943 *len = d-dst;
6940069f
GS
944 return dst;
945}
946
a0ed51b3 947/*
dea0fc0b 948 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
949 *
950 * Destination must be pre-extended to 3/2 source. Do not use in-place.
951 * We optimize for native, for obvious reasons. */
952
953U8*
dea0fc0b 954Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 955{
dea0fc0b
JH
956 U8* pend;
957 U8* dstart = d;
958
7918f24d
NC
959 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
960
1de9afcd
RGS
961 if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
962 d[0] = 0;
963 *newlen = 1;
964 return d;
965 }
966
dea0fc0b 967 if (bytelen & 1)
f5992bc4 968 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
dea0fc0b
JH
969
970 pend = p + bytelen;
971
a0ed51b3 972 while (p < pend) {
dea0fc0b
JH
973 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
974 p += 2;
a0ed51b3 975 if (uv < 0x80) {
e294cc5d
JH
976#ifdef EBCDIC
977 *d++ = UNI_TO_NATIVE(uv);
978#else
eb160463 979 *d++ = (U8)uv;
e294cc5d 980#endif
a0ed51b3
LW
981 continue;
982 }
983 if (uv < 0x800) {
eb160463
GS
984 *d++ = (U8)(( uv >> 6) | 0xc0);
985 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
986 continue;
987 }
988 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
30f84f9e
DT
989 UV low = (p[0] << 8) + p[1];
990 p += 2;
dea0fc0b
JH
991 if (low < 0xdc00 || low >= 0xdfff)
992 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
a0ed51b3
LW
993 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
994 }
995 if (uv < 0x10000) {
eb160463
GS
996 *d++ = (U8)(( uv >> 12) | 0xe0);
997 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
998 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
999 continue;
1000 }
1001 else {
eb160463
GS
1002 *d++ = (U8)(( uv >> 18) | 0xf0);
1003 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1004 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1005 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1006 continue;
1007 }
1008 }
dea0fc0b 1009 *newlen = d - dstart;
a0ed51b3
LW
1010 return d;
1011}
1012
1013/* Note: this one is slightly destructive of the source. */
1014
1015U8*
dea0fc0b 1016Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
1017{
1018 U8* s = (U8*)p;
d4c19fe8 1019 U8* const send = s + bytelen;
7918f24d
NC
1020
1021 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1022
a0ed51b3 1023 while (s < send) {
d4c19fe8 1024 const U8 tmp = s[0];
a0ed51b3
LW
1025 s[0] = s[1];
1026 s[1] = tmp;
1027 s += 2;
1028 }
dea0fc0b 1029 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
1030}
1031
1032/* for now these are all defined (inefficiently) in terms of the utf8 versions */
1033
1034bool
84afefe6 1035Perl_is_uni_alnum(pTHX_ UV c)
a0ed51b3 1036{
89ebb4a3 1037 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1038 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1039 return is_utf8_alnum(tmpbuf);
1040}
1041
1042bool
84afefe6 1043Perl_is_uni_idfirst(pTHX_ UV c)
a0ed51b3 1044{
89ebb4a3 1045 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1046 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1047 return is_utf8_idfirst(tmpbuf);
1048}
1049
1050bool
84afefe6 1051Perl_is_uni_alpha(pTHX_ UV c)
a0ed51b3 1052{
89ebb4a3 1053 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1054 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1055 return is_utf8_alpha(tmpbuf);
1056}
1057
1058bool
84afefe6 1059Perl_is_uni_ascii(pTHX_ UV c)
4d61ec05 1060{
89ebb4a3 1061 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1062 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
1063 return is_utf8_ascii(tmpbuf);
1064}
1065
1066bool
84afefe6 1067Perl_is_uni_space(pTHX_ UV c)
a0ed51b3 1068{
89ebb4a3 1069 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1070 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1071 return is_utf8_space(tmpbuf);
1072}
1073
1074bool
84afefe6 1075Perl_is_uni_digit(pTHX_ UV c)
a0ed51b3 1076{
89ebb4a3 1077 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1078 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1079 return is_utf8_digit(tmpbuf);
1080}
1081
1082bool
84afefe6 1083Perl_is_uni_upper(pTHX_ UV c)
a0ed51b3 1084{
89ebb4a3 1085 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1086 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1087 return is_utf8_upper(tmpbuf);
1088}
1089
1090bool
84afefe6 1091Perl_is_uni_lower(pTHX_ UV c)
a0ed51b3 1092{
89ebb4a3 1093 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1094 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1095 return is_utf8_lower(tmpbuf);
1096}
1097
1098bool
84afefe6 1099Perl_is_uni_cntrl(pTHX_ UV c)
b8c5462f 1100{
89ebb4a3 1101 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1102 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1103 return is_utf8_cntrl(tmpbuf);
1104}
1105
1106bool
84afefe6 1107Perl_is_uni_graph(pTHX_ UV c)
b8c5462f 1108{
89ebb4a3 1109 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1110 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1111 return is_utf8_graph(tmpbuf);
1112}
1113
1114bool
84afefe6 1115Perl_is_uni_print(pTHX_ UV c)
a0ed51b3 1116{
89ebb4a3 1117 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1118 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1119 return is_utf8_print(tmpbuf);
1120}
1121
b8c5462f 1122bool
84afefe6 1123Perl_is_uni_punct(pTHX_ UV c)
b8c5462f 1124{
89ebb4a3 1125 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1126 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1127 return is_utf8_punct(tmpbuf);
1128}
1129
4d61ec05 1130bool
84afefe6 1131Perl_is_uni_xdigit(pTHX_ UV c)
4d61ec05 1132{
89ebb4a3 1133 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
230880c1 1134 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
1135 return is_utf8_xdigit(tmpbuf);
1136}
1137
84afefe6
JH
1138UV
1139Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1140{
7918f24d
NC
1141 PERL_ARGS_ASSERT_TO_UNI_UPPER;
1142
0ebc6274
JH
1143 uvchr_to_utf8(p, c);
1144 return to_utf8_upper(p, p, lenp);
a0ed51b3
LW
1145}
1146
84afefe6
JH
1147UV
1148Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1149{
7918f24d
NC
1150 PERL_ARGS_ASSERT_TO_UNI_TITLE;
1151
0ebc6274
JH
1152 uvchr_to_utf8(p, c);
1153 return to_utf8_title(p, p, lenp);
a0ed51b3
LW
1154}
1155
84afefe6
JH
1156UV
1157Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1158{
7918f24d
NC
1159 PERL_ARGS_ASSERT_TO_UNI_LOWER;
1160
0ebc6274
JH
1161 uvchr_to_utf8(p, c);
1162 return to_utf8_lower(p, p, lenp);
a0ed51b3
LW
1163}
1164
84afefe6
JH
1165UV
1166Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1167{
7918f24d
NC
1168 PERL_ARGS_ASSERT_TO_UNI_FOLD;
1169
0ebc6274
JH
1170 uvchr_to_utf8(p, c);
1171 return to_utf8_fold(p, p, lenp);
84afefe6
JH
1172}
1173
a0ed51b3
LW
1174/* for now these all assume no locale info available for Unicode > 255 */
1175
1176bool
84afefe6 1177Perl_is_uni_alnum_lc(pTHX_ UV c)
a0ed51b3
LW
1178{
1179 return is_uni_alnum(c); /* XXX no locale support yet */
1180}
1181
1182bool
84afefe6 1183Perl_is_uni_idfirst_lc(pTHX_ UV c)
a0ed51b3
LW
1184{
1185 return is_uni_idfirst(c); /* XXX no locale support yet */
1186}
1187
1188bool
84afefe6 1189Perl_is_uni_alpha_lc(pTHX_ UV c)
a0ed51b3
LW
1190{
1191 return is_uni_alpha(c); /* XXX no locale support yet */
1192}
1193
1194bool
84afefe6 1195Perl_is_uni_ascii_lc(pTHX_ UV c)
4d61ec05
GS
1196{
1197 return is_uni_ascii(c); /* XXX no locale support yet */
1198}
1199
1200bool
84afefe6 1201Perl_is_uni_space_lc(pTHX_ UV c)
a0ed51b3
LW
1202{
1203 return is_uni_space(c); /* XXX no locale support yet */
1204}
1205
1206bool
84afefe6 1207Perl_is_uni_digit_lc(pTHX_ UV c)
a0ed51b3
LW
1208{
1209 return is_uni_digit(c); /* XXX no locale support yet */
1210}
1211
1212bool
84afefe6 1213Perl_is_uni_upper_lc(pTHX_ UV c)
a0ed51b3
LW
1214{
1215 return is_uni_upper(c); /* XXX no locale support yet */
1216}
1217
1218bool
84afefe6 1219Perl_is_uni_lower_lc(pTHX_ UV c)
a0ed51b3
LW
1220{
1221 return is_uni_lower(c); /* XXX no locale support yet */
1222}
1223
1224bool
84afefe6 1225Perl_is_uni_cntrl_lc(pTHX_ UV c)
b8c5462f
JH
1226{
1227 return is_uni_cntrl(c); /* XXX no locale support yet */
1228}
1229
1230bool
84afefe6 1231Perl_is_uni_graph_lc(pTHX_ UV c)
b8c5462f
JH
1232{
1233 return is_uni_graph(c); /* XXX no locale support yet */
1234}
1235
1236bool
84afefe6 1237Perl_is_uni_print_lc(pTHX_ UV c)
a0ed51b3
LW
1238{
1239 return is_uni_print(c); /* XXX no locale support yet */
1240}
1241
b8c5462f 1242bool
84afefe6 1243Perl_is_uni_punct_lc(pTHX_ UV c)
b8c5462f
JH
1244{
1245 return is_uni_punct(c); /* XXX no locale support yet */
1246}
1247
4d61ec05 1248bool
84afefe6 1249Perl_is_uni_xdigit_lc(pTHX_ UV c)
4d61ec05
GS
1250{
1251 return is_uni_xdigit(c); /* XXX no locale support yet */
1252}
1253
b7ac61fa
JH
1254U32
1255Perl_to_uni_upper_lc(pTHX_ U32 c)
1256{
ee099d14
JH
1257 /* XXX returns only the first character -- do not use XXX */
1258 /* XXX no locale support yet */
1259 STRLEN len;
89ebb4a3 1260 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1261 return (U32)to_uni_upper(c, tmpbuf, &len);
b7ac61fa
JH
1262}
1263
1264U32
1265Perl_to_uni_title_lc(pTHX_ U32 c)
1266{
ee099d14
JH
1267 /* XXX returns only the first character XXX -- do not use XXX */
1268 /* XXX no locale support yet */
1269 STRLEN len;
89ebb4a3 1270 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1271 return (U32)to_uni_title(c, tmpbuf, &len);
b7ac61fa
JH
1272}
1273
1274U32
1275Perl_to_uni_lower_lc(pTHX_ U32 c)
1276{
ee099d14
JH
1277 /* XXX returns only the first character -- do not use XXX */
1278 /* XXX no locale support yet */
1279 STRLEN len;
89ebb4a3 1280 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1281 return (U32)to_uni_lower(c, tmpbuf, &len);
b7ac61fa
JH
1282}
1283
7452cf6a 1284static bool
5141f98e 1285S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
bde6a22d
NC
1286 const char *const swashname)
1287{
97aff369 1288 dVAR;
7918f24d
NC
1289
1290 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1291
bde6a22d
NC
1292 if (!is_utf8_char(p))
1293 return FALSE;
1294 if (!*swash)
711a919c 1295 *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
bde6a22d
NC
1296 return swash_fetch(*swash, p, TRUE) != 0;
1297}
1298
1299bool
7fc63493 1300Perl_is_utf8_alnum(pTHX_ const U8 *p)
a0ed51b3 1301{
97aff369 1302 dVAR;
7918f24d
NC
1303
1304 PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1305
671c33bf
NC
1306 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1307 * descendant of isalnum(3), in other words, it doesn't
1308 * contain the '_'. --jhi */
d4c19fe8 1309 return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
a0ed51b3
LW
1310}
1311
1312bool
7fc63493 1313Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
a0ed51b3 1314{
97aff369 1315 dVAR;
7918f24d
NC
1316
1317 PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1318
82686b01
JH
1319 if (*p == '_')
1320 return TRUE;
bde6a22d 1321 /* is_utf8_idstart would be more logical. */
d4c19fe8 1322 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
82686b01
JH
1323}
1324
1325bool
7fc63493 1326Perl_is_utf8_idcont(pTHX_ const U8 *p)
82686b01 1327{
97aff369 1328 dVAR;
7918f24d
NC
1329
1330 PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1331
82686b01
JH
1332 if (*p == '_')
1333 return TRUE;
d4c19fe8 1334 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
a0ed51b3
LW
1335}
1336
1337bool
7fc63493 1338Perl_is_utf8_alpha(pTHX_ const U8 *p)
a0ed51b3 1339{
97aff369 1340 dVAR;
7918f24d
NC
1341
1342 PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1343
d4c19fe8 1344 return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
a0ed51b3
LW
1345}
1346
1347bool
7fc63493 1348Perl_is_utf8_ascii(pTHX_ const U8 *p)
b8c5462f 1349{
97aff369 1350 dVAR;
7918f24d
NC
1351
1352 PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1353
d4c19fe8 1354 return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
b8c5462f
JH
1355}
1356
1357bool
7fc63493 1358Perl_is_utf8_space(pTHX_ const U8 *p)
a0ed51b3 1359{
97aff369 1360 dVAR;
7918f24d
NC
1361
1362 PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1363
d4c19fe8 1364 return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
a0ed51b3
LW
1365}
1366
1367bool
7fc63493 1368Perl_is_utf8_digit(pTHX_ const U8 *p)
a0ed51b3 1369{
97aff369 1370 dVAR;
7918f24d
NC
1371
1372 PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1373
d4c19fe8 1374 return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
a0ed51b3
LW
1375}
1376
1377bool
7fc63493 1378Perl_is_utf8_upper(pTHX_ const U8 *p)
a0ed51b3 1379{
97aff369 1380 dVAR;
7918f24d
NC
1381
1382 PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1383
d4c19fe8 1384 return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
a0ed51b3
LW
1385}
1386
1387bool
7fc63493 1388Perl_is_utf8_lower(pTHX_ const U8 *p)
a0ed51b3 1389{
97aff369 1390 dVAR;
7918f24d
NC
1391
1392 PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1393
d4c19fe8 1394 return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
a0ed51b3
LW
1395}
1396
1397bool
7fc63493 1398Perl_is_utf8_cntrl(pTHX_ const U8 *p)
b8c5462f 1399{
97aff369 1400 dVAR;
7918f24d
NC
1401
1402 PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1403
d4c19fe8 1404 return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
b8c5462f
JH
1405}
1406
1407bool
7fc63493 1408Perl_is_utf8_graph(pTHX_ const U8 *p)
b8c5462f 1409{
97aff369 1410 dVAR;
7918f24d
NC
1411
1412 PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1413
d4c19fe8 1414 return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
b8c5462f
JH
1415}
1416
1417bool
7fc63493 1418Perl_is_utf8_print(pTHX_ const U8 *p)
a0ed51b3 1419{
97aff369 1420 dVAR;
7918f24d
NC
1421
1422 PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1423
d4c19fe8 1424 return is_utf8_common(p, &PL_utf8_print, "IsPrint");
a0ed51b3
LW
1425}
1426
1427bool
7fc63493 1428Perl_is_utf8_punct(pTHX_ const U8 *p)
b8c5462f 1429{
97aff369 1430 dVAR;
7918f24d
NC
1431
1432 PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1433
d4c19fe8 1434 return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
b8c5462f
JH
1435}
1436
1437bool
7fc63493 1438Perl_is_utf8_xdigit(pTHX_ const U8 *p)
b8c5462f 1439{
97aff369 1440 dVAR;
7918f24d
NC
1441
1442 PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1443
d4c19fe8 1444 return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
b8c5462f
JH
1445}
1446
1447bool
7fc63493 1448Perl_is_utf8_mark(pTHX_ const U8 *p)
a0ed51b3 1449{
97aff369 1450 dVAR;
7918f24d
NC
1451
1452 PERL_ARGS_ASSERT_IS_UTF8_MARK;
1453
d4c19fe8 1454 return is_utf8_common(p, &PL_utf8_mark, "IsM");
a0ed51b3
LW
1455}
1456
6b5c0936 1457/*
87cea99e 1458=for apidoc to_utf8_case
6b5c0936
JH
1459
1460The "p" contains the pointer to the UTF-8 string encoding
1461the character that is being converted.
1462
1463The "ustrp" is a pointer to the character buffer to put the
1464conversion result to. The "lenp" is a pointer to the length
1465of the result.
1466
0134edef 1467The "swashp" is a pointer to the swash to use.
6b5c0936 1468
0134edef 1469Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
8fe4d5b2 1470and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
0134edef 1471but not always, a multicharacter mapping), is tried first.
6b5c0936 1472
0134edef
JH
1473The "special" is a string like "utf8::ToSpecLower", which means the
1474hash %utf8::ToSpecLower. The access to the hash is through
1475Perl_to_utf8_case().
6b5c0936 1476
0134edef
JH
1477The "normal" is a string like "ToLower" which means the swash
1478%utf8::ToLower.
1479
1480=cut */
6b5c0936 1481
2104c8d9 1482UV
9a957fbc
AL
1483Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1484 SV **swashp, const char *normal, const char *special)
a0ed51b3 1485{
97aff369 1486 dVAR;
89ebb4a3 1487 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
0134edef 1488 STRLEN len = 0;
aec46f14 1489 const UV uv0 = utf8_to_uvchr(p, NULL);
1feea2c7
JH
1490 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1491 * are necessary in EBCDIC, they are redundant no-ops
1492 * in ASCII-ish platforms, and hopefully optimized away. */
f54cb97a 1493 const UV uv1 = NATIVE_TO_UNI(uv0);
7918f24d
NC
1494
1495 PERL_ARGS_ASSERT_TO_UTF8_CASE;
1496
1feea2c7 1497 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
1498
1499 if (!*swashp) /* load on-demand */
1500 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1501
b08cf34e
JH
1502 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1503 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
0134edef 1504 /* It might be "special" (sometimes, but not always,
2a37f04d 1505 * a multicharacter mapping) */
6673a63c 1506 HV * const hv = get_hv(special, 0);
b08cf34e
JH
1507 SV **svp;
1508
35da51f7 1509 if (hv &&
b08cf34e
JH
1510 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1511 (*svp)) {
cfd0369c 1512 const char *s;
47654450 1513
cfd0369c 1514 s = SvPV_const(*svp, len);
47654450
JH
1515 if (len == 1)
1516 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 1517 else {
2f9475ad
JH
1518#ifdef EBCDIC
1519 /* If we have EBCDIC we need to remap the characters
1520 * since any characters in the low 256 are Unicode
1521 * code points, not EBCDIC. */
7cda7a3d 1522 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
1523
1524 d = tmpbuf;
b08cf34e 1525 if (SvUTF8(*svp)) {
2f9475ad
JH
1526 STRLEN tlen = 0;
1527
1528 while (t < tend) {
d4c19fe8 1529 const UV c = utf8_to_uvchr(t, &tlen);
2f9475ad
JH
1530 if (tlen > 0) {
1531 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1532 t += tlen;
1533 }
1534 else
1535 break;
1536 }
1537 }
1538 else {
36fec512
JH
1539 while (t < tend) {
1540 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1541 t++;
1542 }
2f9475ad
JH
1543 }
1544 len = d - tmpbuf;
1545 Copy(tmpbuf, ustrp, len, U8);
1546#else
d2dcd0fb 1547 Copy(s, ustrp, len, U8);
2f9475ad 1548#endif
29e98929 1549 }
983ffd37 1550 }
0134edef
JH
1551 }
1552
1553 if (!len && *swashp) {
d4c19fe8
AL
1554 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1555
0134edef
JH
1556 if (uv2) {
1557 /* It was "normal" (a single character mapping). */
d4c19fe8 1558 const UV uv3 = UNI_TO_NATIVE(uv2);
e9101d72 1559 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2a37f04d
JH
1560 }
1561 }
1feea2c7 1562
0134edef
JH
1563 if (!len) /* Neither: just copy. */
1564 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1565
2a37f04d
JH
1566 if (lenp)
1567 *lenp = len;
1568
0134edef 1569 return len ? utf8_to_uvchr(ustrp, 0) : 0;
a0ed51b3
LW
1570}
1571
d3e79532 1572/*
87cea99e 1573=for apidoc to_utf8_upper
d3e79532
JH
1574
1575Convert the UTF-8 encoded character at p to its uppercase version and
1576store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1577that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1578the uppercase version may be longer than the original character.
d3e79532
JH
1579
1580The first character of the uppercased version is returned
1581(but note, as explained above, that there may be more.)
1582
1583=cut */
1584
2104c8d9 1585UV
7fc63493 1586Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1587{
97aff369 1588 dVAR;
7918f24d
NC
1589
1590 PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1591
983ffd37 1592 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1593 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
983ffd37 1594}
a0ed51b3 1595
d3e79532 1596/*
87cea99e 1597=for apidoc to_utf8_title
d3e79532
JH
1598
1599Convert the UTF-8 encoded character at p to its titlecase version and
1600store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1601that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1602titlecase version may be longer than the original character.
d3e79532
JH
1603
1604The first character of the titlecased version is returned
1605(but note, as explained above, that there may be more.)
1606
1607=cut */
1608
983ffd37 1609UV
7fc63493 1610Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
983ffd37 1611{
97aff369 1612 dVAR;
7918f24d
NC
1613
1614 PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1615
983ffd37 1616 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1617 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
a0ed51b3
LW
1618}
1619
d3e79532 1620/*
87cea99e 1621=for apidoc to_utf8_lower
d3e79532
JH
1622
1623Convert the UTF-8 encoded character at p to its lowercase version and
1624store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1625that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1626lowercase version may be longer than the original character.
d3e79532
JH
1627
1628The first character of the lowercased version is returned
1629(but note, as explained above, that there may be more.)
1630
1631=cut */
1632
2104c8d9 1633UV
7fc63493 1634Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1635{
97aff369 1636 dVAR;
7918f24d
NC
1637
1638 PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1639
983ffd37 1640 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9
JH
1641 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1642}
1643
d3e79532 1644/*
87cea99e 1645=for apidoc to_utf8_fold
d3e79532
JH
1646
1647Convert the UTF-8 encoded character at p to its foldcase version and
1648store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3 1649that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
d3e79532
JH
1650foldcase version may be longer than the original character (up to
1651three characters).
1652
1653The first character of the foldcased version is returned
1654(but note, as explained above, that there may be more.)
1655
1656=cut */
1657
b4e400f9 1658UV
7fc63493 1659Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
b4e400f9 1660{
97aff369 1661 dVAR;
7918f24d
NC
1662
1663 PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1664
b4e400f9
JH
1665 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1666 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
a0ed51b3
LW
1667}
1668
711a919c
ST
1669/* Note:
1670 * A "swash" is a swatch hash.
1671 * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1672 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1673 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1674 */
a0ed51b3 1675SV*
7fc63493 1676Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3 1677{
27da23d5 1678 dVAR;
a0ed51b3 1679 SV* retval;
8e84507e 1680 dSP;
7fc63493
AL
1681 const size_t pkg_len = strlen(pkg);
1682 const size_t name_len = strlen(name);
da51bb9b 1683 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
f8be5cf0 1684 SV* errsv_save;
ce3b816e 1685
7918f24d
NC
1686 PERL_ARGS_ASSERT_SWASH_INIT;
1687
96ca9f55
DM
1688 PUSHSTACKi(PERLSI_MAGIC);
1689 ENTER;
1690 SAVEI32(PL_hints);
1691 PL_hints = 0;
1692 save_re_context();
1b026014 1693 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ce3b816e 1694 ENTER;
f8be5cf0 1695 errsv_save = newSVsv(ERRSV);
dc0c6abb
NC
1696 /* It is assumed that callers of this routine are not passing in any
1697 user derived data. */
1698 /* Need to do this after save_re_context() as it will set PL_tainted to
1699 1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1700 Even line to create errsv_save can turn on PL_tainted. */
1701 SAVEBOOL(PL_tainted);
1702 PL_tainted = 0;
71bed85a 1703 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
a0714e2c 1704 NULL);
f8be5cf0
JH
1705 if (!SvTRUE(ERRSV))
1706 sv_setsv(ERRSV, errsv_save);
1707 SvREFCNT_dec(errsv_save);
ce3b816e
GS
1708 LEAVE;
1709 }
1710 SPAGAIN;
a0ed51b3
LW
1711 PUSHMARK(SP);
1712 EXTEND(SP,5);
6e449a3a
MHM
1713 mPUSHp(pkg, pkg_len);
1714 mPUSHp(name, name_len);
a0ed51b3 1715 PUSHs(listsv);
6e449a3a
MHM
1716 mPUSHi(minbits);
1717 mPUSHi(none);
a0ed51b3 1718 PUTBACK;
f8be5cf0 1719 errsv_save = newSVsv(ERRSV);
864dbfa3 1720 if (call_method("SWASHNEW", G_SCALAR))
8e84507e 1721 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1722 else
e24b16f9 1723 retval = &PL_sv_undef;
f8be5cf0
JH
1724 if (!SvTRUE(ERRSV))
1725 sv_setsv(ERRSV, errsv_save);
1726 SvREFCNT_dec(errsv_save);
a0ed51b3
LW
1727 LEAVE;
1728 POPSTACK;
923e4eb5 1729 if (IN_PERL_COMPILETIME) {
623e6609 1730 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 1731 }
bc45ce41
JH
1732 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1733 if (SvPOK(retval))
35c1215d 1734 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
be2597df 1735 SVfARG(retval));
cea2e8a9 1736 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
bc45ce41 1737 }
a0ed51b3
LW
1738 return retval;
1739}
1740
035d37be
JH
1741
1742/* This API is wrong for special case conversions since we may need to
1743 * return several Unicode characters for a single Unicode character
1744 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1745 * the lower-level routine, and it is similarly broken for returning
1746 * multiple values. --jhi */
979f2922 1747/* Now SWASHGET is recasted into S_swash_get in this file. */
680c470c
ST
1748
1749/* Note:
1750 * Returns the value of property/mapping C<swash> for the first character
1751 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1752 * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1753 * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1754 */
a0ed51b3 1755UV
680c470c 1756Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
a0ed51b3 1757{
27da23d5 1758 dVAR;
ef8f7699 1759 HV *const hv = MUTABLE_HV(SvRV(swash));
3568d838
JH
1760 U32 klen;
1761 U32 off;
a0ed51b3 1762 STRLEN slen;
7d85a32c 1763 STRLEN needents;
cfd0369c 1764 const U8 *tmps = NULL;
a0ed51b3 1765 U32 bit;
979f2922 1766 SV *swatch;
3568d838 1767 U8 tmputf8[2];
35da51f7 1768 const UV c = NATIVE_TO_ASCII(*ptr);
3568d838 1769
7918f24d
NC
1770 PERL_ARGS_ASSERT_SWASH_FETCH;
1771
3568d838 1772 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
979f2922
ST
1773 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1774 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1775 ptr = tmputf8;
3568d838
JH
1776 }
1777 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1778 * then the "swatch" is a vec() for al the chars which start
1779 * with 0xAA..0xYY
1780 * So the key in the hash (klen) is length of encoded char -1
1781 */
1782 klen = UTF8SKIP(ptr) - 1;
1783 off = ptr[klen];
a0ed51b3 1784
979f2922 1785 if (klen == 0) {
7d85a32c 1786 /* If char in invariant then swatch is for all the invariant chars
1e54db1a 1787 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
7d85a32c 1788 */
979f2922
ST
1789 needents = UTF_CONTINUATION_MARK;
1790 off = NATIVE_TO_UTF(ptr[klen]);
1791 }
1792 else {
7d85a32c 1793 /* If char is encoded then swatch is for the prefix */
979f2922
ST
1794 needents = (1 << UTF_ACCUMULATION_SHIFT);
1795 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1796 }
7d85a32c 1797
a0ed51b3
LW
1798 /*
1799 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1800 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1801 * it's nothing to sniff at.) Pity we usually come through at least
1802 * two function calls to get here...
1803 *
1804 * NB: this code assumes that swatches are never modified, once generated!
1805 */
1806
3568d838 1807 if (hv == PL_last_swash_hv &&
a0ed51b3 1808 klen == PL_last_swash_klen &&
27da23d5 1809 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
1810 {
1811 tmps = PL_last_swash_tmps;
1812 slen = PL_last_swash_slen;
1813 }
1814 else {
1815 /* Try our second-level swatch cache, kept in a hash. */
e1ec3a88 1816 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
a0ed51b3 1817
979f2922
ST
1818 /* If not cached, generate it via swash_get */
1819 if (!svp || !SvPOK(*svp)
1820 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2b9d42f0
NIS
1821 /* We use utf8n_to_uvuni() as we want an index into
1822 Unicode tables, not a native character number.
1823 */
aec46f14 1824 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
872c91ae
JH
1825 ckWARN(WARN_UTF8) ?
1826 0 : UTF8_ALLOW_ANY);
680c470c 1827 swatch = swash_get(swash,
979f2922
ST
1828 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1829 (klen) ? (code_point & ~(needents - 1)) : 0,
1830 needents);
1831
923e4eb5 1832 if (IN_PERL_COMPILETIME)
623e6609 1833 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 1834
979f2922 1835 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
a0ed51b3 1836
979f2922
ST
1837 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1838 || (slen << 3) < needents)
660a4616 1839 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
a0ed51b3
LW
1840 }
1841
1842 PL_last_swash_hv = hv;
16d8f38a 1843 assert(klen <= sizeof(PL_last_swash_key));
eac04b2e 1844 PL_last_swash_klen = (U8)klen;
cfd0369c
NC
1845 /* FIXME change interpvar.h? */
1846 PL_last_swash_tmps = (U8 *) tmps;
a0ed51b3
LW
1847 PL_last_swash_slen = slen;
1848 if (klen)
1849 Copy(ptr, PL_last_swash_key, klen, U8);
1850 }
1851
9faf8d75 1852 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
1853 case 1:
1854 bit = 1 << (off & 7);
1855 off >>= 3;
1856 return (tmps[off] & bit) != 0;
1857 case 8:
1858 return tmps[off];
1859 case 16:
1860 off <<= 1;
1861 return (tmps[off] << 8) + tmps[off + 1] ;
1862 case 32:
1863 off <<= 2;
1864 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1865 }
660a4616 1866 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
670f1322 1867 NORETURN_FUNCTION_END;
a0ed51b3 1868}
2b9d42f0 1869
979f2922
ST
1870/* Note:
1871 * Returns a swatch (a bit vector string) for a code point sequence
1872 * that starts from the value C<start> and comprises the number C<span>.
1873 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1874 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1875 */
1876STATIC SV*
1877S_swash_get(pTHX_ SV* swash, UV start, UV span)
1878{
1879 SV *swatch;
711a919c 1880 U8 *l, *lend, *x, *xend, *s;
979f2922 1881 STRLEN lcur, xcur, scur;
ef8f7699 1882 HV *const hv = MUTABLE_HV(SvRV(swash));
017a3ce5
GA
1883 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1884 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1885 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1886 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1887 SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
0bd48802
AL
1888 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1889 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
1890 const STRLEN bits = SvUV(*bitssvp);
1891 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1892 const UV none = SvUV(*nonesvp);
1893 const UV end = start + span;
979f2922 1894
7918f24d
NC
1895 PERL_ARGS_ASSERT_SWASH_GET;
1896
979f2922 1897 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
660a4616
ST
1898 Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1899 (UV)bits);
979f2922
ST
1900 }
1901
1902 /* create and initialize $swatch */
979f2922 1903 scur = octets ? (span * octets) : (span + 7) / 8;
e524fe40
NC
1904 swatch = newSV(scur);
1905 SvPOK_on(swatch);
979f2922
ST
1906 s = (U8*)SvPVX(swatch);
1907 if (octets && none) {
0bd48802 1908 const U8* const e = s + scur;
979f2922
ST
1909 while (s < e) {
1910 if (bits == 8)
1911 *s++ = (U8)(none & 0xff);
1912 else if (bits == 16) {
1913 *s++ = (U8)((none >> 8) & 0xff);
1914 *s++ = (U8)( none & 0xff);
1915 }
1916 else if (bits == 32) {
1917 *s++ = (U8)((none >> 24) & 0xff);
1918 *s++ = (U8)((none >> 16) & 0xff);
1919 *s++ = (U8)((none >> 8) & 0xff);
1920 *s++ = (U8)( none & 0xff);
1921 }
1922 }
1923 *s = '\0';
1924 }
1925 else {
1926 (void)memzero((U8*)s, scur + 1);
1927 }
1928 SvCUR_set(swatch, scur);
1929 s = (U8*)SvPVX(swatch);
1930
1931 /* read $swash->{LIST} */
1932 l = (U8*)SvPV(*listsvp, lcur);
1933 lend = l + lcur;
1934 while (l < lend) {
35da51f7 1935 UV min, max, val;
979f2922
ST
1936 STRLEN numlen;
1937 I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1938
0bd48802 1939 U8* const nl = (U8*)memchr(l, '\n', lend - l);
979f2922
ST
1940
1941 numlen = lend - l;
1942 min = grok_hex((char *)l, &numlen, &flags, NULL);
1943 if (numlen)
1944 l += numlen;
1945 else if (nl) {
1946 l = nl + 1; /* 1 is length of "\n" */
1947 continue;
1948 }
1949 else {
1950 l = lend; /* to LIST's end at which \n is not found */
1951 break;
1952 }
1953
1954 if (isBLANK(*l)) {
1955 ++l;
1956 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1957 numlen = lend - l;
1958 max = grok_hex((char *)l, &numlen, &flags, NULL);
1959 if (numlen)
1960 l += numlen;
1961 else
1962 max = min;
1963
1964 if (octets) {
1965 if (isBLANK(*l)) {
1966 ++l;
1967 flags = PERL_SCAN_SILENT_ILLDIGIT |
1968 PERL_SCAN_DISALLOW_PREFIX;
1969 numlen = lend - l;
1970 val = grok_hex((char *)l, &numlen, &flags, NULL);
1971 if (numlen)
1972 l += numlen;
1973 else
1974 val = 0;
1975 }
1976 else {
1977 val = 0;
1978 if (typeto) {
1979 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1980 typestr, l);
1981 }
1982 }
1983 }
711a919c
ST
1984 else
1985 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
1986 }
1987 else {
1988 max = min;
1989 if (octets) {
1990 val = 0;
1991 if (typeto) {
1992 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1993 }
1994 }
711a919c
ST
1995 else
1996 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
1997 }
1998
1999 if (nl)
2000 l = nl + 1;
2001 else
2002 l = lend;
2003
2004 if (max < start)
2005 continue;
2006
2007 if (octets) {
35da51f7 2008 UV key;
979f2922
ST
2009 if (min < start) {
2010 if (!none || val < none) {
2011 val += start - min;
2012 }
2013 min = start;
2014 }
2015 for (key = min; key <= max; key++) {
2016 STRLEN offset;
2017 if (key >= end)
2018 goto go_out_list;
2019 /* offset must be non-negative (start <= min <= key < end) */
2020 offset = octets * (key - start);
2021 if (bits == 8)
2022 s[offset] = (U8)(val & 0xff);
2023 else if (bits == 16) {
2024 s[offset ] = (U8)((val >> 8) & 0xff);
2025 s[offset + 1] = (U8)( val & 0xff);
2026 }
2027 else if (bits == 32) {
2028 s[offset ] = (U8)((val >> 24) & 0xff);
2029 s[offset + 1] = (U8)((val >> 16) & 0xff);
2030 s[offset + 2] = (U8)((val >> 8) & 0xff);
2031 s[offset + 3] = (U8)( val & 0xff);
2032 }
2033
2034 if (!none || val < none)
2035 ++val;
2036 }
2037 }
711a919c 2038 else { /* bits == 1, then val should be ignored */
35da51f7 2039 UV key;
979f2922
ST
2040 if (min < start)
2041 min = start;
2042 for (key = min; key <= max; key++) {
0bd48802 2043 const STRLEN offset = (STRLEN)(key - start);
979f2922
ST
2044 if (key >= end)
2045 goto go_out_list;
2046 s[offset >> 3] |= 1 << (offset & 7);
2047 }
2048 }
2049 } /* while */
2050 go_out_list:
2051
2052 /* read $swash->{EXTRAS} */
2053 x = (U8*)SvPV(*extssvp, xcur);
2054 xend = x + xcur;
2055 while (x < xend) {
2056 STRLEN namelen;
2057 U8 *namestr;
2058 SV** othersvp;
2059 HV* otherhv;
2060 STRLEN otherbits;
2061 SV **otherbitssvp, *other;
711a919c 2062 U8 *s, *o, *nl;
979f2922
ST
2063 STRLEN slen, olen;
2064
35da51f7 2065 const U8 opc = *x++;
979f2922
ST
2066 if (opc == '\n')
2067 continue;
2068
2069 nl = (U8*)memchr(x, '\n', xend - x);
2070
2071 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2072 if (nl) {
2073 x = nl + 1; /* 1 is length of "\n" */
2074 continue;
2075 }
2076 else {
2077 x = xend; /* to EXTRAS' end at which \n is not found */
2078 break;
2079 }
2080 }
2081
2082 namestr = x;
2083 if (nl) {
2084 namelen = nl - namestr;
2085 x = nl + 1;
2086 }
2087 else {
2088 namelen = xend - namestr;
2089 x = xend;
2090 }
2091
2092 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
ef8f7699 2093 otherhv = MUTABLE_HV(SvRV(*othersvp));
017a3ce5 2094 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
979f2922
ST
2095 otherbits = (STRLEN)SvUV(*otherbitssvp);
2096 if (bits < otherbits)
660a4616 2097 Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
979f2922
ST
2098
2099 /* The "other" swatch must be destroyed after. */
2100 other = swash_get(*othersvp, start, span);
2101 o = (U8*)SvPV(other, olen);
2102
2103 if (!olen)
660a4616 2104 Perl_croak(aTHX_ "panic: swash_get got improper swatch");
979f2922
ST
2105
2106 s = (U8*)SvPV(swatch, slen);
2107 if (bits == 1 && otherbits == 1) {
2108 if (slen != olen)
660a4616 2109 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
979f2922
ST
2110
2111 switch (opc) {
2112 case '+':
2113 while (slen--)
2114 *s++ |= *o++;
2115 break;
2116 case '!':
2117 while (slen--)
2118 *s++ |= ~*o++;
2119 break;
2120 case '-':
2121 while (slen--)
2122 *s++ &= ~*o++;
2123 break;
2124 case '&':
2125 while (slen--)
2126 *s++ &= *o++;
2127 break;
2128 default:
2129 break;
2130 }
2131 }
711a919c 2132 else {
979f2922
ST
2133 STRLEN otheroctets = otherbits >> 3;
2134 STRLEN offset = 0;
35da51f7 2135 U8* const send = s + slen;
979f2922
ST
2136
2137 while (s < send) {
2138 UV otherval = 0;
2139
2140 if (otherbits == 1) {
2141 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2142 ++offset;
2143 }
2144 else {
2145 STRLEN vlen = otheroctets;
2146 otherval = *o++;
2147 while (--vlen) {
2148 otherval <<= 8;
2149 otherval |= *o++;
2150 }
2151 }
2152
711a919c 2153 if (opc == '+' && otherval)
6f207bd3 2154 NOOP; /* replace with otherval */
979f2922
ST
2155 else if (opc == '!' && !otherval)
2156 otherval = 1;
2157 else if (opc == '-' && otherval)
2158 otherval = 0;
2159 else if (opc == '&' && !otherval)
2160 otherval = 0;
2161 else {
711a919c 2162 s += octets; /* no replacement */
979f2922
ST
2163 continue;
2164 }
2165
2166 if (bits == 8)
2167 *s++ = (U8)( otherval & 0xff);
2168 else if (bits == 16) {
2169 *s++ = (U8)((otherval >> 8) & 0xff);
2170 *s++ = (U8)( otherval & 0xff);
2171 }
2172 else if (bits == 32) {
2173 *s++ = (U8)((otherval >> 24) & 0xff);
2174 *s++ = (U8)((otherval >> 16) & 0xff);
2175 *s++ = (U8)((otherval >> 8) & 0xff);
2176 *s++ = (U8)( otherval & 0xff);
2177 }
2178 }
2179 }
2180 sv_free(other); /* through with it! */
2181 } /* while */
2182 return swatch;
2183}
2184
0f830e0b 2185/*
87cea99e 2186=for apidoc uvchr_to_utf8
0f830e0b
NC
2187
2188Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2189of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2190bytes available. The return value is the pointer to the byte after the
2191end of the new character. In other words,
2192
2193 d = uvchr_to_utf8(d, uv);
2194
2195is the recommended wide native character-aware way of saying
2196
2197 *(d++) = uv;
2198
2199=cut
2200*/
2201
2202/* On ASCII machines this is normally a macro but we want a
2203 real function in case XS code wants it
2204*/
0f830e0b
NC
2205U8 *
2206Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2207{
7918f24d
NC
2208 PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2209
0f830e0b
NC
2210 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2211}
2212
b851fbc1
JH
2213U8 *
2214Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2215{
7918f24d
NC
2216 PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2217
b851fbc1
JH
2218 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2219}
2b9d42f0
NIS
2220
2221/*
87cea99e 2222=for apidoc utf8n_to_uvchr
0f830e0b
NC
2223flags
2224
2225Returns the native character value of the first character in the string
2226C<s>
2227which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2228length, in bytes, of that character.
2229
2230Allows length and flags to be passed to low level routine.
2231
2232=cut
2233*/
2234/* On ASCII machines this is normally a macro but we want
2235 a real function in case XS code wants it
2236*/
0f830e0b
NC
2237UV
2238Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2239U32 flags)
2240{
2241 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
7918f24d
NC
2242
2243 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2244
0f830e0b
NC
2245 return UNI_TO_NATIVE(uv);
2246}
2247
2248/*
87cea99e 2249=for apidoc pv_uni_display
d2cc3551
JH
2250
2251Build to the scalar dsv a displayable version of the string spv,
2252length len, the displayable version being at most pvlim bytes long
2253(if longer, the rest is truncated and "..." will be appended).
0a2ef054 2254
9e55ce06 2255The flags argument can have UNI_DISPLAY_ISPRINT set to display
00e86452 2256isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
0a2ef054
JH
2257to display the \\[nrfta\\] as the backslashed versions (like '\n')
2258(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2259UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2260UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2261
d2cc3551
JH
2262The pointer to the PV of the dsv is returned.
2263
2264=cut */
e6b2e755 2265char *
e1ec3a88 2266Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
e6b2e755
JH
2267{
2268 int truncated = 0;
e1ec3a88 2269 const char *s, *e;
e6b2e755 2270
7918f24d
NC
2271 PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2272
76f68e9b 2273 sv_setpvs(dsv, "");
7fddd944 2274 SvUTF8_off(dsv);
e1ec3a88 2275 for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
e6b2e755 2276 UV u;
a49f32c6
NC
2277 /* This serves double duty as a flag and a character to print after
2278 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2279 */
2280 char ok = 0;
c728cb41 2281
e6b2e755
JH
2282 if (pvlim && SvCUR(dsv) >= pvlim) {
2283 truncated++;
2284 break;
2285 }
2286 u = utf8_to_uvchr((U8*)s, 0);
c728cb41 2287 if (u < 256) {
a3b680e6 2288 const unsigned char c = (unsigned char)u & 0xFF;
0bd48802 2289 if (flags & UNI_DISPLAY_BACKSLASH) {
a49f32c6 2290 switch (c) {
c728cb41 2291 case '\n':
a49f32c6 2292 ok = 'n'; break;
c728cb41 2293 case '\r':
a49f32c6 2294 ok = 'r'; break;
c728cb41 2295 case '\t':
a49f32c6 2296 ok = 't'; break;
c728cb41 2297 case '\f':
a49f32c6 2298 ok = 'f'; break;
c728cb41 2299 case '\a':
a49f32c6 2300 ok = 'a'; break;
c728cb41 2301 case '\\':
a49f32c6 2302 ok = '\\'; break;
c728cb41
JH
2303 default: break;
2304 }
a49f32c6 2305 if (ok) {
88c9ea1e 2306 const char string = ok;
76f68e9b 2307 sv_catpvs(dsv, "\\");
5e7aa789 2308 sv_catpvn(dsv, &string, 1);
a49f32c6 2309 }
c728cb41 2310 }
00e86452 2311 /* isPRINT() is the locale-blind version. */
a49f32c6 2312 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
88c9ea1e 2313 const char string = c;
5e7aa789 2314 sv_catpvn(dsv, &string, 1);
a49f32c6 2315 ok = 1;
0a2ef054 2316 }
c728cb41
JH
2317 }
2318 if (!ok)
9e55ce06 2319 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
e6b2e755
JH
2320 }
2321 if (truncated)
396482e1 2322 sv_catpvs(dsv, "...");
e6b2e755
JH
2323
2324 return SvPVX(dsv);
2325}
2b9d42f0 2326
d2cc3551 2327/*
87cea99e 2328=for apidoc sv_uni_display
d2cc3551
JH
2329
2330Build to the scalar dsv a displayable version of the scalar sv,
0a2ef054 2331the displayable version being at most pvlim bytes long
d2cc3551 2332(if longer, the rest is truncated and "..." will be appended).
0a2ef054
JH
2333
2334The flags argument is as in pv_uni_display().
2335
d2cc3551
JH
2336The pointer to the PV of the dsv is returned.
2337
d4c19fe8
AL
2338=cut
2339*/
e6b2e755
JH
2340char *
2341Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2342{
7918f24d
NC
2343 PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2344
cfd0369c
NC
2345 return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2346 SvCUR(ssv), pvlim, flags);
701a277b
JH
2347}
2348
d2cc3551 2349/*
87cea99e 2350=for apidoc ibcmp_utf8
d2cc3551
JH
2351
2352Return true if the strings s1 and s2 differ case-insensitively, false
2353if not (if they are equal case-insensitively). If u1 is true, the
2354string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
d07ddd77
JH
2355the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
2356are false, the respective string is assumed to be in native 8-bit
2357encoding.
2358
2359If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2360in there (they will point at the beginning of the I<next> character).
2361If the pointers behind pe1 or pe2 are non-NULL, they are the end
2362pointers beyond which scanning will not continue under any
4cdaeff7 2363circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
d07ddd77
JH
2364s2+l2 will be used as goal end pointers that will also stop the scan,
2365and which qualify towards defining a successful match: all the scans
2366that define an explicit length must reach their goal pointers for
2367a match to succeed).
d2cc3551
JH
2368
2369For case-insensitiveness, the "casefolding" of Unicode is used
2370instead of upper/lowercasing both the characters, see
2371http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2372
2373=cut */
701a277b 2374I32
d07ddd77 2375Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
332ddc25 2376{
97aff369 2377 dVAR;
e1ec3a88
AL
2378 register const U8 *p1 = (const U8*)s1;
2379 register const U8 *p2 = (const U8*)s2;
cbbf8932 2380 register const U8 *f1 = NULL;
2f73348c 2381 register const U8 *f2 = NULL;
cbbf8932
AL
2382 register U8 *e1 = NULL;
2383 register U8 *q1 = NULL;
2384 register U8 *e2 = NULL;
2385 register U8 *q2 = NULL;
d07ddd77 2386 STRLEN n1 = 0, n2 = 0;
89ebb4a3
JH
2387 U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2388 U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
d7f013c8
JH
2389 U8 natbuf[1+1];
2390 STRLEN foldlen1, foldlen2;
d07ddd77 2391 bool match;
7918f24d
NC
2392
2393 PERL_ARGS_ASSERT_IBCMP_UTF8;
332ddc25 2394
d07ddd77
JH
2395 if (pe1)
2396 e1 = *(U8**)pe1;
a0a388a1 2397 /* assert(e1 || l1); */
e1ec3a88
AL
2398 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2399 f1 = (const U8*)s1 + l1;
d07ddd77
JH
2400 if (pe2)
2401 e2 = *(U8**)pe2;
a0a388a1 2402 /* assert(e2 || l2); */
e1ec3a88
AL
2403 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2404 f2 = (const U8*)s2 + l2;
d07ddd77 2405
a0a388a1
YO
2406 /* This shouldn't happen. However, putting an assert() there makes some
2407 * tests fail. */
2408 /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
d07ddd77
JH
2409 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2410 return 1; /* mismatch; possible infinite loop or false positive */
2411
a6872d42
JH
2412 if (!u1 || !u2)
2413 natbuf[1] = 0; /* Need to terminate the buffer. */
2414
d07ddd77
JH
2415 while ((e1 == 0 || p1 < e1) &&
2416 (f1 == 0 || p1 < f1) &&
2417 (e2 == 0 || p2 < e2) &&
2418 (f2 == 0 || p2 < f2)) {
2419 if (n1 == 0) {
d7f013c8
JH
2420 if (u1)
2421 to_utf8_fold(p1, foldbuf1, &foldlen1);
2422 else {
809e8e66 2423 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
d7f013c8
JH
2424 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2425 }
2426 q1 = foldbuf1;
d07ddd77 2427 n1 = foldlen1;
332ddc25 2428 }
d07ddd77 2429 if (n2 == 0) {
d7f013c8
JH
2430 if (u2)
2431 to_utf8_fold(p2, foldbuf2, &foldlen2);
2432 else {
809e8e66 2433 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
d7f013c8
JH
2434 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2435 }
2436 q2 = foldbuf2;
d07ddd77 2437 n2 = foldlen2;
332ddc25 2438 }
d07ddd77
JH
2439 while (n1 && n2) {
2440 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2441 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2442 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
d7f013c8 2443 return 1; /* mismatch */
d07ddd77 2444 n1 -= UTF8SKIP(q1);
d7f013c8 2445 q1 += UTF8SKIP(q1);
d07ddd77 2446 n2 -= UTF8SKIP(q2);
d7f013c8 2447 q2 += UTF8SKIP(q2);
701a277b 2448 }
d07ddd77 2449 if (n1 == 0)
d7f013c8 2450 p1 += u1 ? UTF8SKIP(p1) : 1;
d07ddd77 2451 if (n2 == 0)
d7f013c8
JH
2452 p2 += u2 ? UTF8SKIP(p2) : 1;
2453
d2cc3551 2454 }
5469e704 2455
d07ddd77
JH
2456 /* A match is defined by all the scans that specified
2457 * an explicit length reaching their final goals. */
2458 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
5469e704
JH
2459
2460 if (match) {
d07ddd77
JH
2461 if (pe1)
2462 *pe1 = (char*)p1;
2463 if (pe2)
2464 *pe2 = (char*)p2;
5469e704
JH
2465 }
2466
2467 return match ? 0 : 1; /* 0 match, 1 mismatch */
e6b2e755 2468}
701a277b 2469
a49f32c6
NC
2470/*
2471 * Local variables:
2472 * c-indentation-style: bsd
2473 * c-basic-offset: 4
2474 * indent-tabs-mode: t
2475 * End:
2476 *
37442d52
RGS
2477 * ex: set ts=8 sts=4 sw=4 noet:
2478 */