This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf16_to_utf8_reversed() should croak early when passed an odd byte length.
[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
e0ea5e2d
NC
1023 if (bytelen & 1)
1024 Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1025 (UV)bytelen);
1026
a0ed51b3 1027 while (s < send) {
d4c19fe8 1028 const U8 tmp = s[0];
a0ed51b3
LW
1029 s[0] = s[1];
1030 s[1] = tmp;
1031 s += 2;
1032 }
dea0fc0b 1033 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
1034}
1035
1036/* for now these are all defined (inefficiently) in terms of the utf8 versions */
1037
1038bool
84afefe6 1039Perl_is_uni_alnum(pTHX_ UV c)
a0ed51b3 1040{
89ebb4a3 1041 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1042 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1043 return is_utf8_alnum(tmpbuf);
1044}
1045
1046bool
84afefe6 1047Perl_is_uni_idfirst(pTHX_ UV c)
a0ed51b3 1048{
89ebb4a3 1049 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1050 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1051 return is_utf8_idfirst(tmpbuf);
1052}
1053
1054bool
84afefe6 1055Perl_is_uni_alpha(pTHX_ UV c)
a0ed51b3 1056{
89ebb4a3 1057 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1058 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1059 return is_utf8_alpha(tmpbuf);
1060}
1061
1062bool
84afefe6 1063Perl_is_uni_ascii(pTHX_ UV c)
4d61ec05 1064{
89ebb4a3 1065 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1066 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
1067 return is_utf8_ascii(tmpbuf);
1068}
1069
1070bool
84afefe6 1071Perl_is_uni_space(pTHX_ UV c)
a0ed51b3 1072{
89ebb4a3 1073 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1074 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1075 return is_utf8_space(tmpbuf);
1076}
1077
1078bool
84afefe6 1079Perl_is_uni_digit(pTHX_ UV c)
a0ed51b3 1080{
89ebb4a3 1081 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1082 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1083 return is_utf8_digit(tmpbuf);
1084}
1085
1086bool
84afefe6 1087Perl_is_uni_upper(pTHX_ UV c)
a0ed51b3 1088{
89ebb4a3 1089 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1090 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1091 return is_utf8_upper(tmpbuf);
1092}
1093
1094bool
84afefe6 1095Perl_is_uni_lower(pTHX_ UV c)
a0ed51b3 1096{
89ebb4a3 1097 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1098 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1099 return is_utf8_lower(tmpbuf);
1100}
1101
1102bool
84afefe6 1103Perl_is_uni_cntrl(pTHX_ UV c)
b8c5462f 1104{
89ebb4a3 1105 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1106 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1107 return is_utf8_cntrl(tmpbuf);
1108}
1109
1110bool
84afefe6 1111Perl_is_uni_graph(pTHX_ UV c)
b8c5462f 1112{
89ebb4a3 1113 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1114 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1115 return is_utf8_graph(tmpbuf);
1116}
1117
1118bool
84afefe6 1119Perl_is_uni_print(pTHX_ UV c)
a0ed51b3 1120{
89ebb4a3 1121 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1122 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1123 return is_utf8_print(tmpbuf);
1124}
1125
b8c5462f 1126bool
84afefe6 1127Perl_is_uni_punct(pTHX_ UV c)
b8c5462f 1128{
89ebb4a3 1129 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1130 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1131 return is_utf8_punct(tmpbuf);
1132}
1133
4d61ec05 1134bool
84afefe6 1135Perl_is_uni_xdigit(pTHX_ UV c)
4d61ec05 1136{
89ebb4a3 1137 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
230880c1 1138 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
1139 return is_utf8_xdigit(tmpbuf);
1140}
1141
84afefe6
JH
1142UV
1143Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1144{
7918f24d
NC
1145 PERL_ARGS_ASSERT_TO_UNI_UPPER;
1146
0ebc6274
JH
1147 uvchr_to_utf8(p, c);
1148 return to_utf8_upper(p, p, lenp);
a0ed51b3
LW
1149}
1150
84afefe6
JH
1151UV
1152Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1153{
7918f24d
NC
1154 PERL_ARGS_ASSERT_TO_UNI_TITLE;
1155
0ebc6274
JH
1156 uvchr_to_utf8(p, c);
1157 return to_utf8_title(p, p, lenp);
a0ed51b3
LW
1158}
1159
84afefe6
JH
1160UV
1161Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1162{
7918f24d
NC
1163 PERL_ARGS_ASSERT_TO_UNI_LOWER;
1164
0ebc6274
JH
1165 uvchr_to_utf8(p, c);
1166 return to_utf8_lower(p, p, lenp);
a0ed51b3
LW
1167}
1168
84afefe6
JH
1169UV
1170Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1171{
7918f24d
NC
1172 PERL_ARGS_ASSERT_TO_UNI_FOLD;
1173
0ebc6274
JH
1174 uvchr_to_utf8(p, c);
1175 return to_utf8_fold(p, p, lenp);
84afefe6
JH
1176}
1177
a0ed51b3
LW
1178/* for now these all assume no locale info available for Unicode > 255 */
1179
1180bool
84afefe6 1181Perl_is_uni_alnum_lc(pTHX_ UV c)
a0ed51b3
LW
1182{
1183 return is_uni_alnum(c); /* XXX no locale support yet */
1184}
1185
1186bool
84afefe6 1187Perl_is_uni_idfirst_lc(pTHX_ UV c)
a0ed51b3
LW
1188{
1189 return is_uni_idfirst(c); /* XXX no locale support yet */
1190}
1191
1192bool
84afefe6 1193Perl_is_uni_alpha_lc(pTHX_ UV c)
a0ed51b3
LW
1194{
1195 return is_uni_alpha(c); /* XXX no locale support yet */
1196}
1197
1198bool
84afefe6 1199Perl_is_uni_ascii_lc(pTHX_ UV c)
4d61ec05
GS
1200{
1201 return is_uni_ascii(c); /* XXX no locale support yet */
1202}
1203
1204bool
84afefe6 1205Perl_is_uni_space_lc(pTHX_ UV c)
a0ed51b3
LW
1206{
1207 return is_uni_space(c); /* XXX no locale support yet */
1208}
1209
1210bool
84afefe6 1211Perl_is_uni_digit_lc(pTHX_ UV c)
a0ed51b3
LW
1212{
1213 return is_uni_digit(c); /* XXX no locale support yet */
1214}
1215
1216bool
84afefe6 1217Perl_is_uni_upper_lc(pTHX_ UV c)
a0ed51b3
LW
1218{
1219 return is_uni_upper(c); /* XXX no locale support yet */
1220}
1221
1222bool
84afefe6 1223Perl_is_uni_lower_lc(pTHX_ UV c)
a0ed51b3
LW
1224{
1225 return is_uni_lower(c); /* XXX no locale support yet */
1226}
1227
1228bool
84afefe6 1229Perl_is_uni_cntrl_lc(pTHX_ UV c)
b8c5462f
JH
1230{
1231 return is_uni_cntrl(c); /* XXX no locale support yet */
1232}
1233
1234bool
84afefe6 1235Perl_is_uni_graph_lc(pTHX_ UV c)
b8c5462f
JH
1236{
1237 return is_uni_graph(c); /* XXX no locale support yet */
1238}
1239
1240bool
84afefe6 1241Perl_is_uni_print_lc(pTHX_ UV c)
a0ed51b3
LW
1242{
1243 return is_uni_print(c); /* XXX no locale support yet */
1244}
1245
b8c5462f 1246bool
84afefe6 1247Perl_is_uni_punct_lc(pTHX_ UV c)
b8c5462f
JH
1248{
1249 return is_uni_punct(c); /* XXX no locale support yet */
1250}
1251
4d61ec05 1252bool
84afefe6 1253Perl_is_uni_xdigit_lc(pTHX_ UV c)
4d61ec05
GS
1254{
1255 return is_uni_xdigit(c); /* XXX no locale support yet */
1256}
1257
b7ac61fa
JH
1258U32
1259Perl_to_uni_upper_lc(pTHX_ U32 c)
1260{
ee099d14
JH
1261 /* XXX returns only the first character -- do not use XXX */
1262 /* XXX no locale support yet */
1263 STRLEN len;
89ebb4a3 1264 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1265 return (U32)to_uni_upper(c, tmpbuf, &len);
b7ac61fa
JH
1266}
1267
1268U32
1269Perl_to_uni_title_lc(pTHX_ U32 c)
1270{
ee099d14
JH
1271 /* XXX returns only the first character XXX -- do not use XXX */
1272 /* XXX no locale support yet */
1273 STRLEN len;
89ebb4a3 1274 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1275 return (U32)to_uni_title(c, tmpbuf, &len);
b7ac61fa
JH
1276}
1277
1278U32
1279Perl_to_uni_lower_lc(pTHX_ U32 c)
1280{
ee099d14
JH
1281 /* XXX returns only the first character -- do not use XXX */
1282 /* XXX no locale support yet */
1283 STRLEN len;
89ebb4a3 1284 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1285 return (U32)to_uni_lower(c, tmpbuf, &len);
b7ac61fa
JH
1286}
1287
7452cf6a 1288static bool
5141f98e 1289S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
bde6a22d
NC
1290 const char *const swashname)
1291{
97aff369 1292 dVAR;
7918f24d
NC
1293
1294 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1295
bde6a22d
NC
1296 if (!is_utf8_char(p))
1297 return FALSE;
1298 if (!*swash)
711a919c 1299 *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
bde6a22d
NC
1300 return swash_fetch(*swash, p, TRUE) != 0;
1301}
1302
1303bool
7fc63493 1304Perl_is_utf8_alnum(pTHX_ const U8 *p)
a0ed51b3 1305{
97aff369 1306 dVAR;
7918f24d
NC
1307
1308 PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1309
671c33bf
NC
1310 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1311 * descendant of isalnum(3), in other words, it doesn't
1312 * contain the '_'. --jhi */
d4c19fe8 1313 return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
a0ed51b3
LW
1314}
1315
1316bool
7fc63493 1317Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
a0ed51b3 1318{
97aff369 1319 dVAR;
7918f24d
NC
1320
1321 PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1322
82686b01
JH
1323 if (*p == '_')
1324 return TRUE;
bde6a22d 1325 /* is_utf8_idstart would be more logical. */
d4c19fe8 1326 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
82686b01
JH
1327}
1328
1329bool
7fc63493 1330Perl_is_utf8_idcont(pTHX_ const U8 *p)
82686b01 1331{
97aff369 1332 dVAR;
7918f24d
NC
1333
1334 PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1335
82686b01
JH
1336 if (*p == '_')
1337 return TRUE;
d4c19fe8 1338 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
a0ed51b3
LW
1339}
1340
1341bool
7fc63493 1342Perl_is_utf8_alpha(pTHX_ const U8 *p)
a0ed51b3 1343{
97aff369 1344 dVAR;
7918f24d
NC
1345
1346 PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1347
d4c19fe8 1348 return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
a0ed51b3
LW
1349}
1350
1351bool
7fc63493 1352Perl_is_utf8_ascii(pTHX_ const U8 *p)
b8c5462f 1353{
97aff369 1354 dVAR;
7918f24d
NC
1355
1356 PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1357
d4c19fe8 1358 return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
b8c5462f
JH
1359}
1360
1361bool
7fc63493 1362Perl_is_utf8_space(pTHX_ const U8 *p)
a0ed51b3 1363{
97aff369 1364 dVAR;
7918f24d
NC
1365
1366 PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1367
d4c19fe8 1368 return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
a0ed51b3
LW
1369}
1370
1371bool
7fc63493 1372Perl_is_utf8_digit(pTHX_ const U8 *p)
a0ed51b3 1373{
97aff369 1374 dVAR;
7918f24d
NC
1375
1376 PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1377
d4c19fe8 1378 return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
a0ed51b3
LW
1379}
1380
1381bool
7fc63493 1382Perl_is_utf8_upper(pTHX_ const U8 *p)
a0ed51b3 1383{
97aff369 1384 dVAR;
7918f24d
NC
1385
1386 PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1387
d4c19fe8 1388 return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
a0ed51b3
LW
1389}
1390
1391bool
7fc63493 1392Perl_is_utf8_lower(pTHX_ const U8 *p)
a0ed51b3 1393{
97aff369 1394 dVAR;
7918f24d
NC
1395
1396 PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1397
d4c19fe8 1398 return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
a0ed51b3
LW
1399}
1400
1401bool
7fc63493 1402Perl_is_utf8_cntrl(pTHX_ const U8 *p)
b8c5462f 1403{
97aff369 1404 dVAR;
7918f24d
NC
1405
1406 PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1407
d4c19fe8 1408 return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
b8c5462f
JH
1409}
1410
1411bool
7fc63493 1412Perl_is_utf8_graph(pTHX_ const U8 *p)
b8c5462f 1413{
97aff369 1414 dVAR;
7918f24d
NC
1415
1416 PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1417
d4c19fe8 1418 return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
b8c5462f
JH
1419}
1420
1421bool
7fc63493 1422Perl_is_utf8_print(pTHX_ const U8 *p)
a0ed51b3 1423{
97aff369 1424 dVAR;
7918f24d
NC
1425
1426 PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1427
d4c19fe8 1428 return is_utf8_common(p, &PL_utf8_print, "IsPrint");
a0ed51b3
LW
1429}
1430
1431bool
7fc63493 1432Perl_is_utf8_punct(pTHX_ const U8 *p)
b8c5462f 1433{
97aff369 1434 dVAR;
7918f24d
NC
1435
1436 PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1437
d4c19fe8 1438 return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
b8c5462f
JH
1439}
1440
1441bool
7fc63493 1442Perl_is_utf8_xdigit(pTHX_ const U8 *p)
b8c5462f 1443{
97aff369 1444 dVAR;
7918f24d
NC
1445
1446 PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1447
d4c19fe8 1448 return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
b8c5462f
JH
1449}
1450
1451bool
7fc63493 1452Perl_is_utf8_mark(pTHX_ const U8 *p)
a0ed51b3 1453{
97aff369 1454 dVAR;
7918f24d
NC
1455
1456 PERL_ARGS_ASSERT_IS_UTF8_MARK;
1457
d4c19fe8 1458 return is_utf8_common(p, &PL_utf8_mark, "IsM");
a0ed51b3
LW
1459}
1460
6b5c0936 1461/*
87cea99e 1462=for apidoc to_utf8_case
6b5c0936
JH
1463
1464The "p" contains the pointer to the UTF-8 string encoding
1465the character that is being converted.
1466
1467The "ustrp" is a pointer to the character buffer to put the
1468conversion result to. The "lenp" is a pointer to the length
1469of the result.
1470
0134edef 1471The "swashp" is a pointer to the swash to use.
6b5c0936 1472
0134edef 1473Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
8fe4d5b2 1474and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
0134edef 1475but not always, a multicharacter mapping), is tried first.
6b5c0936 1476
0134edef
JH
1477The "special" is a string like "utf8::ToSpecLower", which means the
1478hash %utf8::ToSpecLower. The access to the hash is through
1479Perl_to_utf8_case().
6b5c0936 1480
0134edef
JH
1481The "normal" is a string like "ToLower" which means the swash
1482%utf8::ToLower.
1483
1484=cut */
6b5c0936 1485
2104c8d9 1486UV
9a957fbc
AL
1487Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1488 SV **swashp, const char *normal, const char *special)
a0ed51b3 1489{
97aff369 1490 dVAR;
89ebb4a3 1491 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
0134edef 1492 STRLEN len = 0;
aec46f14 1493 const UV uv0 = utf8_to_uvchr(p, NULL);
1feea2c7
JH
1494 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1495 * are necessary in EBCDIC, they are redundant no-ops
1496 * in ASCII-ish platforms, and hopefully optimized away. */
f54cb97a 1497 const UV uv1 = NATIVE_TO_UNI(uv0);
7918f24d
NC
1498
1499 PERL_ARGS_ASSERT_TO_UTF8_CASE;
1500
1feea2c7 1501 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
1502
1503 if (!*swashp) /* load on-demand */
1504 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1505
b08cf34e
JH
1506 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1507 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
0134edef 1508 /* It might be "special" (sometimes, but not always,
2a37f04d 1509 * a multicharacter mapping) */
6673a63c 1510 HV * const hv = get_hv(special, 0);
b08cf34e
JH
1511 SV **svp;
1512
35da51f7 1513 if (hv &&
b08cf34e
JH
1514 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1515 (*svp)) {
cfd0369c 1516 const char *s;
47654450 1517
cfd0369c 1518 s = SvPV_const(*svp, len);
47654450
JH
1519 if (len == 1)
1520 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 1521 else {
2f9475ad
JH
1522#ifdef EBCDIC
1523 /* If we have EBCDIC we need to remap the characters
1524 * since any characters in the low 256 are Unicode
1525 * code points, not EBCDIC. */
7cda7a3d 1526 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
1527
1528 d = tmpbuf;
b08cf34e 1529 if (SvUTF8(*svp)) {
2f9475ad
JH
1530 STRLEN tlen = 0;
1531
1532 while (t < tend) {
d4c19fe8 1533 const UV c = utf8_to_uvchr(t, &tlen);
2f9475ad
JH
1534 if (tlen > 0) {
1535 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1536 t += tlen;
1537 }
1538 else
1539 break;
1540 }
1541 }
1542 else {
36fec512
JH
1543 while (t < tend) {
1544 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1545 t++;
1546 }
2f9475ad
JH
1547 }
1548 len = d - tmpbuf;
1549 Copy(tmpbuf, ustrp, len, U8);
1550#else
d2dcd0fb 1551 Copy(s, ustrp, len, U8);
2f9475ad 1552#endif
29e98929 1553 }
983ffd37 1554 }
0134edef
JH
1555 }
1556
1557 if (!len && *swashp) {
d4c19fe8
AL
1558 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1559
0134edef
JH
1560 if (uv2) {
1561 /* It was "normal" (a single character mapping). */
d4c19fe8 1562 const UV uv3 = UNI_TO_NATIVE(uv2);
e9101d72 1563 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2a37f04d
JH
1564 }
1565 }
1feea2c7 1566
0134edef
JH
1567 if (!len) /* Neither: just copy. */
1568 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1569
2a37f04d
JH
1570 if (lenp)
1571 *lenp = len;
1572
0134edef 1573 return len ? utf8_to_uvchr(ustrp, 0) : 0;
a0ed51b3
LW
1574}
1575
d3e79532 1576/*
87cea99e 1577=for apidoc to_utf8_upper
d3e79532
JH
1578
1579Convert the UTF-8 encoded character at p to its uppercase version and
1580store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1581that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1582the uppercase version may be longer than the original character.
d3e79532
JH
1583
1584The first character of the uppercased version is returned
1585(but note, as explained above, that there may be more.)
1586
1587=cut */
1588
2104c8d9 1589UV
7fc63493 1590Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1591{
97aff369 1592 dVAR;
7918f24d
NC
1593
1594 PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1595
983ffd37 1596 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1597 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
983ffd37 1598}
a0ed51b3 1599
d3e79532 1600/*
87cea99e 1601=for apidoc to_utf8_title
d3e79532
JH
1602
1603Convert the UTF-8 encoded character at p to its titlecase version and
1604store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1605that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1606titlecase version may be longer than the original character.
d3e79532
JH
1607
1608The first character of the titlecased version is returned
1609(but note, as explained above, that there may be more.)
1610
1611=cut */
1612
983ffd37 1613UV
7fc63493 1614Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
983ffd37 1615{
97aff369 1616 dVAR;
7918f24d
NC
1617
1618 PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1619
983ffd37 1620 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1621 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
a0ed51b3
LW
1622}
1623
d3e79532 1624/*
87cea99e 1625=for apidoc to_utf8_lower
d3e79532
JH
1626
1627Convert the UTF-8 encoded character at p to its lowercase version and
1628store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1629that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1630lowercase version may be longer than the original character.
d3e79532
JH
1631
1632The first character of the lowercased version is returned
1633(but note, as explained above, that there may be more.)
1634
1635=cut */
1636
2104c8d9 1637UV
7fc63493 1638Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1639{
97aff369 1640 dVAR;
7918f24d
NC
1641
1642 PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1643
983ffd37 1644 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9
JH
1645 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1646}
1647
d3e79532 1648/*
87cea99e 1649=for apidoc to_utf8_fold
d3e79532
JH
1650
1651Convert the UTF-8 encoded character at p to its foldcase version and
1652store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3 1653that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
d3e79532
JH
1654foldcase version may be longer than the original character (up to
1655three characters).
1656
1657The first character of the foldcased version is returned
1658(but note, as explained above, that there may be more.)
1659
1660=cut */
1661
b4e400f9 1662UV
7fc63493 1663Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
b4e400f9 1664{
97aff369 1665 dVAR;
7918f24d
NC
1666
1667 PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1668
b4e400f9
JH
1669 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1670 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
a0ed51b3
LW
1671}
1672
711a919c
ST
1673/* Note:
1674 * A "swash" is a swatch hash.
1675 * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1676 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1677 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1678 */
a0ed51b3 1679SV*
7fc63493 1680Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3 1681{
27da23d5 1682 dVAR;
a0ed51b3 1683 SV* retval;
8e84507e 1684 dSP;
7fc63493
AL
1685 const size_t pkg_len = strlen(pkg);
1686 const size_t name_len = strlen(name);
da51bb9b 1687 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
f8be5cf0 1688 SV* errsv_save;
ce3b816e 1689
7918f24d
NC
1690 PERL_ARGS_ASSERT_SWASH_INIT;
1691
96ca9f55
DM
1692 PUSHSTACKi(PERLSI_MAGIC);
1693 ENTER;
1694 SAVEI32(PL_hints);
1695 PL_hints = 0;
1696 save_re_context();
1b026014 1697 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ce3b816e 1698 ENTER;
f8be5cf0 1699 errsv_save = newSVsv(ERRSV);
dc0c6abb
NC
1700 /* It is assumed that callers of this routine are not passing in any
1701 user derived data. */
1702 /* Need to do this after save_re_context() as it will set PL_tainted to
1703 1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1704 Even line to create errsv_save can turn on PL_tainted. */
1705 SAVEBOOL(PL_tainted);
1706 PL_tainted = 0;
71bed85a 1707 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
a0714e2c 1708 NULL);
f8be5cf0
JH
1709 if (!SvTRUE(ERRSV))
1710 sv_setsv(ERRSV, errsv_save);
1711 SvREFCNT_dec(errsv_save);
ce3b816e
GS
1712 LEAVE;
1713 }
1714 SPAGAIN;
a0ed51b3
LW
1715 PUSHMARK(SP);
1716 EXTEND(SP,5);
6e449a3a
MHM
1717 mPUSHp(pkg, pkg_len);
1718 mPUSHp(name, name_len);
a0ed51b3 1719 PUSHs(listsv);
6e449a3a
MHM
1720 mPUSHi(minbits);
1721 mPUSHi(none);
a0ed51b3 1722 PUTBACK;
f8be5cf0 1723 errsv_save = newSVsv(ERRSV);
864dbfa3 1724 if (call_method("SWASHNEW", G_SCALAR))
8e84507e 1725 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1726 else
e24b16f9 1727 retval = &PL_sv_undef;
f8be5cf0
JH
1728 if (!SvTRUE(ERRSV))
1729 sv_setsv(ERRSV, errsv_save);
1730 SvREFCNT_dec(errsv_save);
a0ed51b3
LW
1731 LEAVE;
1732 POPSTACK;
923e4eb5 1733 if (IN_PERL_COMPILETIME) {
623e6609 1734 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 1735 }
bc45ce41
JH
1736 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1737 if (SvPOK(retval))
35c1215d 1738 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
be2597df 1739 SVfARG(retval));
cea2e8a9 1740 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
bc45ce41 1741 }
a0ed51b3
LW
1742 return retval;
1743}
1744
035d37be
JH
1745
1746/* This API is wrong for special case conversions since we may need to
1747 * return several Unicode characters for a single Unicode character
1748 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1749 * the lower-level routine, and it is similarly broken for returning
1750 * multiple values. --jhi */
979f2922 1751/* Now SWASHGET is recasted into S_swash_get in this file. */
680c470c
ST
1752
1753/* Note:
1754 * Returns the value of property/mapping C<swash> for the first character
1755 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1756 * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1757 * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1758 */
a0ed51b3 1759UV
680c470c 1760Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
a0ed51b3 1761{
27da23d5 1762 dVAR;
ef8f7699 1763 HV *const hv = MUTABLE_HV(SvRV(swash));
3568d838
JH
1764 U32 klen;
1765 U32 off;
a0ed51b3 1766 STRLEN slen;
7d85a32c 1767 STRLEN needents;
cfd0369c 1768 const U8 *tmps = NULL;
a0ed51b3 1769 U32 bit;
979f2922 1770 SV *swatch;
3568d838 1771 U8 tmputf8[2];
35da51f7 1772 const UV c = NATIVE_TO_ASCII(*ptr);
3568d838 1773
7918f24d
NC
1774 PERL_ARGS_ASSERT_SWASH_FETCH;
1775
3568d838 1776 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
979f2922
ST
1777 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1778 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1779 ptr = tmputf8;
3568d838
JH
1780 }
1781 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1782 * then the "swatch" is a vec() for al the chars which start
1783 * with 0xAA..0xYY
1784 * So the key in the hash (klen) is length of encoded char -1
1785 */
1786 klen = UTF8SKIP(ptr) - 1;
1787 off = ptr[klen];
a0ed51b3 1788
979f2922 1789 if (klen == 0) {
7d85a32c 1790 /* If char in invariant then swatch is for all the invariant chars
1e54db1a 1791 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
7d85a32c 1792 */
979f2922
ST
1793 needents = UTF_CONTINUATION_MARK;
1794 off = NATIVE_TO_UTF(ptr[klen]);
1795 }
1796 else {
7d85a32c 1797 /* If char is encoded then swatch is for the prefix */
979f2922
ST
1798 needents = (1 << UTF_ACCUMULATION_SHIFT);
1799 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1800 }
7d85a32c 1801
a0ed51b3
LW
1802 /*
1803 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1804 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1805 * it's nothing to sniff at.) Pity we usually come through at least
1806 * two function calls to get here...
1807 *
1808 * NB: this code assumes that swatches are never modified, once generated!
1809 */
1810
3568d838 1811 if (hv == PL_last_swash_hv &&
a0ed51b3 1812 klen == PL_last_swash_klen &&
27da23d5 1813 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
1814 {
1815 tmps = PL_last_swash_tmps;
1816 slen = PL_last_swash_slen;
1817 }
1818 else {
1819 /* Try our second-level swatch cache, kept in a hash. */
e1ec3a88 1820 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
a0ed51b3 1821
979f2922
ST
1822 /* If not cached, generate it via swash_get */
1823 if (!svp || !SvPOK(*svp)
1824 || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2b9d42f0
NIS
1825 /* We use utf8n_to_uvuni() as we want an index into
1826 Unicode tables, not a native character number.
1827 */
aec46f14 1828 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
872c91ae
JH
1829 ckWARN(WARN_UTF8) ?
1830 0 : UTF8_ALLOW_ANY);
680c470c 1831 swatch = swash_get(swash,
979f2922
ST
1832 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1833 (klen) ? (code_point & ~(needents - 1)) : 0,
1834 needents);
1835
923e4eb5 1836 if (IN_PERL_COMPILETIME)
623e6609 1837 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 1838
979f2922 1839 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
a0ed51b3 1840
979f2922
ST
1841 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1842 || (slen << 3) < needents)
660a4616 1843 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
a0ed51b3
LW
1844 }
1845
1846 PL_last_swash_hv = hv;
16d8f38a 1847 assert(klen <= sizeof(PL_last_swash_key));
eac04b2e 1848 PL_last_swash_klen = (U8)klen;
cfd0369c
NC
1849 /* FIXME change interpvar.h? */
1850 PL_last_swash_tmps = (U8 *) tmps;
a0ed51b3
LW
1851 PL_last_swash_slen = slen;
1852 if (klen)
1853 Copy(ptr, PL_last_swash_key, klen, U8);
1854 }
1855
9faf8d75 1856 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
1857 case 1:
1858 bit = 1 << (off & 7);
1859 off >>= 3;
1860 return (tmps[off] & bit) != 0;
1861 case 8:
1862 return tmps[off];
1863 case 16:
1864 off <<= 1;
1865 return (tmps[off] << 8) + tmps[off + 1] ;
1866 case 32:
1867 off <<= 2;
1868 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1869 }
660a4616 1870 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
670f1322 1871 NORETURN_FUNCTION_END;
a0ed51b3 1872}
2b9d42f0 1873
979f2922
ST
1874/* Note:
1875 * Returns a swatch (a bit vector string) for a code point sequence
1876 * that starts from the value C<start> and comprises the number C<span>.
1877 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1878 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1879 */
1880STATIC SV*
1881S_swash_get(pTHX_ SV* swash, UV start, UV span)
1882{
1883 SV *swatch;
711a919c 1884 U8 *l, *lend, *x, *xend, *s;
979f2922 1885 STRLEN lcur, xcur, scur;
ef8f7699 1886 HV *const hv = MUTABLE_HV(SvRV(swash));
017a3ce5
GA
1887 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1888 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1889 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1890 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1891 SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
0bd48802
AL
1892 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1893 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
1894 const STRLEN bits = SvUV(*bitssvp);
1895 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1896 const UV none = SvUV(*nonesvp);
1897 const UV end = start + span;
979f2922 1898
7918f24d
NC
1899 PERL_ARGS_ASSERT_SWASH_GET;
1900
979f2922 1901 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
660a4616
ST
1902 Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1903 (UV)bits);
979f2922
ST
1904 }
1905
1906 /* create and initialize $swatch */
979f2922 1907 scur = octets ? (span * octets) : (span + 7) / 8;
e524fe40
NC
1908 swatch = newSV(scur);
1909 SvPOK_on(swatch);
979f2922
ST
1910 s = (U8*)SvPVX(swatch);
1911 if (octets && none) {
0bd48802 1912 const U8* const e = s + scur;
979f2922
ST
1913 while (s < e) {
1914 if (bits == 8)
1915 *s++ = (U8)(none & 0xff);
1916 else if (bits == 16) {
1917 *s++ = (U8)((none >> 8) & 0xff);
1918 *s++ = (U8)( none & 0xff);
1919 }
1920 else if (bits == 32) {
1921 *s++ = (U8)((none >> 24) & 0xff);
1922 *s++ = (U8)((none >> 16) & 0xff);
1923 *s++ = (U8)((none >> 8) & 0xff);
1924 *s++ = (U8)( none & 0xff);
1925 }
1926 }
1927 *s = '\0';
1928 }
1929 else {
1930 (void)memzero((U8*)s, scur + 1);
1931 }
1932 SvCUR_set(swatch, scur);
1933 s = (U8*)SvPVX(swatch);
1934
1935 /* read $swash->{LIST} */
1936 l = (U8*)SvPV(*listsvp, lcur);
1937 lend = l + lcur;
1938 while (l < lend) {
35da51f7 1939 UV min, max, val;
979f2922
ST
1940 STRLEN numlen;
1941 I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1942
0bd48802 1943 U8* const nl = (U8*)memchr(l, '\n', lend - l);
979f2922
ST
1944
1945 numlen = lend - l;
1946 min = grok_hex((char *)l, &numlen, &flags, NULL);
1947 if (numlen)
1948 l += numlen;
1949 else if (nl) {
1950 l = nl + 1; /* 1 is length of "\n" */
1951 continue;
1952 }
1953 else {
1954 l = lend; /* to LIST's end at which \n is not found */
1955 break;
1956 }
1957
1958 if (isBLANK(*l)) {
1959 ++l;
1960 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1961 numlen = lend - l;
1962 max = grok_hex((char *)l, &numlen, &flags, NULL);
1963 if (numlen)
1964 l += numlen;
1965 else
1966 max = min;
1967
1968 if (octets) {
1969 if (isBLANK(*l)) {
1970 ++l;
1971 flags = PERL_SCAN_SILENT_ILLDIGIT |
1972 PERL_SCAN_DISALLOW_PREFIX;
1973 numlen = lend - l;
1974 val = grok_hex((char *)l, &numlen, &flags, NULL);
1975 if (numlen)
1976 l += numlen;
1977 else
1978 val = 0;
1979 }
1980 else {
1981 val = 0;
1982 if (typeto) {
1983 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1984 typestr, l);
1985 }
1986 }
1987 }
711a919c
ST
1988 else
1989 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
1990 }
1991 else {
1992 max = min;
1993 if (octets) {
1994 val = 0;
1995 if (typeto) {
1996 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1997 }
1998 }
711a919c
ST
1999 else
2000 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
2001 }
2002
2003 if (nl)
2004 l = nl + 1;
2005 else
2006 l = lend;
2007
2008 if (max < start)
2009 continue;
2010
2011 if (octets) {
35da51f7 2012 UV key;
979f2922
ST
2013 if (min < start) {
2014 if (!none || val < none) {
2015 val += start - min;
2016 }
2017 min = start;
2018 }
2019 for (key = min; key <= max; key++) {
2020 STRLEN offset;
2021 if (key >= end)
2022 goto go_out_list;
2023 /* offset must be non-negative (start <= min <= key < end) */
2024 offset = octets * (key - start);
2025 if (bits == 8)
2026 s[offset] = (U8)(val & 0xff);
2027 else if (bits == 16) {
2028 s[offset ] = (U8)((val >> 8) & 0xff);
2029 s[offset + 1] = (U8)( val & 0xff);
2030 }
2031 else if (bits == 32) {
2032 s[offset ] = (U8)((val >> 24) & 0xff);
2033 s[offset + 1] = (U8)((val >> 16) & 0xff);
2034 s[offset + 2] = (U8)((val >> 8) & 0xff);
2035 s[offset + 3] = (U8)( val & 0xff);
2036 }
2037
2038 if (!none || val < none)
2039 ++val;
2040 }
2041 }
711a919c 2042 else { /* bits == 1, then val should be ignored */
35da51f7 2043 UV key;
979f2922
ST
2044 if (min < start)
2045 min = start;
2046 for (key = min; key <= max; key++) {
0bd48802 2047 const STRLEN offset = (STRLEN)(key - start);
979f2922
ST
2048 if (key >= end)
2049 goto go_out_list;
2050 s[offset >> 3] |= 1 << (offset & 7);
2051 }
2052 }
2053 } /* while */
2054 go_out_list:
2055
2056 /* read $swash->{EXTRAS} */
2057 x = (U8*)SvPV(*extssvp, xcur);
2058 xend = x + xcur;
2059 while (x < xend) {
2060 STRLEN namelen;
2061 U8 *namestr;
2062 SV** othersvp;
2063 HV* otherhv;
2064 STRLEN otherbits;
2065 SV **otherbitssvp, *other;
711a919c 2066 U8 *s, *o, *nl;
979f2922
ST
2067 STRLEN slen, olen;
2068
35da51f7 2069 const U8 opc = *x++;
979f2922
ST
2070 if (opc == '\n')
2071 continue;
2072
2073 nl = (U8*)memchr(x, '\n', xend - x);
2074
2075 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2076 if (nl) {
2077 x = nl + 1; /* 1 is length of "\n" */
2078 continue;
2079 }
2080 else {
2081 x = xend; /* to EXTRAS' end at which \n is not found */
2082 break;
2083 }
2084 }
2085
2086 namestr = x;
2087 if (nl) {
2088 namelen = nl - namestr;
2089 x = nl + 1;
2090 }
2091 else {
2092 namelen = xend - namestr;
2093 x = xend;
2094 }
2095
2096 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
ef8f7699 2097 otherhv = MUTABLE_HV(SvRV(*othersvp));
017a3ce5 2098 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
979f2922
ST
2099 otherbits = (STRLEN)SvUV(*otherbitssvp);
2100 if (bits < otherbits)
660a4616 2101 Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
979f2922
ST
2102
2103 /* The "other" swatch must be destroyed after. */
2104 other = swash_get(*othersvp, start, span);
2105 o = (U8*)SvPV(other, olen);
2106
2107 if (!olen)
660a4616 2108 Perl_croak(aTHX_ "panic: swash_get got improper swatch");
979f2922
ST
2109
2110 s = (U8*)SvPV(swatch, slen);
2111 if (bits == 1 && otherbits == 1) {
2112 if (slen != olen)
660a4616 2113 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
979f2922
ST
2114
2115 switch (opc) {
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 case '&':
2129 while (slen--)
2130 *s++ &= *o++;
2131 break;
2132 default:
2133 break;
2134 }
2135 }
711a919c 2136 else {
979f2922
ST
2137 STRLEN otheroctets = otherbits >> 3;
2138 STRLEN offset = 0;
35da51f7 2139 U8* const send = s + slen;
979f2922
ST
2140
2141 while (s < send) {
2142 UV otherval = 0;
2143
2144 if (otherbits == 1) {
2145 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2146 ++offset;
2147 }
2148 else {
2149 STRLEN vlen = otheroctets;
2150 otherval = *o++;
2151 while (--vlen) {
2152 otherval <<= 8;
2153 otherval |= *o++;
2154 }
2155 }
2156
711a919c 2157 if (opc == '+' && otherval)
6f207bd3 2158 NOOP; /* replace with otherval */
979f2922
ST
2159 else if (opc == '!' && !otherval)
2160 otherval = 1;
2161 else if (opc == '-' && otherval)
2162 otherval = 0;
2163 else if (opc == '&' && !otherval)
2164 otherval = 0;
2165 else {
711a919c 2166 s += octets; /* no replacement */
979f2922
ST
2167 continue;
2168 }
2169
2170 if (bits == 8)
2171 *s++ = (U8)( otherval & 0xff);
2172 else if (bits == 16) {
2173 *s++ = (U8)((otherval >> 8) & 0xff);
2174 *s++ = (U8)( otherval & 0xff);
2175 }
2176 else if (bits == 32) {
2177 *s++ = (U8)((otherval >> 24) & 0xff);
2178 *s++ = (U8)((otherval >> 16) & 0xff);
2179 *s++ = (U8)((otherval >> 8) & 0xff);
2180 *s++ = (U8)( otherval & 0xff);
2181 }
2182 }
2183 }
2184 sv_free(other); /* through with it! */
2185 } /* while */
2186 return swatch;
2187}
2188
0f830e0b 2189/*
87cea99e 2190=for apidoc uvchr_to_utf8
0f830e0b
NC
2191
2192Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2193of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2194bytes available. The return value is the pointer to the byte after the
2195end of the new character. In other words,
2196
2197 d = uvchr_to_utf8(d, uv);
2198
2199is the recommended wide native character-aware way of saying
2200
2201 *(d++) = uv;
2202
2203=cut
2204*/
2205
2206/* On ASCII machines this is normally a macro but we want a
2207 real function in case XS code wants it
2208*/
0f830e0b
NC
2209U8 *
2210Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2211{
7918f24d
NC
2212 PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2213
0f830e0b
NC
2214 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2215}
2216
b851fbc1
JH
2217U8 *
2218Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2219{
7918f24d
NC
2220 PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2221
b851fbc1
JH
2222 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2223}
2b9d42f0
NIS
2224
2225/*
87cea99e 2226=for apidoc utf8n_to_uvchr
0f830e0b
NC
2227flags
2228
2229Returns the native character value of the first character in the string
2230C<s>
2231which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2232length, in bytes, of that character.
2233
2234Allows length and flags to be passed to low level routine.
2235
2236=cut
2237*/
2238/* On ASCII machines this is normally a macro but we want
2239 a real function in case XS code wants it
2240*/
0f830e0b
NC
2241UV
2242Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2243U32 flags)
2244{
2245 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
7918f24d
NC
2246
2247 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2248
0f830e0b
NC
2249 return UNI_TO_NATIVE(uv);
2250}
2251
2252/*
87cea99e 2253=for apidoc pv_uni_display
d2cc3551
JH
2254
2255Build to the scalar dsv a displayable version of the string spv,
2256length len, the displayable version being at most pvlim bytes long
2257(if longer, the rest is truncated and "..." will be appended).
0a2ef054 2258
9e55ce06 2259The flags argument can have UNI_DISPLAY_ISPRINT set to display
00e86452 2260isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
0a2ef054
JH
2261to display the \\[nrfta\\] as the backslashed versions (like '\n')
2262(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2263UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2264UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2265
d2cc3551
JH
2266The pointer to the PV of the dsv is returned.
2267
2268=cut */
e6b2e755 2269char *
e1ec3a88 2270Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
e6b2e755
JH
2271{
2272 int truncated = 0;
e1ec3a88 2273 const char *s, *e;
e6b2e755 2274
7918f24d
NC
2275 PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2276
76f68e9b 2277 sv_setpvs(dsv, "");
7fddd944 2278 SvUTF8_off(dsv);
e1ec3a88 2279 for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
e6b2e755 2280 UV u;
a49f32c6
NC
2281 /* This serves double duty as a flag and a character to print after
2282 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2283 */
2284 char ok = 0;
c728cb41 2285
e6b2e755
JH
2286 if (pvlim && SvCUR(dsv) >= pvlim) {
2287 truncated++;
2288 break;
2289 }
2290 u = utf8_to_uvchr((U8*)s, 0);
c728cb41 2291 if (u < 256) {
a3b680e6 2292 const unsigned char c = (unsigned char)u & 0xFF;
0bd48802 2293 if (flags & UNI_DISPLAY_BACKSLASH) {
a49f32c6 2294 switch (c) {
c728cb41 2295 case '\n':
a49f32c6 2296 ok = 'n'; break;
c728cb41 2297 case '\r':
a49f32c6 2298 ok = 'r'; break;
c728cb41 2299 case '\t':
a49f32c6 2300 ok = 't'; break;
c728cb41 2301 case '\f':
a49f32c6 2302 ok = 'f'; break;
c728cb41 2303 case '\a':
a49f32c6 2304 ok = 'a'; break;
c728cb41 2305 case '\\':
a49f32c6 2306 ok = '\\'; break;
c728cb41
JH
2307 default: break;
2308 }
a49f32c6 2309 if (ok) {
88c9ea1e 2310 const char string = ok;
76f68e9b 2311 sv_catpvs(dsv, "\\");
5e7aa789 2312 sv_catpvn(dsv, &string, 1);
a49f32c6 2313 }
c728cb41 2314 }
00e86452 2315 /* isPRINT() is the locale-blind version. */
a49f32c6 2316 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
88c9ea1e 2317 const char string = c;
5e7aa789 2318 sv_catpvn(dsv, &string, 1);
a49f32c6 2319 ok = 1;
0a2ef054 2320 }
c728cb41
JH
2321 }
2322 if (!ok)
9e55ce06 2323 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
e6b2e755
JH
2324 }
2325 if (truncated)
396482e1 2326 sv_catpvs(dsv, "...");
e6b2e755
JH
2327
2328 return SvPVX(dsv);
2329}
2b9d42f0 2330
d2cc3551 2331/*
87cea99e 2332=for apidoc sv_uni_display
d2cc3551
JH
2333
2334Build to the scalar dsv a displayable version of the scalar sv,
0a2ef054 2335the displayable version being at most pvlim bytes long
d2cc3551 2336(if longer, the rest is truncated and "..." will be appended).
0a2ef054
JH
2337
2338The flags argument is as in pv_uni_display().
2339
d2cc3551
JH
2340The pointer to the PV of the dsv is returned.
2341
d4c19fe8
AL
2342=cut
2343*/
e6b2e755
JH
2344char *
2345Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2346{
7918f24d
NC
2347 PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2348
cfd0369c
NC
2349 return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2350 SvCUR(ssv), pvlim, flags);
701a277b
JH
2351}
2352
d2cc3551 2353/*
87cea99e 2354=for apidoc ibcmp_utf8
d2cc3551
JH
2355
2356Return true if the strings s1 and s2 differ case-insensitively, false
2357if not (if they are equal case-insensitively). If u1 is true, the
2358string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
d07ddd77
JH
2359the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
2360are false, the respective string is assumed to be in native 8-bit
2361encoding.
2362
2363If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2364in there (they will point at the beginning of the I<next> character).
2365If the pointers behind pe1 or pe2 are non-NULL, they are the end
2366pointers beyond which scanning will not continue under any
4cdaeff7 2367circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
d07ddd77
JH
2368s2+l2 will be used as goal end pointers that will also stop the scan,
2369and which qualify towards defining a successful match: all the scans
2370that define an explicit length must reach their goal pointers for
2371a match to succeed).
d2cc3551
JH
2372
2373For case-insensitiveness, the "casefolding" of Unicode is used
2374instead of upper/lowercasing both the characters, see
2375http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2376
2377=cut */
701a277b 2378I32
d07ddd77 2379Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
332ddc25 2380{
97aff369 2381 dVAR;
e1ec3a88
AL
2382 register const U8 *p1 = (const U8*)s1;
2383 register const U8 *p2 = (const U8*)s2;
cbbf8932 2384 register const U8 *f1 = NULL;
2f73348c 2385 register const U8 *f2 = NULL;
cbbf8932
AL
2386 register U8 *e1 = NULL;
2387 register U8 *q1 = NULL;
2388 register U8 *e2 = NULL;
2389 register U8 *q2 = NULL;
d07ddd77 2390 STRLEN n1 = 0, n2 = 0;
89ebb4a3
JH
2391 U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2392 U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
d7f013c8
JH
2393 U8 natbuf[1+1];
2394 STRLEN foldlen1, foldlen2;
d07ddd77 2395 bool match;
7918f24d
NC
2396
2397 PERL_ARGS_ASSERT_IBCMP_UTF8;
332ddc25 2398
d07ddd77
JH
2399 if (pe1)
2400 e1 = *(U8**)pe1;
a0a388a1 2401 /* assert(e1 || l1); */
e1ec3a88
AL
2402 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2403 f1 = (const U8*)s1 + l1;
d07ddd77
JH
2404 if (pe2)
2405 e2 = *(U8**)pe2;
a0a388a1 2406 /* assert(e2 || l2); */
e1ec3a88
AL
2407 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2408 f2 = (const U8*)s2 + l2;
d07ddd77 2409
a0a388a1
YO
2410 /* This shouldn't happen. However, putting an assert() there makes some
2411 * tests fail. */
2412 /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
d07ddd77
JH
2413 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2414 return 1; /* mismatch; possible infinite loop or false positive */
2415
a6872d42
JH
2416 if (!u1 || !u2)
2417 natbuf[1] = 0; /* Need to terminate the buffer. */
2418
d07ddd77
JH
2419 while ((e1 == 0 || p1 < e1) &&
2420 (f1 == 0 || p1 < f1) &&
2421 (e2 == 0 || p2 < e2) &&
2422 (f2 == 0 || p2 < f2)) {
2423 if (n1 == 0) {
d7f013c8
JH
2424 if (u1)
2425 to_utf8_fold(p1, foldbuf1, &foldlen1);
2426 else {
809e8e66 2427 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
d7f013c8
JH
2428 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2429 }
2430 q1 = foldbuf1;
d07ddd77 2431 n1 = foldlen1;
332ddc25 2432 }
d07ddd77 2433 if (n2 == 0) {
d7f013c8
JH
2434 if (u2)
2435 to_utf8_fold(p2, foldbuf2, &foldlen2);
2436 else {
809e8e66 2437 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
d7f013c8
JH
2438 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2439 }
2440 q2 = foldbuf2;
d07ddd77 2441 n2 = foldlen2;
332ddc25 2442 }
d07ddd77
JH
2443 while (n1 && n2) {
2444 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2445 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2446 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
d7f013c8 2447 return 1; /* mismatch */
d07ddd77 2448 n1 -= UTF8SKIP(q1);
d7f013c8 2449 q1 += UTF8SKIP(q1);
d07ddd77 2450 n2 -= UTF8SKIP(q2);
d7f013c8 2451 q2 += UTF8SKIP(q2);
701a277b 2452 }
d07ddd77 2453 if (n1 == 0)
d7f013c8 2454 p1 += u1 ? UTF8SKIP(p1) : 1;
d07ddd77 2455 if (n2 == 0)
d7f013c8
JH
2456 p2 += u2 ? UTF8SKIP(p2) : 1;
2457
d2cc3551 2458 }
5469e704 2459
d07ddd77
JH
2460 /* A match is defined by all the scans that specified
2461 * an explicit length reaching their final goals. */
2462 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
5469e704
JH
2463
2464 if (match) {
d07ddd77
JH
2465 if (pe1)
2466 *pe1 = (char*)p1;
2467 if (pe2)
2468 *pe2 = (char*)p2;
5469e704
JH
2469 }
2470
2471 return match ? 0 : 1; /* 0 match, 1 mismatch */
e6b2e755 2472}
701a277b 2473
a49f32c6
NC
2474/*
2475 * Local variables:
2476 * c-indentation-style: bsd
2477 * c-basic-offset: 4
2478 * indent-tabs-mode: t
2479 * End:
2480 *
37442d52
RGS
2481 * ex: set ts=8 sts=4 sw=4 noet:
2482 */