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