This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document a PerlIO/Encode warning.
[perl5.git] / utf8.c
CommitLineData
a0ed51b3
LW
1/* utf8.c
2 *
4bb101f2 3 * Copyright (C) 2000, 2001, 2002, 2003, by Larry Wall and others
a0ed51b3
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
12 * heard of that we don't want to see any closer; and that's the one place
13 * we're trying to get to! And that's just where we can't get, nohow.'
14 *
15 * 'Well do I understand your speech,' he answered in the same language;
16 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
17 * as is the custom in the West, if you wish to be answered?'
18 *
19 * ...the travellers perceived that the floor was paved with stones of many
20 * hues; branching runes and strange devices intertwined beneath their feet.
21 */
22
23#include "EXTERN.h"
864dbfa3 24#define PERL_IN_UTF8_C
a0ed51b3
LW
25#include "perl.h"
26
901b21bf
JH
27static char unees[] = "Malformed UTF-8 character (unexpected end of string)";
28
ccfc67b7
JH
29/*
30=head1 Unicode Support
a0ed51b3 31
b851fbc1 32=for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
eebe1485
SC
33
34Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
35of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
36bytes available. The return value is the pointer to the byte after the
9041c2e3 37end of the new character. In other words,
eebe1485 38
b851fbc1
JH
39 d = uvuni_to_utf8_flags(d, uv, flags);
40
41or, in most cases,
42
9041c2e3 43 d = uvuni_to_utf8(d, uv);
eebe1485 44
b851fbc1
JH
45(which is equivalent to)
46
47 d = uvuni_to_utf8_flags(d, uv, 0);
48
eebe1485
SC
49is the recommended Unicode-aware way of saying
50
51 *(d++) = uv;
52
53=cut
54*/
55
dfe13c55 56U8 *
b851fbc1 57Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
a0ed51b3 58{
62961d2e 59 if (ckWARN(WARN_UTF8)) {
b851fbc1
JH
60 if (UNICODE_IS_SURROGATE(uv) &&
61 !(flags & UNICODE_ALLOW_SURROGATE))
9014280d 62 Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
b851fbc1
JH
63 else if (
64 ((uv >= 0xFDD0 && uv <= 0xFDEF &&
65 !(flags & UNICODE_ALLOW_FDD0))
66 ||
c867b360 67 ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
b851fbc1
JH
68 !(flags & UNICODE_ALLOW_FFFF))) &&
69 /* UNICODE_ALLOW_SUPER includes
2a20b9da 70 * FFFEs and FFFFs beyond 0x10FFFF. */
b851fbc1
JH
71 ((uv <= PERL_UNICODE_MAX) ||
72 !(flags & UNICODE_ALLOW_SUPER))
73 )
9014280d 74 Perl_warner(aTHX_ packWARN(WARN_UTF8),
507b9800
JH
75 "Unicode character 0x%04"UVxf" is illegal", uv);
76 }
c4d5f83a 77 if (UNI_IS_INVARIANT(uv)) {
eb160463 78 *d++ = (U8)UTF_TO_NATIVE(uv);
a0ed51b3
LW
79 return d;
80 }
2d331972 81#if defined(EBCDIC)
1d72bdf6
NIS
82 else {
83 STRLEN len = UNISKIP(uv);
84 U8 *p = d+len-1;
85 while (p > d) {
eb160463 86 *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1d72bdf6
NIS
87 uv >>= UTF_ACCUMULATION_SHIFT;
88 }
eb160463 89 *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1d72bdf6
NIS
90 return d+len;
91 }
92#else /* Non loop style */
a0ed51b3 93 if (uv < 0x800) {
eb160463
GS
94 *d++ = (U8)(( uv >> 6) | 0xc0);
95 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
96 return d;
97 }
98 if (uv < 0x10000) {
eb160463
GS
99 *d++ = (U8)(( uv >> 12) | 0xe0);
100 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
101 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
102 return d;
103 }
104 if (uv < 0x200000) {
eb160463
GS
105 *d++ = (U8)(( uv >> 18) | 0xf0);
106 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
107 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
108 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
109 return d;
110 }
111 if (uv < 0x4000000) {
eb160463
GS
112 *d++ = (U8)(( uv >> 24) | 0xf8);
113 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
114 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
115 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
116 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
117 return d;
118 }
119 if (uv < 0x80000000) {
eb160463
GS
120 *d++ = (U8)(( uv >> 30) | 0xfc);
121 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
122 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
123 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
124 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
125 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
126 return d;
127 }
6b8eaf93 128#ifdef HAS_QUAD
d7578b48 129 if (uv < UTF8_QUAD_MAX)
a0ed51b3
LW
130#endif
131 {
eb160463
GS
132 *d++ = 0xfe; /* Can't match U+FEFF! */
133 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
134 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
135 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
136 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
137 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
138 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
139 return d;
140 }
6b8eaf93 141#ifdef HAS_QUAD
a0ed51b3 142 {
eb160463
GS
143 *d++ = 0xff; /* Can't match U+FFFE! */
144 *d++ = 0x80; /* 6 Reserved bits */
145 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
146 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
147 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
148 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
149 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
150 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
151 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
152 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
153 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
154 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
155 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
156 return d;
157 }
158#endif
1d72bdf6 159#endif /* Loop style */
a0ed51b3 160}
b851fbc1
JH
161
162U8 *
163Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
164{
165 return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
166}
9041c2e3
NIS
167
168
169/*
eebe1485
SC
170=for apidoc A|STRLEN|is_utf8_char|U8 *s
171
5da9da9e 172Tests if some arbitrary number of bytes begins in a valid UTF-8
82686b01
JH
173character. Note that an INVARIANT (i.e. ASCII) character is a valid
174UTF-8 character. The actual number of bytes in the UTF-8 character
175will be returned if it is valid, otherwise 0.
9041c2e3 176
82686b01 177=cut */
067a85ef 178STRLEN
386d01d6
GS
179Perl_is_utf8_char(pTHX_ U8 *s)
180{
181 U8 u = *s;
067a85ef
A
182 STRLEN slen, len;
183 UV uv, ouv;
386d01d6 184
1d72bdf6 185 if (UTF8_IS_INVARIANT(u))
386d01d6
GS
186 return 1;
187
60006e79 188 if (!UTF8_IS_START(u))
386d01d6
GS
189 return 0;
190
9f07fdcd 191 len = UTF8SKIP(s);
386d01d6 192
60006e79 193 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
067a85ef
A
194 return 0;
195
386d01d6
GS
196 slen = len - 1;
197 s++;
6eb6869e 198 u &= UTF_START_MASK(len);
1d72bdf6 199 uv = u;
067a85ef 200 ouv = uv;
386d01d6 201 while (slen--) {
60006e79 202 if (!UTF8_IS_CONTINUATION(*s))
386d01d6 203 return 0;
8850bf83 204 uv = UTF8_ACCUMULATE(uv, *s);
209a9bc1 205 if (uv < ouv)
067a85ef
A
206 return 0;
207 ouv = uv;
386d01d6
GS
208 s++;
209 }
067a85ef 210
eb160463 211 if ((STRLEN)UNISKIP(uv) < len)
067a85ef
A
212 return 0;
213
386d01d6
GS
214 return len;
215}
216
6662521e 217/*
eebe1485 218=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
6662521e 219
c9ada85f
JH
220Returns true if first C<len> bytes of the given string form a valid
221UTF8 string, false otherwise. Note that 'a valid UTF8 string' does
222not mean 'a string that contains code points above 0x7F encoded in
223UTF8' because a valid ASCII string is a valid UTF8 string.
6662521e
GS
224
225=cut
226*/
227
8e84507e 228bool
6662521e
GS
229Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
230{
067a85ef 231 U8* x = s;
1aa99e6b 232 U8* send;
067a85ef
A
233 STRLEN c;
234
1aa99e6b 235 if (!len)
6cd5fe39 236 len = strlen((char *)s);
1aa99e6b
IH
237 send = s + len;
238
6662521e 239 while (x < send) {
1acdb0da
JH
240 /* Inline the easy bits of is_utf8_char() here for speed... */
241 if (UTF8_IS_INVARIANT(*x))
242 c = 1;
243 else if (!UTF8_IS_START(*x))
244 return FALSE;
245 else {
246 /* ... and call is_utf8_char() only if really needed. */
247 c = is_utf8_char(x);
248 if (!c)
249 return FALSE;
250 }
6662521e 251 x += c;
6662521e 252 }
60006e79
JH
253 if (x != send)
254 return FALSE;
067a85ef
A
255
256 return TRUE;
6662521e
GS
257}
258
67e989fb 259/*
9041c2e3 260=for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
67e989fb 261
9041c2e3
NIS
262Bottom level UTF-8 decode routine.
263Returns the unicode code point value of the first character in the string C<s>
ba210ebe 264which is assumed to be in UTF8 encoding and no longer than C<curlen>;
7df053ec 265C<retlen> will be set to the length, in bytes, of that character.
67e989fb
JH
266
267If C<s> does not point to a well-formed UTF8 character, the behaviour
dcad2880
JH
268is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
269it is assumed that the caller will raise a warning, and this function
28d3d195
JH
270will silently just set C<retlen> to C<-1> and return zero. If the
271C<flags> does not contain UTF8_CHECK_ONLY, warnings about
272malformations will be given, C<retlen> will be set to the expected
273length of the UTF-8 character in bytes, and zero will be returned.
274
275The C<flags> can also contain various flags to allow deviations from
276the strict UTF-8 encoding (see F<utf8.h>).
67e989fb 277
9041c2e3
NIS
278Most code should use utf8_to_uvchr() rather than call this directly.
279
37607a96
PK
280=cut
281*/
67e989fb 282
a0ed51b3 283UV
37607a96 284Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 285{
097fb8e2 286 U8 *s0 = s;
9c5ffd7c 287 UV uv = *s, ouv = 0;
ba210ebe
JH
288 STRLEN len = 1;
289 bool dowarn = ckWARN_d(WARN_UTF8);
4f849cb6 290 UV startbyte = *s;
ba210ebe 291 STRLEN expectlen = 0;
a0dbb045
JH
292 U32 warning = 0;
293
294/* This list is a superset of the UTF8_ALLOW_XXX. */
295
296#define UTF8_WARN_EMPTY 1
297#define UTF8_WARN_CONTINUATION 2
298#define UTF8_WARN_NON_CONTINUATION 3
299#define UTF8_WARN_FE_FF 4
300#define UTF8_WARN_SHORT 5
301#define UTF8_WARN_OVERFLOW 6
302#define UTF8_WARN_SURROGATE 7
c867b360
JH
303#define UTF8_WARN_LONG 8
304#define UTF8_WARN_FFFF 9 /* Also FFFE. */
a0dbb045
JH
305
306 if (curlen == 0 &&
307 !(flags & UTF8_ALLOW_EMPTY)) {
308 warning = UTF8_WARN_EMPTY;
0c443dc2
JH
309 goto malformed;
310 }
311
1d72bdf6 312 if (UTF8_IS_INVARIANT(uv)) {
a0ed51b3
LW
313 if (retlen)
314 *retlen = 1;
c4d5f83a 315 return (UV) (NATIVE_TO_UTF(*s));
a0ed51b3 316 }
67e989fb 317
421a8bf2 318 if (UTF8_IS_CONTINUATION(uv) &&
fcc8fcf6 319 !(flags & UTF8_ALLOW_CONTINUATION)) {
a0dbb045 320 warning = UTF8_WARN_CONTINUATION;
ba210ebe
JH
321 goto malformed;
322 }
323
421a8bf2 324 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
fcc8fcf6 325 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045 326 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe
JH
327 goto malformed;
328 }
9041c2e3 329
1d72bdf6 330#ifdef EBCDIC
75383841 331 uv = NATIVE_TO_UTF(uv);
1d72bdf6 332#else
fcc8fcf6
JH
333 if ((uv == 0xfe || uv == 0xff) &&
334 !(flags & UTF8_ALLOW_FE_FF)) {
a0dbb045 335 warning = UTF8_WARN_FE_FF;
ba210ebe 336 goto malformed;
a0ed51b3 337 }
1d72bdf6
NIS
338#endif
339
ba210ebe
JH
340 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
341 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
342 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
343 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
1d72bdf6
NIS
344#ifdef EBCDIC
345 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
346 else { len = 7; uv &= 0x01; }
347#else
ba210ebe
JH
348 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
349 else if (!(uv & 0x01)) { len = 7; uv = 0; }
1d72bdf6
NIS
350 else { len = 13; uv = 0; } /* whoa! */
351#endif
352
a0ed51b3
LW
353 if (retlen)
354 *retlen = len;
9041c2e3 355
ba210ebe
JH
356 expectlen = len;
357
fcc8fcf6
JH
358 if ((curlen < expectlen) &&
359 !(flags & UTF8_ALLOW_SHORT)) {
a0dbb045 360 warning = UTF8_WARN_SHORT;
ba210ebe
JH
361 goto malformed;
362 }
363
364 len--;
a0ed51b3 365 s++;
ba210ebe
JH
366 ouv = uv;
367
a0ed51b3 368 while (len--) {
421a8bf2
JH
369 if (!UTF8_IS_CONTINUATION(*s) &&
370 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045
JH
371 s--;
372 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe 373 goto malformed;
a0ed51b3
LW
374 }
375 else
8850bf83 376 uv = UTF8_ACCUMULATE(uv, *s);
a0dbb045
JH
377 if (!(uv > ouv)) {
378 /* These cannot be allowed. */
379 if (uv == ouv) {
380 if (!(flags & UTF8_ALLOW_LONG)) {
381 warning = UTF8_WARN_LONG;
382 goto malformed;
383 }
384 }
385 else { /* uv < ouv */
386 /* This cannot be allowed. */
387 warning = UTF8_WARN_OVERFLOW;
388 goto malformed;
389 }
ba210ebe
JH
390 }
391 s++;
392 ouv = uv;
393 }
394
421a8bf2 395 if (UNICODE_IS_SURROGATE(uv) &&
fcc8fcf6 396 !(flags & UTF8_ALLOW_SURROGATE)) {
a0dbb045 397 warning = UTF8_WARN_SURROGATE;
ba210ebe 398 goto malformed;
eb160463 399 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
fcc8fcf6 400 !(flags & UTF8_ALLOW_LONG)) {
a0dbb045 401 warning = UTF8_WARN_LONG;
ba210ebe 402 goto malformed;
421a8bf2 403 } else if (UNICODE_IS_ILLEGAL(uv) &&
a9917092 404 !(flags & UTF8_ALLOW_FFFF)) {
a0dbb045 405 warning = UTF8_WARN_FFFF;
a9917092 406 goto malformed;
a0ed51b3 407 }
ba210ebe 408
a0ed51b3 409 return uv;
ba210ebe
JH
410
411malformed:
412
fcc8fcf6 413 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 414 if (retlen)
cc366d4b 415 *retlen = -1;
ba210ebe
JH
416 return 0;
417 }
418
a0dbb045
JH
419 if (dowarn) {
420 SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
421
422 switch (warning) {
423 case 0: /* Intentionally empty. */ break;
424 case UTF8_WARN_EMPTY:
425 Perl_sv_catpvf(aTHX_ sv, "(empty string)");
426 break;
427 case UTF8_WARN_CONTINUATION:
097fb8e2 428 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
a0dbb045
JH
429 break;
430 case UTF8_WARN_NON_CONTINUATION:
097fb8e2
JH
431 if (s == s0)
432 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
433 (UV)s[1], startbyte);
434 else
435 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
436 (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
437
a0dbb045
JH
438 break;
439 case UTF8_WARN_FE_FF:
440 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
441 break;
442 case UTF8_WARN_SHORT:
097fb8e2
JH
443 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
444 curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
b31f83c2 445 expectlen = curlen; /* distance for caller to skip */
a0dbb045
JH
446 break;
447 case UTF8_WARN_OVERFLOW:
097fb8e2
JH
448 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
449 ouv, *s, startbyte);
a0dbb045
JH
450 break;
451 case UTF8_WARN_SURROGATE:
452 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
453 break;
a0dbb045 454 case UTF8_WARN_LONG:
097fb8e2
JH
455 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
456 expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
a0dbb045
JH
457 break;
458 case UTF8_WARN_FFFF:
459 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
460 break;
461 default:
462 Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
463 break;
464 }
465
466 if (warning) {
467 char *s = SvPVX(sv);
468
469 if (PL_op)
9014280d 470 Perl_warner(aTHX_ packWARN(WARN_UTF8),
53e06cf0 471 "%s in %s", s, OP_DESC(PL_op));
a0dbb045 472 else
9014280d 473 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
a0dbb045
JH
474 }
475 }
476
ba210ebe 477 if (retlen)
28d3d195 478 *retlen = expectlen ? expectlen : len;
ba210ebe 479
28d3d195 480 return 0;
a0ed51b3
LW
481}
482
8e84507e 483/*
37607a96 484=for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
9041c2e3
NIS
485
486Returns the native character value of the first character in the string C<s>
487which is assumed to be in UTF8 encoding; C<retlen> will be set to the
488length, in bytes, of that character.
489
490If C<s> does not point to a well-formed UTF8 character, zero is
491returned and retlen is set, if possible, to -1.
492
493=cut
494*/
495
496UV
37607a96 497Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
9041c2e3 498{
872c91ae
JH
499 return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen,
500 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
9041c2e3
NIS
501}
502
503/*
37607a96 504=for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
9041c2e3
NIS
505
506Returns the Unicode code point of the first character in the string C<s>
507which is assumed to be in UTF8 encoding; C<retlen> will be set to the
508length, in bytes, of that character.
509
510This function should only be used when returned UV is considered
511an index into the Unicode semantic tables (e.g. swashes).
512
ba210ebe
JH
513If C<s> does not point to a well-formed UTF8 character, zero is
514returned and retlen is set, if possible, to -1.
8e84507e
NIS
515
516=cut
517*/
518
519UV
37607a96 520Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
8e84507e 521{
9041c2e3 522 /* Call the low level routine asking for checks */
872c91ae
JH
523 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen,
524 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
8e84507e
NIS
525}
526
b76347f2 527/*
37607a96 528=for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
b76347f2
JH
529
530Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
531Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
532up past C<e>, croaks.
b76347f2
JH
533
534=cut
535*/
536
537STRLEN
37607a96 538Perl_utf8_length(pTHX_ U8 *s, U8 *e)
b76347f2
JH
539{
540 STRLEN len = 0;
541
8850bf83
JH
542 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
543 * the bitops (especially ~) can create illegal UTF-8.
544 * In other words: in Perl UTF-8 is not just for Unicode. */
545
901b21bf
JH
546 if (e < s) {
547 if (ckWARN_d(WARN_UTF8)) {
548 if (PL_op)
549 Perl_warner(aTHX_ packWARN(WARN_UTF8),
550 "%s in %s", unees, OP_DESC(PL_op));
551 else
552 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
553 }
554 return 0;
555 }
b76347f2 556 while (s < e) {
02eb7b47 557 U8 t = UTF8SKIP(s);
b76347f2 558
901b21bf
JH
559 if (e - s < t) {
560 if (ckWARN_d(WARN_UTF8)) {
561 if (PL_op)
562 Perl_warner(aTHX_ packWARN(WARN_UTF8),
563 unees, OP_DESC(PL_op));
564 else
565 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
566 }
567 return len;
568 }
b76347f2
JH
569 s += t;
570 len++;
571 }
572
573 return len;
574}
575
b06226ff 576/*
eebe1485 577=for apidoc A|IV|utf8_distance|U8 *a|U8 *b
b06226ff
JH
578
579Returns the number of UTF8 characters between the UTF-8 pointers C<a>
580and C<b>.
581
582WARNING: use only if you *know* that the pointers point inside the
583same UTF-8 buffer.
584
37607a96
PK
585=cut
586*/
a0ed51b3 587
02eb7b47 588IV
864dbfa3 589Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
a0ed51b3 590{
02eb7b47
JH
591 IV off = 0;
592
8850bf83
JH
593 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
594 * the bitops (especially ~) can create illegal UTF-8.
595 * In other words: in Perl UTF-8 is not just for Unicode. */
596
a0ed51b3
LW
597 if (a < b) {
598 while (a < b) {
02eb7b47
JH
599 U8 c = UTF8SKIP(a);
600
901b21bf
JH
601 if (b - a < c) {
602 if (ckWARN_d(WARN_UTF8)) {
603 if (PL_op)
604 Perl_warner(aTHX_ packWARN(WARN_UTF8),
605 "%s in %s", unees, OP_DESC(PL_op));
606 else
607 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
608 }
609 return off;
610 }
02eb7b47 611 a += c;
a0ed51b3
LW
612 off--;
613 }
614 }
615 else {
616 while (b < a) {
02eb7b47
JH
617 U8 c = UTF8SKIP(b);
618
901b21bf
JH
619 if (a - b < c) {
620 if (ckWARN_d(WARN_UTF8)) {
621 if (PL_op)
622 Perl_warner(aTHX_ packWARN(WARN_UTF8),
623 "%s in %s", unees, OP_DESC(PL_op));
624 else
625 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
626 }
627 return off;
628 }
02eb7b47 629 b += c;
a0ed51b3
LW
630 off++;
631 }
632 }
02eb7b47 633
a0ed51b3
LW
634 return off;
635}
636
b06226ff 637/*
37607a96 638=for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
b06226ff 639
8850bf83
JH
640Return the UTF-8 pointer C<s> displaced by C<off> characters, either
641forward or backward.
b06226ff
JH
642
643WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
644the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
645on the first byte of character or just after the last byte of a character.
b06226ff 646
37607a96
PK
647=cut
648*/
a0ed51b3
LW
649
650U8 *
864dbfa3 651Perl_utf8_hop(pTHX_ U8 *s, I32 off)
a0ed51b3 652{
8850bf83
JH
653 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
654 * the bitops (especially ~) can create illegal UTF-8.
655 * In other words: in Perl UTF-8 is not just for Unicode. */
656
a0ed51b3
LW
657 if (off >= 0) {
658 while (off--)
659 s += UTF8SKIP(s);
660 }
661 else {
662 while (off++) {
663 s--;
8850bf83
JH
664 while (UTF8_IS_CONTINUATION(*s))
665 s--;
a0ed51b3
LW
666 }
667 }
668 return s;
669}
670
6940069f 671/*
eebe1485 672=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
6940069f 673
246fae53
MG
674Converts a string C<s> of length C<len> from UTF8 into byte encoding.
675Unlike C<bytes_to_utf8>, this over-writes the original string, and
676updates len to contain the new length.
67e989fb 677Returns zero on failure, setting C<len> to -1.
6940069f
GS
678
679=cut
680*/
681
682U8 *
37607a96 683Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 684{
6940069f
GS
685 U8 *send;
686 U8 *d;
dcad2880 687 U8 *save = s;
246fae53
MG
688
689 /* ensure valid UTF8 and chars < 256 before updating string */
dcad2880
JH
690 for (send = s + *len; s < send; ) {
691 U8 c = *s++;
692
1d72bdf6
NIS
693 if (!UTF8_IS_INVARIANT(c) &&
694 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
695 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
dcad2880
JH
696 *len = -1;
697 return 0;
698 }
246fae53 699 }
dcad2880
JH
700
701 d = s = save;
6940069f 702 while (s < send) {
ed646e6e 703 STRLEN ulen;
9041c2e3 704 *d++ = (U8)utf8_to_uvchr(s, &ulen);
ed646e6e 705 s += ulen;
6940069f
GS
706 }
707 *d = '\0';
246fae53 708 *len = d - save;
6940069f
GS
709 return save;
710}
711
712/*
f9a63242
JH
713=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
714
715Converts a string C<s> of length C<len> from UTF8 into byte encoding.
716Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
717the newly-created string, and updates C<len> to contain the new
718length. Returns the original string if no conversion occurs, C<len>
719is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
7200 if C<s> is converted or contains all 7bit characters.
f9a63242 721
37607a96
PK
722=cut
723*/
f9a63242
JH
724
725U8 *
37607a96 726Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 727{
f9a63242
JH
728 U8 *d;
729 U8 *start = s;
db42d148 730 U8 *send;
f9a63242
JH
731 I32 count = 0;
732
733 if (!*is_utf8)
734 return start;
735
ef9edfd0 736 /* ensure valid UTF8 and chars < 256 before converting string */
f9a63242
JH
737 for (send = s + *len; s < send;) {
738 U8 c = *s++;
1d72bdf6 739 if (!UTF8_IS_INVARIANT(c)) {
db42d148
NIS
740 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
741 (c = *s++) && UTF8_IS_CONTINUATION(c))
742 count++;
743 else
f9a63242 744 return start;
db42d148 745 }
f9a63242
JH
746 }
747
748 *is_utf8 = 0;
749
f9a63242 750 Newz(801, d, (*len) - count + 1, U8);
ef9edfd0 751 s = start; start = d;
f9a63242
JH
752 while (s < send) {
753 U8 c = *s++;
c4d5f83a
NIS
754 if (!UTF8_IS_INVARIANT(c)) {
755 /* Then it is two-byte encoded */
756 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
757 c = ASCII_TO_NATIVE(c);
758 }
759 *d++ = c;
f9a63242
JH
760 }
761 *d = '\0';
762 *len = d - start;
763 return start;
764}
765
766/*
eebe1485 767=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
6940069f
GS
768
769Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
6662521e
GS
770Returns a pointer to the newly-created string, and sets C<len> to
771reflect the new length.
6940069f 772
c9ada85f
JH
773If you want to convert to UTF8 from other encodings than ASCII,
774see sv_recode_to_utf8().
775
497711e7 776=cut
6940069f
GS
777*/
778
779U8*
37607a96 780Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
6940069f 781{
6940069f
GS
782 U8 *send;
783 U8 *d;
784 U8 *dst;
6662521e 785 send = s + (*len);
6940069f 786
6662521e 787 Newz(801, d, (*len) * 2 + 1, U8);
6940069f
GS
788 dst = d;
789
790 while (s < send) {
db42d148 791 UV uv = NATIVE_TO_ASCII(*s++);
c4d5f83a 792 if (UNI_IS_INVARIANT(uv))
eb160463 793 *d++ = (U8)UTF_TO_NATIVE(uv);
6940069f 794 else {
eb160463
GS
795 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
796 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
6940069f
GS
797 }
798 }
799 *d = '\0';
6662521e 800 *len = d-dst;
6940069f
GS
801 return dst;
802}
803
a0ed51b3 804/*
dea0fc0b 805 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
806 *
807 * Destination must be pre-extended to 3/2 source. Do not use in-place.
808 * We optimize for native, for obvious reasons. */
809
810U8*
dea0fc0b 811Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 812{
dea0fc0b
JH
813 U8* pend;
814 U8* dstart = d;
815
816 if (bytelen & 1)
a7867d0a 817 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
dea0fc0b
JH
818
819 pend = p + bytelen;
820
a0ed51b3 821 while (p < pend) {
dea0fc0b
JH
822 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
823 p += 2;
a0ed51b3 824 if (uv < 0x80) {
eb160463 825 *d++ = (U8)uv;
a0ed51b3
LW
826 continue;
827 }
828 if (uv < 0x800) {
eb160463
GS
829 *d++ = (U8)(( uv >> 6) | 0xc0);
830 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
831 continue;
832 }
833 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
30f84f9e
DT
834 UV low = (p[0] << 8) + p[1];
835 p += 2;
dea0fc0b
JH
836 if (low < 0xdc00 || low >= 0xdfff)
837 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
a0ed51b3
LW
838 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
839 }
840 if (uv < 0x10000) {
eb160463
GS
841 *d++ = (U8)(( uv >> 12) | 0xe0);
842 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
843 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
844 continue;
845 }
846 else {
eb160463
GS
847 *d++ = (U8)(( uv >> 18) | 0xf0);
848 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
849 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
850 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
851 continue;
852 }
853 }
dea0fc0b 854 *newlen = d - dstart;
a0ed51b3
LW
855 return d;
856}
857
858/* Note: this one is slightly destructive of the source. */
859
860U8*
dea0fc0b 861Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
862{
863 U8* s = (U8*)p;
864 U8* send = s + bytelen;
865 while (s < send) {
866 U8 tmp = s[0];
867 s[0] = s[1];
868 s[1] = tmp;
869 s += 2;
870 }
dea0fc0b 871 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
872}
873
874/* for now these are all defined (inefficiently) in terms of the utf8 versions */
875
876bool
84afefe6 877Perl_is_uni_alnum(pTHX_ UV c)
a0ed51b3 878{
ad391ad9 879 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 880 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
881 return is_utf8_alnum(tmpbuf);
882}
883
884bool
84afefe6 885Perl_is_uni_alnumc(pTHX_ UV c)
b8c5462f 886{
ad391ad9 887 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 888 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
889 return is_utf8_alnumc(tmpbuf);
890}
891
892bool
84afefe6 893Perl_is_uni_idfirst(pTHX_ UV c)
a0ed51b3 894{
ad391ad9 895 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 896 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
897 return is_utf8_idfirst(tmpbuf);
898}
899
900bool
84afefe6 901Perl_is_uni_alpha(pTHX_ UV c)
a0ed51b3 902{
ad391ad9 903 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 904 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
905 return is_utf8_alpha(tmpbuf);
906}
907
908bool
84afefe6 909Perl_is_uni_ascii(pTHX_ UV c)
4d61ec05 910{
ad391ad9 911 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 912 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
913 return is_utf8_ascii(tmpbuf);
914}
915
916bool
84afefe6 917Perl_is_uni_space(pTHX_ UV c)
a0ed51b3 918{
ad391ad9 919 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 920 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
921 return is_utf8_space(tmpbuf);
922}
923
924bool
84afefe6 925Perl_is_uni_digit(pTHX_ UV c)
a0ed51b3 926{
ad391ad9 927 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 928 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
929 return is_utf8_digit(tmpbuf);
930}
931
932bool
84afefe6 933Perl_is_uni_upper(pTHX_ UV c)
a0ed51b3 934{
ad391ad9 935 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 936 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
937 return is_utf8_upper(tmpbuf);
938}
939
940bool
84afefe6 941Perl_is_uni_lower(pTHX_ UV c)
a0ed51b3 942{
ad391ad9 943 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 944 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
945 return is_utf8_lower(tmpbuf);
946}
947
948bool
84afefe6 949Perl_is_uni_cntrl(pTHX_ UV c)
b8c5462f 950{
ad391ad9 951 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 952 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
953 return is_utf8_cntrl(tmpbuf);
954}
955
956bool
84afefe6 957Perl_is_uni_graph(pTHX_ UV c)
b8c5462f 958{
ad391ad9 959 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 960 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
961 return is_utf8_graph(tmpbuf);
962}
963
964bool
84afefe6 965Perl_is_uni_print(pTHX_ UV c)
a0ed51b3 966{
ad391ad9 967 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 968 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
969 return is_utf8_print(tmpbuf);
970}
971
b8c5462f 972bool
84afefe6 973Perl_is_uni_punct(pTHX_ UV c)
b8c5462f 974{
ad391ad9 975 U8 tmpbuf[UTF8_MAXLEN+1];
230880c1 976 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
977 return is_utf8_punct(tmpbuf);
978}
979
4d61ec05 980bool
84afefe6 981Perl_is_uni_xdigit(pTHX_ UV c)
4d61ec05 982{
e7ae6809 983 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
230880c1 984 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
985 return is_utf8_xdigit(tmpbuf);
986}
987
84afefe6
JH
988UV
989Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 990{
0ebc6274
JH
991 uvchr_to_utf8(p, c);
992 return to_utf8_upper(p, p, lenp);
a0ed51b3
LW
993}
994
84afefe6
JH
995UV
996Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 997{
0ebc6274
JH
998 uvchr_to_utf8(p, c);
999 return to_utf8_title(p, p, lenp);
a0ed51b3
LW
1000}
1001
84afefe6
JH
1002UV
1003Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1004{
0ebc6274
JH
1005 uvchr_to_utf8(p, c);
1006 return to_utf8_lower(p, p, lenp);
a0ed51b3
LW
1007}
1008
84afefe6
JH
1009UV
1010Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1011{
0ebc6274
JH
1012 uvchr_to_utf8(p, c);
1013 return to_utf8_fold(p, p, lenp);
84afefe6
JH
1014}
1015
a0ed51b3
LW
1016/* for now these all assume no locale info available for Unicode > 255 */
1017
1018bool
84afefe6 1019Perl_is_uni_alnum_lc(pTHX_ UV c)
a0ed51b3
LW
1020{
1021 return is_uni_alnum(c); /* XXX no locale support yet */
1022}
1023
1024bool
84afefe6 1025Perl_is_uni_alnumc_lc(pTHX_ UV c)
b8c5462f
JH
1026{
1027 return is_uni_alnumc(c); /* XXX no locale support yet */
1028}
1029
1030bool
84afefe6 1031Perl_is_uni_idfirst_lc(pTHX_ UV c)
a0ed51b3
LW
1032{
1033 return is_uni_idfirst(c); /* XXX no locale support yet */
1034}
1035
1036bool
84afefe6 1037Perl_is_uni_alpha_lc(pTHX_ UV c)
a0ed51b3
LW
1038{
1039 return is_uni_alpha(c); /* XXX no locale support yet */
1040}
1041
1042bool
84afefe6 1043Perl_is_uni_ascii_lc(pTHX_ UV c)
4d61ec05
GS
1044{
1045 return is_uni_ascii(c); /* XXX no locale support yet */
1046}
1047
1048bool
84afefe6 1049Perl_is_uni_space_lc(pTHX_ UV c)
a0ed51b3
LW
1050{
1051 return is_uni_space(c); /* XXX no locale support yet */
1052}
1053
1054bool
84afefe6 1055Perl_is_uni_digit_lc(pTHX_ UV c)
a0ed51b3
LW
1056{
1057 return is_uni_digit(c); /* XXX no locale support yet */
1058}
1059
1060bool
84afefe6 1061Perl_is_uni_upper_lc(pTHX_ UV c)
a0ed51b3
LW
1062{
1063 return is_uni_upper(c); /* XXX no locale support yet */
1064}
1065
1066bool
84afefe6 1067Perl_is_uni_lower_lc(pTHX_ UV c)
a0ed51b3
LW
1068{
1069 return is_uni_lower(c); /* XXX no locale support yet */
1070}
1071
1072bool
84afefe6 1073Perl_is_uni_cntrl_lc(pTHX_ UV c)
b8c5462f
JH
1074{
1075 return is_uni_cntrl(c); /* XXX no locale support yet */
1076}
1077
1078bool
84afefe6 1079Perl_is_uni_graph_lc(pTHX_ UV c)
b8c5462f
JH
1080{
1081 return is_uni_graph(c); /* XXX no locale support yet */
1082}
1083
1084bool
84afefe6 1085Perl_is_uni_print_lc(pTHX_ UV c)
a0ed51b3
LW
1086{
1087 return is_uni_print(c); /* XXX no locale support yet */
1088}
1089
b8c5462f 1090bool
84afefe6 1091Perl_is_uni_punct_lc(pTHX_ UV c)
b8c5462f
JH
1092{
1093 return is_uni_punct(c); /* XXX no locale support yet */
1094}
1095
4d61ec05 1096bool
84afefe6 1097Perl_is_uni_xdigit_lc(pTHX_ UV c)
4d61ec05
GS
1098{
1099 return is_uni_xdigit(c); /* XXX no locale support yet */
1100}
1101
b7ac61fa
JH
1102U32
1103Perl_to_uni_upper_lc(pTHX_ U32 c)
1104{
ee099d14
JH
1105 /* XXX returns only the first character -- do not use XXX */
1106 /* XXX no locale support yet */
1107 STRLEN len;
1108 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1109 return (U32)to_uni_upper(c, tmpbuf, &len);
b7ac61fa
JH
1110}
1111
1112U32
1113Perl_to_uni_title_lc(pTHX_ U32 c)
1114{
ee099d14
JH
1115 /* XXX returns only the first character XXX -- do not use XXX */
1116 /* XXX no locale support yet */
1117 STRLEN len;
1118 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1119 return (U32)to_uni_title(c, tmpbuf, &len);
b7ac61fa
JH
1120}
1121
1122U32
1123Perl_to_uni_lower_lc(pTHX_ U32 c)
1124{
ee099d14
JH
1125 /* XXX returns only the first character -- do not use XXX */
1126 /* XXX no locale support yet */
1127 STRLEN len;
1128 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1129 return (U32)to_uni_lower(c, tmpbuf, &len);
b7ac61fa
JH
1130}
1131
a0ed51b3 1132bool
864dbfa3 1133Perl_is_utf8_alnum(pTHX_ U8 *p)
a0ed51b3 1134{
386d01d6
GS
1135 if (!is_utf8_char(p))
1136 return FALSE;
a0ed51b3 1137 if (!PL_utf8_alnum)
289d4f09
ML
1138 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1139 * descendant of isalnum(3), in other words, it doesn't
1140 * contain the '_'. --jhi */
1141 PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
eb160463 1142 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
a0ed51b3
LW
1143/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1144#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1145 if (!PL_utf8_alnum)
1146 PL_utf8_alnum = swash_init("utf8", "",
1147 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
eb160463 1148 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
a0ed51b3
LW
1149#endif
1150}
1151
1152bool
b8c5462f
JH
1153Perl_is_utf8_alnumc(pTHX_ U8 *p)
1154{
386d01d6
GS
1155 if (!is_utf8_char(p))
1156 return FALSE;
b8c5462f
JH
1157 if (!PL_utf8_alnum)
1158 PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
eb160463 1159 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
b8c5462f
JH
1160/* return is_utf8_alpha(p) || is_utf8_digit(p); */
1161#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1162 if (!PL_utf8_alnum)
1163 PL_utf8_alnum = swash_init("utf8", "",
1164 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
eb160463 1165 return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
b8c5462f
JH
1166#endif
1167}
1168
1169bool
82686b01 1170Perl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
a0ed51b3 1171{
82686b01
JH
1172 if (*p == '_')
1173 return TRUE;
1174 if (!is_utf8_char(p))
1175 return FALSE;
1176 if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */
1177 PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0);
eb160463 1178 return swash_fetch(PL_utf8_idstart, p, TRUE) != 0;
82686b01
JH
1179}
1180
1181bool
1182Perl_is_utf8_idcont(pTHX_ U8 *p)
1183{
1184 if (*p == '_')
1185 return TRUE;
1186 if (!is_utf8_char(p))
1187 return FALSE;
1188 if (!PL_utf8_idcont)
1189 PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0);
eb160463 1190 return swash_fetch(PL_utf8_idcont, p, TRUE) != 0;
a0ed51b3
LW
1191}
1192
1193bool
864dbfa3 1194Perl_is_utf8_alpha(pTHX_ U8 *p)
a0ed51b3 1195{
386d01d6
GS
1196 if (!is_utf8_char(p))
1197 return FALSE;
a0ed51b3 1198 if (!PL_utf8_alpha)
e24b16f9 1199 PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
eb160463 1200 return swash_fetch(PL_utf8_alpha, p, TRUE) != 0;
a0ed51b3
LW
1201}
1202
1203bool
b8c5462f
JH
1204Perl_is_utf8_ascii(pTHX_ U8 *p)
1205{
386d01d6
GS
1206 if (!is_utf8_char(p))
1207 return FALSE;
b8c5462f
JH
1208 if (!PL_utf8_ascii)
1209 PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
eb160463 1210 return swash_fetch(PL_utf8_ascii, p, TRUE) != 0;
b8c5462f
JH
1211}
1212
1213bool
864dbfa3 1214Perl_is_utf8_space(pTHX_ U8 *p)
a0ed51b3 1215{
386d01d6
GS
1216 if (!is_utf8_char(p))
1217 return FALSE;
a0ed51b3 1218 if (!PL_utf8_space)
3bec3564 1219 PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
eb160463 1220 return swash_fetch(PL_utf8_space, p, TRUE) != 0;
a0ed51b3
LW
1221}
1222
1223bool
864dbfa3 1224Perl_is_utf8_digit(pTHX_ U8 *p)
a0ed51b3 1225{
386d01d6
GS
1226 if (!is_utf8_char(p))
1227 return FALSE;
a0ed51b3 1228 if (!PL_utf8_digit)
e24b16f9 1229 PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
eb160463 1230 return swash_fetch(PL_utf8_digit, p, TRUE) != 0;
a0ed51b3
LW
1231}
1232
1233bool
864dbfa3 1234Perl_is_utf8_upper(pTHX_ U8 *p)
a0ed51b3 1235{
386d01d6
GS
1236 if (!is_utf8_char(p))
1237 return FALSE;
a0ed51b3 1238 if (!PL_utf8_upper)
c65e4d19 1239 PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0);
eb160463 1240 return swash_fetch(PL_utf8_upper, p, TRUE) != 0;
a0ed51b3
LW
1241}
1242
1243bool
864dbfa3 1244Perl_is_utf8_lower(pTHX_ U8 *p)
a0ed51b3 1245{
386d01d6
GS
1246 if (!is_utf8_char(p))
1247 return FALSE;
a0ed51b3 1248 if (!PL_utf8_lower)
c65e4d19 1249 PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0);
eb160463 1250 return swash_fetch(PL_utf8_lower, p, TRUE) != 0;
a0ed51b3
LW
1251}
1252
1253bool
b8c5462f
JH
1254Perl_is_utf8_cntrl(pTHX_ U8 *p)
1255{
386d01d6
GS
1256 if (!is_utf8_char(p))
1257 return FALSE;
b8c5462f
JH
1258 if (!PL_utf8_cntrl)
1259 PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
eb160463 1260 return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0;
b8c5462f
JH
1261}
1262
1263bool
1264Perl_is_utf8_graph(pTHX_ U8 *p)
1265{
386d01d6
GS
1266 if (!is_utf8_char(p))
1267 return FALSE;
b8c5462f
JH
1268 if (!PL_utf8_graph)
1269 PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
eb160463 1270 return swash_fetch(PL_utf8_graph, p, TRUE) != 0;
b8c5462f
JH
1271}
1272
1273bool
864dbfa3 1274Perl_is_utf8_print(pTHX_ U8 *p)
a0ed51b3 1275{
386d01d6
GS
1276 if (!is_utf8_char(p))
1277 return FALSE;
a0ed51b3 1278 if (!PL_utf8_print)
e24b16f9 1279 PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
eb160463 1280 return swash_fetch(PL_utf8_print, p, TRUE) != 0;
a0ed51b3
LW
1281}
1282
1283bool
b8c5462f
JH
1284Perl_is_utf8_punct(pTHX_ U8 *p)
1285{
386d01d6
GS
1286 if (!is_utf8_char(p))
1287 return FALSE;
b8c5462f
JH
1288 if (!PL_utf8_punct)
1289 PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
eb160463 1290 return swash_fetch(PL_utf8_punct, p, TRUE) != 0;
b8c5462f
JH
1291}
1292
1293bool
1294Perl_is_utf8_xdigit(pTHX_ U8 *p)
1295{
386d01d6
GS
1296 if (!is_utf8_char(p))
1297 return FALSE;
b8c5462f
JH
1298 if (!PL_utf8_xdigit)
1299 PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
eb160463 1300 return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0;
b8c5462f
JH
1301}
1302
1303bool
864dbfa3 1304Perl_is_utf8_mark(pTHX_ U8 *p)
a0ed51b3 1305{
386d01d6
GS
1306 if (!is_utf8_char(p))
1307 return FALSE;
a0ed51b3 1308 if (!PL_utf8_mark)
e24b16f9 1309 PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
eb160463 1310 return swash_fetch(PL_utf8_mark, p, TRUE) != 0;
a0ed51b3
LW
1311}
1312
6b5c0936
JH
1313/*
1314=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1315
1316The "p" contains the pointer to the UTF-8 string encoding
1317the character that is being converted.
1318
1319The "ustrp" is a pointer to the character buffer to put the
1320conversion result to. The "lenp" is a pointer to the length
1321of the result.
1322
0134edef 1323The "swashp" is a pointer to the swash to use.
6b5c0936 1324
0134edef
JH
1325Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1326and loaded by SWASHGET, using lib/utf8_heavy.pl. The special (usually,
1327but not always, a multicharacter mapping), is tried first.
6b5c0936 1328
0134edef
JH
1329The "special" is a string like "utf8::ToSpecLower", which means the
1330hash %utf8::ToSpecLower. The access to the hash is through
1331Perl_to_utf8_case().
6b5c0936 1332
0134edef
JH
1333The "normal" is a string like "ToLower" which means the swash
1334%utf8::ToLower.
1335
1336=cut */
6b5c0936 1337
2104c8d9 1338UV
a6872d42 1339Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
a0ed51b3 1340{
0134edef 1341 UV uv0, uv1;
2f9475ad 1342 U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
0134edef 1343 STRLEN len = 0;
a0ed51b3 1344
1feea2c7
JH
1345 uv0 = utf8_to_uvchr(p, 0);
1346 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1347 * are necessary in EBCDIC, they are redundant no-ops
1348 * in ASCII-ish platforms, and hopefully optimized away. */
1349 uv1 = NATIVE_TO_UNI(uv0);
1350 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
1351
1352 if (!*swashp) /* load on-demand */
1353 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1354
1355 if (special) {
1356 /* It might be "special" (sometimes, but not always,
2a37f04d 1357 * a multicharacter mapping) */
983ffd37
JH
1358 HV *hv;
1359 SV *keysv;
1360 HE *he;
2a37f04d 1361 SV *val;
2f9475ad 1362
983ffd37 1363 if ((hv = get_hv(special, FALSE)) &&
1feea2c7 1364 (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv1))) &&
2a37f04d
JH
1365 (he = hv_fetch_ent(hv, keysv, FALSE, 0)) &&
1366 (val = HeVAL(he))) {
47654450 1367 char *s;
47654450 1368
2a37f04d 1369 s = SvPV(val, len);
47654450
JH
1370 if (len == 1)
1371 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 1372 else {
2f9475ad
JH
1373#ifdef EBCDIC
1374 /* If we have EBCDIC we need to remap the characters
1375 * since any characters in the low 256 are Unicode
1376 * code points, not EBCDIC. */
7cda7a3d 1377 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
1378
1379 d = tmpbuf;
1380 if (SvUTF8(val)) {
1381 STRLEN tlen = 0;
1382
1383 while (t < tend) {
1384 UV c = utf8_to_uvchr(t, &tlen);
1385 if (tlen > 0) {
1386 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1387 t += tlen;
1388 }
1389 else
1390 break;
1391 }
1392 }
1393 else {
36fec512
JH
1394 while (t < tend) {
1395 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1396 t++;
1397 }
2f9475ad
JH
1398 }
1399 len = d - tmpbuf;
1400 Copy(tmpbuf, ustrp, len, U8);
1401#else
d2dcd0fb 1402 Copy(s, ustrp, len, U8);
2f9475ad 1403#endif
29e98929 1404 }
983ffd37 1405 }
0134edef
JH
1406 }
1407
1408 if (!len && *swashp) {
1409 UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1410
1411 if (uv2) {
1412 /* It was "normal" (a single character mapping). */
1413 UV uv3 = UNI_TO_NATIVE(uv2);
1414
e9101d72 1415 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2a37f04d
JH
1416 }
1417 }
1feea2c7 1418
0134edef
JH
1419 if (!len) /* Neither: just copy. */
1420 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1421
2a37f04d
JH
1422 if (lenp)
1423 *lenp = len;
1424
0134edef 1425 return len ? utf8_to_uvchr(ustrp, 0) : 0;
a0ed51b3
LW
1426}
1427
d3e79532
JH
1428/*
1429=for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1430
1431Convert the UTF-8 encoded character at p to its uppercase version and
1432store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1433that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1434uppercase version may be longer than the original character (up to two
1435characters).
1436
1437The first character of the uppercased version is returned
1438(but note, as explained above, that there may be more.)
1439
1440=cut */
1441
2104c8d9 1442UV
983ffd37 1443Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1444{
983ffd37 1445 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1446 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
983ffd37 1447}
a0ed51b3 1448
d3e79532
JH
1449/*
1450=for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1451
1452Convert the UTF-8 encoded character at p to its titlecase version and
1453store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1454that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1455titlecase version may be longer than the original character (up to two
1456characters).
1457
1458The first character of the titlecased version is returned
1459(but note, as explained above, that there may be more.)
1460
1461=cut */
1462
983ffd37
JH
1463UV
1464Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1465{
1466 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1467 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
a0ed51b3
LW
1468}
1469
d3e79532
JH
1470/*
1471=for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1472
1473Convert the UTF-8 encoded character at p to its lowercase version and
1474store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1475that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1476lowercase version may be longer than the original character (up to two
1477characters).
1478
1479The first character of the lowercased version is returned
1480(but note, as explained above, that there may be more.)
1481
1482=cut */
1483
2104c8d9 1484UV
a2a2844f 1485Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1486{
983ffd37 1487 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9
JH
1488 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1489}
1490
d3e79532
JH
1491/*
1492=for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1493
1494Convert the UTF-8 encoded character at p to its foldcase version and
1495store that in UTF-8 in ustrp and its length in bytes in lenp. Note
1496that the ustrp needs to be at least UTF8_MAXLEN_FOLD+1 bytes since the
1497foldcase version may be longer than the original character (up to
1498three characters).
1499
1500The first character of the foldcased version is returned
1501(but note, as explained above, that there may be more.)
1502
1503=cut */
1504
b4e400f9
JH
1505UV
1506Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1507{
1508 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1509 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
a0ed51b3
LW
1510}
1511
1512/* a "swash" is a swatch hash */
1513
1514SV*
864dbfa3 1515Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3
LW
1516{
1517 SV* retval;
bf1fed83 1518 SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
8e84507e 1519 dSP;
1b026014 1520 HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
f8be5cf0 1521 SV* errsv_save;
ce3b816e 1522
1b026014 1523 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ce3b816e 1524 ENTER;
f8be5cf0 1525 errsv_save = newSVsv(ERRSV);
ce3b816e 1526 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
f8be5cf0
JH
1527 if (!SvTRUE(ERRSV))
1528 sv_setsv(ERRSV, errsv_save);
1529 SvREFCNT_dec(errsv_save);
ce3b816e
GS
1530 LEAVE;
1531 }
1532 SPAGAIN;
a0ed51b3
LW
1533 PUSHSTACKi(PERLSI_MAGIC);
1534 PUSHMARK(SP);
1535 EXTEND(SP,5);
1536 PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1537 PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1538 PUSHs(listsv);
1539 PUSHs(sv_2mortal(newSViv(minbits)));
1540 PUSHs(sv_2mortal(newSViv(none)));
1541 PUTBACK;
1542 ENTER;
1543 SAVEI32(PL_hints);
1544 PL_hints = 0;
1545 save_re_context();
82686b01 1546 if (PL_curcop == &PL_compiling) {
bf1fed83 1547 /* XXX ought to be handled by lex_start */
82686b01 1548 SAVEI32(PL_in_my);
2b4bd638 1549 PL_in_my = 0;
bf1fed83 1550 sv_setpv(tokenbufsv, PL_tokenbuf);
82686b01 1551 }
f8be5cf0 1552 errsv_save = newSVsv(ERRSV);
864dbfa3 1553 if (call_method("SWASHNEW", G_SCALAR))
8e84507e 1554 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1555 else
e24b16f9 1556 retval = &PL_sv_undef;
f8be5cf0
JH
1557 if (!SvTRUE(ERRSV))
1558 sv_setsv(ERRSV, errsv_save);
1559 SvREFCNT_dec(errsv_save);
a0ed51b3
LW
1560 LEAVE;
1561 POPSTACK;
e24b16f9 1562 if (PL_curcop == &PL_compiling) {
bf1fed83
JH
1563 STRLEN len;
1564 char* pv = SvPV(tokenbufsv, len);
1565
1566 Copy(pv, PL_tokenbuf, len+1, char);
eb160463 1567 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0ed51b3 1568 }
bc45ce41
JH
1569 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1570 if (SvPOK(retval))
35c1215d
NC
1571 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1572 retval);
cea2e8a9 1573 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
bc45ce41 1574 }
a0ed51b3
LW
1575 return retval;
1576}
1577
035d37be
JH
1578
1579/* This API is wrong for special case conversions since we may need to
1580 * return several Unicode characters for a single Unicode character
1581 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1582 * the lower-level routine, and it is similarly broken for returning
1583 * multiple values. --jhi */
a0ed51b3 1584UV
3568d838 1585Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
a0ed51b3
LW
1586{
1587 HV* hv = (HV*)SvRV(sv);
3568d838
JH
1588 U32 klen;
1589 U32 off;
a0ed51b3 1590 STRLEN slen;
7d85a32c 1591 STRLEN needents;
4ea42e7f 1592 U8 *tmps = NULL;
a0ed51b3
LW
1593 U32 bit;
1594 SV *retval;
3568d838
JH
1595 U8 tmputf8[2];
1596 UV c = NATIVE_TO_ASCII(*ptr);
1597
1598 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
eb160463
GS
1599 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1600 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
3568d838
JH
1601 ptr = tmputf8;
1602 }
1603 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1604 * then the "swatch" is a vec() for al the chars which start
1605 * with 0xAA..0xYY
1606 * So the key in the hash (klen) is length of encoded char -1
1607 */
1608 klen = UTF8SKIP(ptr) - 1;
1609 off = ptr[klen];
a0ed51b3 1610
7d85a32c
JH
1611 if (klen == 0)
1612 {
1613 /* If char in invariant then swatch is for all the invariant chars
1614 * In both UTF-8 and UTF8-MOD that happens to be UTF_CONTINUATION_MARK
1615 */
1616 needents = UTF_CONTINUATION_MARK;
1617 off = NATIVE_TO_UTF(ptr[klen]);
1618 }
1619 else
1620 {
1621 /* If char is encoded then swatch is for the prefix */
1622 needents = (1 << UTF_ACCUMULATION_SHIFT);
1623 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1624 }
1625
a0ed51b3
LW
1626 /*
1627 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1628 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1629 * it's nothing to sniff at.) Pity we usually come through at least
1630 * two function calls to get here...
1631 *
1632 * NB: this code assumes that swatches are never modified, once generated!
1633 */
1634
3568d838 1635 if (hv == PL_last_swash_hv &&
a0ed51b3 1636 klen == PL_last_swash_klen &&
3568d838 1637 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
1638 {
1639 tmps = PL_last_swash_tmps;
1640 slen = PL_last_swash_slen;
1641 }
1642 else {
1643 /* Try our second-level swatch cache, kept in a hash. */
dfe13c55 1644 SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
a0ed51b3
LW
1645
1646 /* If not cached, generate it via utf8::SWASHGET */
dfe13c55 1647 if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
a0ed51b3 1648 dSP;
2b9d42f0
NIS
1649 /* We use utf8n_to_uvuni() as we want an index into
1650 Unicode tables, not a native character number.
1651 */
872c91ae
JH
1652 UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, 0,
1653 ckWARN(WARN_UTF8) ?
1654 0 : UTF8_ALLOW_ANY);
f8be5cf0 1655 SV *errsv_save;
a0ed51b3
LW
1656 ENTER;
1657 SAVETMPS;
1658 save_re_context();
1659 PUSHSTACKi(PERLSI_MAGIC);
1660 PUSHMARK(SP);
1661 EXTEND(SP,3);
1662 PUSHs((SV*)sv);
ffbc6a93 1663 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
3568d838
JH
1664 PUSHs(sv_2mortal(newSViv((klen) ?
1665 (code_point & ~(needents - 1)) : 0)));
a0ed51b3
LW
1666 PUSHs(sv_2mortal(newSViv(needents)));
1667 PUTBACK;
f8be5cf0 1668 errsv_save = newSVsv(ERRSV);
864dbfa3 1669 if (call_method("SWASHGET", G_SCALAR))
8e84507e 1670 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1671 else
e24b16f9 1672 retval = &PL_sv_undef;
f8be5cf0
JH
1673 if (!SvTRUE(ERRSV))
1674 sv_setsv(ERRSV, errsv_save);
1675 SvREFCNT_dec(errsv_save);
a0ed51b3
LW
1676 POPSTACK;
1677 FREETMPS;
1678 LEAVE;
e24b16f9 1679 if (PL_curcop == &PL_compiling)
eb160463 1680 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0ed51b3 1681
dfe13c55 1682 svp = hv_store(hv, (char*)ptr, klen, retval, 0);
a0ed51b3 1683
7d85a32c 1684 if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
cea2e8a9 1685 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
a0ed51b3
LW
1686 }
1687
1688 PL_last_swash_hv = hv;
1689 PL_last_swash_klen = klen;
1690 PL_last_swash_tmps = tmps;
1691 PL_last_swash_slen = slen;
1692 if (klen)
1693 Copy(ptr, PL_last_swash_key, klen, U8);
1694 }
1695
9faf8d75 1696 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
1697 case 1:
1698 bit = 1 << (off & 7);
1699 off >>= 3;
1700 return (tmps[off] & bit) != 0;
1701 case 8:
1702 return tmps[off];
1703 case 16:
1704 off <<= 1;
1705 return (tmps[off] << 8) + tmps[off + 1] ;
1706 case 32:
1707 off <<= 2;
1708 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1709 }
cea2e8a9 1710 Perl_croak(aTHX_ "panic: swash_fetch");
a0ed51b3
LW
1711 return 0;
1712}
2b9d42f0
NIS
1713
1714
1715/*
37607a96 1716=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
2b9d42f0
NIS
1717
1718Adds the UTF8 representation of the Native codepoint C<uv> to the end
1719of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1720bytes available. The return value is the pointer to the byte after the
1721end of the new character. In other words,
1722
1723 d = uvchr_to_utf8(d, uv);
1724
1725is the recommended wide native character-aware way of saying
1726
1727 *(d++) = uv;
1728
1729=cut
1730*/
1731
1732/* On ASCII machines this is normally a macro but we want a
1733 real function in case XS code wants it
1734*/
1735#undef Perl_uvchr_to_utf8
1736U8 *
1737Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1738{
b851fbc1 1739 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2b9d42f0
NIS
1740}
1741
b851fbc1
JH
1742U8 *
1743Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1744{
1745 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1746}
2b9d42f0
NIS
1747
1748/*
37607a96 1749=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
2b9d42f0
NIS
1750
1751Returns the native character value of the first character in the string C<s>
1752which is assumed to be in UTF8 encoding; C<retlen> will be set to the
1753length, in bytes, of that character.
1754
1755Allows length and flags to be passed to low level routine.
1756
1757=cut
1758*/
0a2ef054
JH
1759/* On ASCII machines this is normally a macro but we want
1760 a real function in case XS code wants it
2b9d42f0
NIS
1761*/
1762#undef Perl_utf8n_to_uvchr
1763UV
37607a96 1764Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
2b9d42f0
NIS
1765{
1766 UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1767 return UNI_TO_NATIVE(uv);
1768}
1769
d2cc3551
JH
1770/*
1771=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1772
1773Build to the scalar dsv a displayable version of the string spv,
1774length len, the displayable version being at most pvlim bytes long
1775(if longer, the rest is truncated and "..." will be appended).
0a2ef054 1776
9e55ce06 1777The flags argument can have UNI_DISPLAY_ISPRINT set to display
00e86452 1778isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
0a2ef054
JH
1779to display the \\[nrfta\\] as the backslashed versions (like '\n')
1780(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1781UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1782UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1783
d2cc3551
JH
1784The pointer to the PV of the dsv is returned.
1785
1786=cut */
e6b2e755
JH
1787char *
1788Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1789{
1790 int truncated = 0;
1791 char *s, *e;
1792
1793 sv_setpvn(dsv, "", 0);
1794 for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1795 UV u;
c728cb41
JH
1796 bool ok = FALSE;
1797
e6b2e755
JH
1798 if (pvlim && SvCUR(dsv) >= pvlim) {
1799 truncated++;
1800 break;
1801 }
1802 u = utf8_to_uvchr((U8*)s, 0);
c728cb41 1803 if (u < 256) {
c728cb41
JH
1804 if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1805 switch (u & 0xFF) {
1806 case '\n':
1807 Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
1808 case '\r':
1809 Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
1810 case '\t':
1811 Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
1812 case '\f':
1813 Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
1814 case '\a':
1815 Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
1816 case '\\':
d79a7a3d 1817 Perl_sv_catpvf(aTHX_ dsv, "\\\\" ); ok = TRUE; break;
c728cb41
JH
1818 default: break;
1819 }
1820 }
00e86452
JH
1821 /* isPRINT() is the locale-blind version. */
1822 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) {
2c4547fe 1823 Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF));
0a2ef054
JH
1824 ok = TRUE;
1825 }
c728cb41
JH
1826 }
1827 if (!ok)
9e55ce06 1828 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
e6b2e755
JH
1829 }
1830 if (truncated)
1831 sv_catpvn(dsv, "...", 3);
1832
1833 return SvPVX(dsv);
1834}
2b9d42f0 1835
d2cc3551
JH
1836/*
1837=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1838
1839Build to the scalar dsv a displayable version of the scalar sv,
0a2ef054 1840the displayable version being at most pvlim bytes long
d2cc3551 1841(if longer, the rest is truncated and "..." will be appended).
0a2ef054
JH
1842
1843The flags argument is as in pv_uni_display().
1844
d2cc3551
JH
1845The pointer to the PV of the dsv is returned.
1846
1847=cut */
e6b2e755
JH
1848char *
1849Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1850{
701a277b
JH
1851 return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1852 pvlim, flags);
1853}
1854
d2cc3551 1855/*
d07ddd77 1856=for apidoc A|I32|ibcmp_utf8|const char *s1|char **pe1|register UV l1|bool u1|const char *s2|char **pe2|register UV l2|bool u2
d2cc3551
JH
1857
1858Return true if the strings s1 and s2 differ case-insensitively, false
1859if not (if they are equal case-insensitively). If u1 is true, the
1860string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
d07ddd77
JH
1861the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
1862are false, the respective string is assumed to be in native 8-bit
1863encoding.
1864
1865If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1866in there (they will point at the beginning of the I<next> character).
1867If the pointers behind pe1 or pe2 are non-NULL, they are the end
1868pointers beyond which scanning will not continue under any
1869circustances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
1870s2+l2 will be used as goal end pointers that will also stop the scan,
1871and which qualify towards defining a successful match: all the scans
1872that define an explicit length must reach their goal pointers for
1873a match to succeed).
d2cc3551
JH
1874
1875For case-insensitiveness, the "casefolding" of Unicode is used
1876instead of upper/lowercasing both the characters, see
1877http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1878
1879=cut */
701a277b 1880I32
d07ddd77 1881Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
332ddc25 1882{
5469e704
JH
1883 register U8 *p1 = (U8*)s1;
1884 register U8 *p2 = (U8*)s2;
d07ddd77
JH
1885 register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1886 register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1887 STRLEN n1 = 0, n2 = 0;
ffce6cc2
JH
1888 U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
1889 U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
d7f013c8
JH
1890 U8 natbuf[1+1];
1891 STRLEN foldlen1, foldlen2;
d07ddd77 1892 bool match;
332ddc25 1893
d07ddd77
JH
1894 if (pe1)
1895 e1 = *(U8**)pe1;
eb160463 1896 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
d07ddd77
JH
1897 f1 = (U8*)s1 + l1;
1898 if (pe2)
1899 e2 = *(U8**)pe2;
eb160463 1900 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
d07ddd77
JH
1901 f2 = (U8*)s2 + l2;
1902
1903 if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1904 return 1; /* mismatch; possible infinite loop or false positive */
1905
a6872d42
JH
1906 if (!u1 || !u2)
1907 natbuf[1] = 0; /* Need to terminate the buffer. */
1908
d07ddd77
JH
1909 while ((e1 == 0 || p1 < e1) &&
1910 (f1 == 0 || p1 < f1) &&
1911 (e2 == 0 || p2 < e2) &&
1912 (f2 == 0 || p2 < f2)) {
1913 if (n1 == 0) {
d7f013c8
JH
1914 if (u1)
1915 to_utf8_fold(p1, foldbuf1, &foldlen1);
1916 else {
f5cee151 1917 natbuf[0] = *p1;
d7f013c8
JH
1918 to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1919 }
1920 q1 = foldbuf1;
d07ddd77 1921 n1 = foldlen1;
332ddc25 1922 }
d07ddd77 1923 if (n2 == 0) {
d7f013c8
JH
1924 if (u2)
1925 to_utf8_fold(p2, foldbuf2, &foldlen2);
1926 else {
f5cee151 1927 natbuf[0] = *p2;
d7f013c8
JH
1928 to_utf8_fold(natbuf, foldbuf2, &foldlen2);
1929 }
1930 q2 = foldbuf2;
d07ddd77 1931 n2 = foldlen2;
332ddc25 1932 }
d07ddd77
JH
1933 while (n1 && n2) {
1934 if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
1935 (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
1936 memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
d7f013c8 1937 return 1; /* mismatch */
d07ddd77 1938 n1 -= UTF8SKIP(q1);
d7f013c8 1939 q1 += UTF8SKIP(q1);
d07ddd77 1940 n2 -= UTF8SKIP(q2);
d7f013c8 1941 q2 += UTF8SKIP(q2);
701a277b 1942 }
d07ddd77 1943 if (n1 == 0)
d7f013c8 1944 p1 += u1 ? UTF8SKIP(p1) : 1;
d07ddd77 1945 if (n2 == 0)
d7f013c8
JH
1946 p2 += u2 ? UTF8SKIP(p2) : 1;
1947
d2cc3551 1948 }
5469e704 1949
d07ddd77
JH
1950 /* A match is defined by all the scans that specified
1951 * an explicit length reaching their final goals. */
1952 match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
5469e704
JH
1953
1954 if (match) {
d07ddd77
JH
1955 if (pe1)
1956 *pe1 = (char*)p1;
1957 if (pe2)
1958 *pe2 = (char*)p2;
5469e704
JH
1959 }
1960
1961 return match ? 0 : 1; /* 0 match, 1 mismatch */
e6b2e755 1962}
701a277b 1963