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