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