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