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