This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #34155] perldoc -f hex should say how to convert back
[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/*
eebe1485
SC
177=for apidoc A|STRLEN|is_utf8_char|U8 *s
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
386d01d6
GS
186Perl_is_utf8_char(pTHX_ U8 *s)
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/*
eebe1485 225=for apidoc A|bool|is_utf8_string|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
6662521e
GS
236Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
237{
067a85ef 238 U8* x = s;
1aa99e6b 239 U8* send;
067a85ef
A
240 STRLEN c;
241
61468b03 242 if (!len && s)
6cd5fe39 243 len = strlen((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/*
81cd54e3
JH
267=for apidoc A|bool|is_utf8_string_loc|U8 *s|STRLEN len|U8 **p
268
269Like is_ut8_string but store the location of the failure in
270the last argument.
271
272=cut
273*/
274
275bool
276Perl_is_utf8_string_loc(pTHX_ U8 *s, STRLEN len, U8 **p)
277{
278 U8* x = s;
279 U8* send;
280 STRLEN c;
281
61468b03 282 if (!len && s)
81cd54e3
JH
283 len = strlen((char *)s);
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/*
9041c2e3 316=for apidoc A|UV|utf8n_to_uvuni|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
37607a96 340Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 341{
097fb8e2 342 U8 *s0 = s;
9c5ffd7c 343 UV uv = *s, ouv = 0;
ba210ebe
JH
344 STRLEN len = 1;
345 bool dowarn = ckWARN_d(WARN_UTF8);
4f849cb6 346 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/*
37607a96 540=for apidoc A|UV|utf8_to_uvchr|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
37607a96 553Perl_utf8_to_uvchr(pTHX_ 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/*
37607a96 560=for apidoc A|UV|utf8_to_uvuni|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
37607a96 576Perl_utf8_to_uvuni(pTHX_ 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/*
37607a96 584=for apidoc A|STRLEN|utf8_length|U8 *s|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
37607a96 594Perl_utf8_length(pTHX_ U8 *s, 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/*
eebe1485 633=for apidoc A|IV|utf8_distance|U8 *a|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
864dbfa3 645Perl_utf8_distance(pTHX_ U8 *a, 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) {
02eb7b47
JH
655 U8 c = UTF8SKIP(a);
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/*
f9a63242
JH
769=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
770
1e54db1a 771Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
f9a63242 772Unlike <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 *
37607a96 782Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 783{
f9a63242
JH
784 U8 *d;
785 U8 *start = s;
db42d148 786 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
JH
793 for (send = s + *len; s < send;) {
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/*
eebe1485 823=for apidoc A|U8 *|bytes_to_utf8|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*
37607a96 836Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
6940069f 837{
6940069f
GS
838 U8 *send;
839 U8 *d;
840 U8 *dst;
6662521e 841 send = s + (*len);
6940069f 842
6662521e 843 Newz(801, d, (*len) * 2 + 1, U8);
6940069f
GS
844 dst = d;
845
846 while (s < send) {
db42d148 847 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
864dbfa3 1195Perl_is_utf8_alnum(pTHX_ 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
b8c5462f
JH
1215Perl_is_utf8_alnumc(pTHX_ U8 *p)
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
82686b01 1232Perl_is_utf8_idfirst(pTHX_ 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
1244Perl_is_utf8_idcont(pTHX_ U8 *p)
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
864dbfa3 1256Perl_is_utf8_alpha(pTHX_ 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
b8c5462f
JH
1266Perl_is_utf8_ascii(pTHX_ U8 *p)
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
864dbfa3 1276Perl_is_utf8_space(pTHX_ 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
864dbfa3 1286Perl_is_utf8_digit(pTHX_ 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
864dbfa3 1296Perl_is_utf8_upper(pTHX_ 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
864dbfa3 1306Perl_is_utf8_lower(pTHX_ 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
b8c5462f
JH
1316Perl_is_utf8_cntrl(pTHX_ U8 *p)
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
1326Perl_is_utf8_graph(pTHX_ U8 *p)
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
864dbfa3 1336Perl_is_utf8_print(pTHX_ 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
b8c5462f
JH
1346Perl_is_utf8_punct(pTHX_ U8 *p)
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
1356Perl_is_utf8_xdigit(pTHX_ U8 *p)
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
864dbfa3 1366Perl_is_utf8_mark(pTHX_ 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
a6872d42 1401Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
a0ed51b3 1402{
0134edef 1403 UV uv0, uv1;
89ebb4a3 1404 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
0134edef 1405 STRLEN len = 0;
a0ed51b3 1406
1feea2c7
JH
1407 uv0 = utf8_to_uvchr(p, 0);
1408 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1409 * are necessary in EBCDIC, they are redundant no-ops
1410 * in ASCII-ish platforms, and hopefully optimized away. */
1411 uv1 = NATIVE_TO_UNI(uv0);
1412 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
1413
1414 if (!*swashp) /* load on-demand */
1415 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1416
b08cf34e
JH
1417 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1418 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
0134edef 1419 /* It might be "special" (sometimes, but not always,
2a37f04d 1420 * a multicharacter mapping) */
983ffd37 1421 HV *hv;
b08cf34e
JH
1422 SV **svp;
1423
1424 if ((hv = get_hv(special, FALSE)) &&
1425 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1426 (*svp)) {
1427 char *s;
47654450 1428
b08cf34e 1429 s = SvPV(*svp, len);
47654450
JH
1430 if (len == 1)
1431 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 1432 else {
2f9475ad
JH
1433#ifdef EBCDIC
1434 /* If we have EBCDIC we need to remap the characters
1435 * since any characters in the low 256 are Unicode
1436 * code points, not EBCDIC. */
7cda7a3d 1437 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
1438
1439 d = tmpbuf;
b08cf34e 1440 if (SvUTF8(*svp)) {
2f9475ad
JH
1441 STRLEN tlen = 0;
1442
1443 while (t < tend) {
1444 UV c = utf8_to_uvchr(t, &tlen);
1445 if (tlen > 0) {
1446 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1447 t += tlen;
1448 }
1449 else
1450 break;
1451 }
1452 }
1453 else {
36fec512
JH
1454 while (t < tend) {
1455 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1456 t++;
1457 }
2f9475ad
JH
1458 }
1459 len = d - tmpbuf;
1460 Copy(tmpbuf, ustrp, len, U8);
1461#else
d2dcd0fb 1462 Copy(s, ustrp, len, U8);
2f9475ad 1463#endif
29e98929 1464 }
983ffd37 1465 }
0134edef
JH
1466 }
1467
1468 if (!len && *swashp) {
1469 UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1470
1471 if (uv2) {
1472 /* It was "normal" (a single character mapping). */
1473 UV uv3 = UNI_TO_NATIVE(uv2);
1474
e9101d72 1475 len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2a37f04d
JH
1476 }
1477 }
1feea2c7 1478
0134edef
JH
1479 if (!len) /* Neither: just copy. */
1480 len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1481
2a37f04d
JH
1482 if (lenp)
1483 *lenp = len;
1484
0134edef 1485 return len ? utf8_to_uvchr(ustrp, 0) : 0;
a0ed51b3
LW
1486}
1487
d3e79532
JH
1488/*
1489=for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1490
1491Convert the UTF-8 encoded character at p to its uppercase version and
1492store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1493that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1494the uppercase version may be longer than the original character.
d3e79532
JH
1495
1496The first character of the uppercased version is returned
1497(but note, as explained above, that there may be more.)
1498
1499=cut */
1500
2104c8d9 1501UV
983ffd37 1502Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1503{
983ffd37 1504 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1505 &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
983ffd37 1506}
a0ed51b3 1507
d3e79532
JH
1508/*
1509=for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1510
1511Convert the UTF-8 encoded character at p to its titlecase version and
1512store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1513that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1514titlecase version may be longer than the original character.
d3e79532
JH
1515
1516The first character of the titlecased version is returned
1517(but note, as explained above, that there may be more.)
1518
1519=cut */
1520
983ffd37
JH
1521UV
1522Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1523{
1524 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9 1525 &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
a0ed51b3
LW
1526}
1527
d3e79532
JH
1528/*
1529=for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1530
1531Convert the UTF-8 encoded character at p to its lowercase version and
1532store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3
JH
1533that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1534lowercase version may be longer than the original character.
d3e79532
JH
1535
1536The first character of the lowercased version is returned
1537(but note, as explained above, that there may be more.)
1538
1539=cut */
1540
2104c8d9 1541UV
a2a2844f 1542Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
a0ed51b3 1543{
983ffd37 1544 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
b4e400f9
JH
1545 &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1546}
1547
d3e79532
JH
1548/*
1549=for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1550
1551Convert the UTF-8 encoded character at p to its foldcase version and
1552store that in UTF-8 in ustrp and its length in bytes in lenp. Note
89ebb4a3 1553that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
d3e79532
JH
1554foldcase version may be longer than the original character (up to
1555three characters).
1556
1557The first character of the foldcased version is returned
1558(but note, as explained above, that there may be more.)
1559
1560=cut */
1561
b4e400f9
JH
1562UV
1563Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1564{
1565 return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1566 &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
a0ed51b3
LW
1567}
1568
1569/* a "swash" is a swatch hash */
1570
1571SV*
864dbfa3 1572Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3
LW
1573{
1574 SV* retval;
243b1711 1575 SV* tokenbufsv = sv_newmortal();
8e84507e 1576 dSP;
71bed85a
NC
1577 size_t pkg_len = strlen(pkg);
1578 size_t name_len = strlen(name);
1579 HV *stash = gv_stashpvn(pkg, pkg_len, FALSE);
f8be5cf0 1580 SV* errsv_save;
ce3b816e 1581
1b026014 1582 if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ce3b816e 1583 ENTER;
f8be5cf0 1584 errsv_save = newSVsv(ERRSV);
71bed85a
NC
1585 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1586 Nullsv);
f8be5cf0
JH
1587 if (!SvTRUE(ERRSV))
1588 sv_setsv(ERRSV, errsv_save);
1589 SvREFCNT_dec(errsv_save);
ce3b816e
GS
1590 LEAVE;
1591 }
1592 SPAGAIN;
a0ed51b3
LW
1593 PUSHSTACKi(PERLSI_MAGIC);
1594 PUSHMARK(SP);
1595 EXTEND(SP,5);
71bed85a
NC
1596 PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
1597 PUSHs(sv_2mortal(newSVpvn(name, name_len)));
a0ed51b3
LW
1598 PUSHs(listsv);
1599 PUSHs(sv_2mortal(newSViv(minbits)));
1600 PUSHs(sv_2mortal(newSViv(none)));
1601 PUTBACK;
1602 ENTER;
1603 SAVEI32(PL_hints);
1604 PL_hints = 0;
1605 save_re_context();
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
JH
1623 STRLEN len;
1624 char* pv = SvPV(tokenbufsv, len);
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
3568d838 1645Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
a0ed51b3
LW
1646{
1647 HV* hv = (HV*)SvRV(sv);
3568d838
JH
1648 U32 klen;
1649 U32 off;
a0ed51b3 1650 STRLEN slen;
7d85a32c 1651 STRLEN needents;
4ea42e7f 1652 U8 *tmps = NULL;
a0ed51b3
LW
1653 U32 bit;
1654 SV *retval;
3568d838
JH
1655 U8 tmputf8[2];
1656 UV c = NATIVE_TO_ASCII(*ptr);
1657
1658 if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
eb160463
GS
1659 tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1660 tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
3568d838
JH
1661 ptr = tmputf8;
1662 }
1663 /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1664 * then the "swatch" is a vec() for al the chars which start
1665 * with 0xAA..0xYY
1666 * So the key in the hash (klen) is length of encoded char -1
1667 */
1668 klen = UTF8SKIP(ptr) - 1;
1669 off = ptr[klen];
a0ed51b3 1670
7d85a32c
JH
1671 if (klen == 0)
1672 {
1673 /* If char in invariant then swatch is for all the invariant chars
1e54db1a 1674 * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
7d85a32c
JH
1675 */
1676 needents = UTF_CONTINUATION_MARK;
1677 off = NATIVE_TO_UTF(ptr[klen]);
1678 }
1679 else
1680 {
1681 /* If char is encoded then swatch is for the prefix */
1682 needents = (1 << UTF_ACCUMULATION_SHIFT);
1683 off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1684 }
1685
a0ed51b3
LW
1686 /*
1687 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1688 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1689 * it's nothing to sniff at.) Pity we usually come through at least
1690 * two function calls to get here...
1691 *
1692 * NB: this code assumes that swatches are never modified, once generated!
1693 */
1694
3568d838 1695 if (hv == PL_last_swash_hv &&
a0ed51b3 1696 klen == PL_last_swash_klen &&
3568d838 1697 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
1698 {
1699 tmps = PL_last_swash_tmps;
1700 slen = PL_last_swash_slen;
1701 }
1702 else {
1703 /* Try our second-level swatch cache, kept in a hash. */
dfe13c55 1704 SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
a0ed51b3
LW
1705
1706 /* If not cached, generate it via utf8::SWASHGET */
dfe13c55 1707 if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
a0ed51b3 1708 dSP;
2b9d42f0
NIS
1709 /* We use utf8n_to_uvuni() as we want an index into
1710 Unicode tables, not a native character number.
1711 */
89ebb4a3 1712 UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
872c91ae
JH
1713 ckWARN(WARN_UTF8) ?
1714 0 : UTF8_ALLOW_ANY);
f8be5cf0 1715 SV *errsv_save;
a0ed51b3
LW
1716 ENTER;
1717 SAVETMPS;
1718 save_re_context();
1719 PUSHSTACKi(PERLSI_MAGIC);
1720 PUSHMARK(SP);
1721 EXTEND(SP,3);
1722 PUSHs((SV*)sv);
ffbc6a93 1723 /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
3568d838
JH
1724 PUSHs(sv_2mortal(newSViv((klen) ?
1725 (code_point & ~(needents - 1)) : 0)));
a0ed51b3
LW
1726 PUSHs(sv_2mortal(newSViv(needents)));
1727 PUTBACK;
f8be5cf0 1728 errsv_save = newSVsv(ERRSV);
864dbfa3 1729 if (call_method("SWASHGET", G_SCALAR))
8e84507e 1730 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1731 else
e24b16f9 1732 retval = &PL_sv_undef;
f8be5cf0
JH
1733 if (!SvTRUE(ERRSV))
1734 sv_setsv(ERRSV, errsv_save);
1735 SvREFCNT_dec(errsv_save);
a0ed51b3
LW
1736 POPSTACK;
1737 FREETMPS;
1738 LEAVE;
923e4eb5 1739 if (IN_PERL_COMPILETIME)
eb160463 1740 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0ed51b3 1741
dfe13c55 1742 svp = hv_store(hv, (char*)ptr, klen, retval, 0);
a0ed51b3 1743
7d85a32c 1744 if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
cea2e8a9 1745 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
a0ed51b3
LW
1746 }
1747
1748 PL_last_swash_hv = hv;
1749 PL_last_swash_klen = klen;
1750 PL_last_swash_tmps = tmps;
1751 PL_last_swash_slen = slen;
1752 if (klen)
1753 Copy(ptr, PL_last_swash_key, klen, U8);
1754 }
1755
9faf8d75 1756 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
1757 case 1:
1758 bit = 1 << (off & 7);
1759 off >>= 3;
1760 return (tmps[off] & bit) != 0;
1761 case 8:
1762 return tmps[off];
1763 case 16:
1764 off <<= 1;
1765 return (tmps[off] << 8) + tmps[off + 1] ;
1766 case 32:
1767 off <<= 2;
1768 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1769 }
cea2e8a9 1770 Perl_croak(aTHX_ "panic: swash_fetch");
a0ed51b3
LW
1771 return 0;
1772}
2b9d42f0
NIS
1773
1774
1775/*
37607a96 1776=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
2b9d42f0 1777
1e54db1a 1778Adds the UTF-8 representation of the Native codepoint C<uv> to the end
89ebb4a3 1779of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2b9d42f0
NIS
1780bytes available. The return value is the pointer to the byte after the
1781end of the new character. In other words,
1782
1783 d = uvchr_to_utf8(d, uv);
1784
1785is the recommended wide native character-aware way of saying
1786
1787 *(d++) = uv;
1788
1789=cut
1790*/
1791
1792/* On ASCII machines this is normally a macro but we want a
1793 real function in case XS code wants it
1794*/
1795#undef Perl_uvchr_to_utf8
1796U8 *
1797Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1798{
b851fbc1 1799 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2b9d42f0
NIS
1800}
1801
b851fbc1
JH
1802U8 *
1803Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1804{
1805 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1806}
2b9d42f0
NIS
1807
1808/*
37607a96 1809=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
2b9d42f0
NIS
1810
1811Returns the native character value of the first character in the string C<s>
1e54db1a 1812which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2b9d42f0
NIS
1813length, in bytes, of that character.
1814
1815Allows length and flags to be passed to low level routine.
1816
1817=cut
1818*/
0a2ef054
JH
1819/* On ASCII machines this is normally a macro but we want
1820 a real function in case XS code wants it
2b9d42f0
NIS
1821*/
1822#undef Perl_utf8n_to_uvchr
1823UV
37607a96 1824Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
2b9d42f0
NIS
1825{
1826 UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1827 return UNI_TO_NATIVE(uv);
1828}
1829
d2cc3551
JH
1830/*
1831=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1832
1833Build to the scalar dsv a displayable version of the string spv,
1834length len, the displayable version being at most pvlim bytes long
1835(if longer, the rest is truncated and "..." will be appended).
0a2ef054 1836
9e55ce06 1837The flags argument can have UNI_DISPLAY_ISPRINT set to display
00e86452 1838isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
0a2ef054
JH
1839to display the \\[nrfta\\] as the backslashed versions (like '\n')
1840(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1841UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1842UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1843
d2cc3551
JH
1844The pointer to the PV of the dsv is returned.
1845
1846=cut */
e6b2e755
JH
1847char *
1848Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1849{
1850 int truncated = 0;
1851 char *s, *e;
1852
1853 sv_setpvn(dsv, "", 0);
1854 for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1855 UV u;
a49f32c6
NC
1856 /* This serves double duty as a flag and a character to print after
1857 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
1858 */
1859 char ok = 0;
c728cb41 1860
e6b2e755
JH
1861 if (pvlim && SvCUR(dsv) >= pvlim) {
1862 truncated++;
1863 break;
1864 }
1865 u = utf8_to_uvchr((U8*)s, 0);
c728cb41 1866 if (u < 256) {
a49f32c6 1867 unsigned char c = u & 0xFF;
c728cb41 1868 if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
a49f32c6 1869 switch (c) {
c728cb41 1870 case '\n':
a49f32c6 1871 ok = 'n'; break;
c728cb41 1872 case '\r':
a49f32c6 1873 ok = 'r'; break;
c728cb41 1874 case '\t':
a49f32c6 1875 ok = 't'; break;
c728cb41 1876 case '\f':
a49f32c6 1877 ok = 'f'; break;
c728cb41 1878 case '\a':
a49f32c6 1879 ok = 'a'; break;
c728cb41 1880 case '\\':
a49f32c6 1881 ok = '\\'; break;
c728cb41
JH
1882 default: break;
1883 }
a49f32c6
NC
1884 if (ok) {
1885 Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok);
1886 }
c728cb41 1887 }
00e86452 1888 /* isPRINT() is the locale-blind version. */
a49f32c6
NC
1889 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
1890 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
1891 ok = 1;
0a2ef054 1892 }
c728cb41
JH
1893 }
1894 if (!ok)
9e55ce06 1895 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
e6b2e755
JH
1896 }
1897 if (truncated)
1898 sv_catpvn(dsv, "...", 3);
1899
1900 return SvPVX(dsv);
1901}
2b9d42f0 1902
d2cc3551
JH
1903/*
1904=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1905
1906Build to the scalar dsv a displayable version of the scalar sv,
0a2ef054 1907the displayable version being at most pvlim bytes long
d2cc3551 1908(if longer, the rest is truncated and "..." will be appended).
0a2ef054
JH
1909
1910The flags argument is as in pv_uni_display().
1911
d2cc3551
JH
1912The pointer to the PV of the dsv is returned.
1913
1914=cut */
e6b2e755
JH
1915char *
1916Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1917{
701a277b
JH
1918 return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1919 pvlim, flags);
1920}
1921
d2cc3551 1922/*
d07ddd77 1923=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
1924
1925Return true if the strings s1 and s2 differ case-insensitively, false
1926if not (if they are equal case-insensitively). If u1 is true, the
1927string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
d07ddd77
JH
1928the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
1929are false, the respective string is assumed to be in native 8-bit
1930encoding.
1931
1932If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1933in there (they will point at the beginning of the I<next> character).
1934If the pointers behind pe1 or pe2 are non-NULL, they are the end
1935pointers beyond which scanning will not continue under any
4cdaeff7 1936circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
d07ddd77
JH
1937s2+l2 will be used as goal end pointers that will also stop the scan,
1938and which qualify towards defining a successful match: all the scans
1939that define an explicit length must reach their goal pointers for
1940a match to succeed).
d2cc3551
JH
1941
1942For case-insensitiveness, the "casefolding" of Unicode is used
1943instead of upper/lowercasing both the characters, see
1944http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1945
1946=cut */
701a277b 1947I32
d07ddd77 1948Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
332ddc25 1949{
5469e704
JH
1950 register U8 *p1 = (U8*)s1;
1951 register U8 *p2 = (U8*)s2;
d07ddd77
JH
1952 register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1953 register U8 *e2 = 0, *f2 = 0, *q2 = 0;
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;
eb160463 1963 if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
d07ddd77
JH
1964 f1 = (U8*)s1 + l1;
1965 if (pe2)
1966 e2 = *(U8**)pe2;
eb160463 1967 if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
d07ddd77
JH
1968 f2 = (U8*)s2 + l2;
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*/