This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Builds an passes all tests after integrate and this tweak.
[perl5.git] / utf8.c
CommitLineData
a0ed51b3
LW
1/* utf8.c
2 *
bc89e66f 3 * Copyright (c) 1998-2001, Larry Wall
a0ed51b3
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
12 * heard of that we don't want to see any closer; and that's the one place
13 * we're trying to get to! And that's just where we can't get, nohow.'
14 *
15 * 'Well do I understand your speech,' he answered in the same language;
16 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
17 * as is the custom in the West, if you wish to be answered?'
18 *
19 * ...the travellers perceived that the floor was paved with stones of many
20 * hues; branching runes and strange devices intertwined beneath their feet.
21 */
22
23#include "EXTERN.h"
864dbfa3 24#define PERL_IN_UTF8_C
a0ed51b3
LW
25#include "perl.h"
26
27/* Unicode support */
28
eebe1485
SC
29/*
30=for apidoc A|U8*|uv_to_utf8|U8 *d|UV uv
31
32Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
33of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
34bytes available. The return value is the pointer to the byte after the
35end of the new character. In other words,
36
37 d = uv_to_utf8(d, uv);
38
39is the recommended Unicode-aware way of saying
40
41 *(d++) = uv;
42
43=cut
44*/
45
dfe13c55 46U8 *
eebe1485 47Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
a0ed51b3 48{
3bd709b1
PP
49 if (uv < 0x100)
50 uv = NATIVE_TO_ASCII(uv);
a0ed51b3
LW
51 if (uv < 0x80) {
52 *d++ = uv;
53 return d;
54 }
55 if (uv < 0x800) {
56 *d++ = (( uv >> 6) | 0xc0);
57 *d++ = (( uv & 0x3f) | 0x80);
58 return d;
59 }
60 if (uv < 0x10000) {
61 *d++ = (( uv >> 12) | 0xe0);
62 *d++ = (((uv >> 6) & 0x3f) | 0x80);
63 *d++ = (( uv & 0x3f) | 0x80);
64 return d;
65 }
66 if (uv < 0x200000) {
67 *d++ = (( uv >> 18) | 0xf0);
68 *d++ = (((uv >> 12) & 0x3f) | 0x80);
69 *d++ = (((uv >> 6) & 0x3f) | 0x80);
70 *d++ = (( uv & 0x3f) | 0x80);
71 return d;
72 }
73 if (uv < 0x4000000) {
74 *d++ = (( uv >> 24) | 0xf8);
75 *d++ = (((uv >> 18) & 0x3f) | 0x80);
76 *d++ = (((uv >> 12) & 0x3f) | 0x80);
77 *d++ = (((uv >> 6) & 0x3f) | 0x80);
78 *d++ = (( uv & 0x3f) | 0x80);
79 return d;
80 }
81 if (uv < 0x80000000) {
82 *d++ = (( uv >> 30) | 0xfc);
83 *d++ = (((uv >> 24) & 0x3f) | 0x80);
84 *d++ = (((uv >> 18) & 0x3f) | 0x80);
85 *d++ = (((uv >> 12) & 0x3f) | 0x80);
86 *d++ = (((uv >> 6) & 0x3f) | 0x80);
87 *d++ = (( uv & 0x3f) | 0x80);
88 return d;
89 }
6b8eaf93 90#ifdef HAS_QUAD
d7578b48 91 if (uv < UTF8_QUAD_MAX)
a0ed51b3
LW
92#endif
93 {
94 *d++ = 0xfe; /* Can't match U+FEFF! */
95 *d++ = (((uv >> 30) & 0x3f) | 0x80);
96 *d++ = (((uv >> 24) & 0x3f) | 0x80);
97 *d++ = (((uv >> 18) & 0x3f) | 0x80);
98 *d++ = (((uv >> 12) & 0x3f) | 0x80);
99 *d++ = (((uv >> 6) & 0x3f) | 0x80);
100 *d++ = (( uv & 0x3f) | 0x80);
101 return d;
102 }
6b8eaf93 103#ifdef HAS_QUAD
a0ed51b3
LW
104 {
105 *d++ = 0xff; /* Can't match U+FFFE! */
3c77ea2b
GS
106 *d++ = 0x80; /* 6 Reserved bits */
107 *d++ = (((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
108 *d++ = (((uv >> 54) & 0x3f) | 0x80);
109 *d++ = (((uv >> 48) & 0x3f) | 0x80);
110 *d++ = (((uv >> 42) & 0x3f) | 0x80);
a0ed51b3
LW
111 *d++ = (((uv >> 36) & 0x3f) | 0x80);
112 *d++ = (((uv >> 30) & 0x3f) | 0x80);
113 *d++ = (((uv >> 24) & 0x3f) | 0x80);
114 *d++ = (((uv >> 18) & 0x3f) | 0x80);
115 *d++ = (((uv >> 12) & 0x3f) | 0x80);
116 *d++ = (((uv >> 6) & 0x3f) | 0x80);
117 *d++ = (( uv & 0x3f) | 0x80);
118 return d;
119 }
120#endif
121}
122
eebe1485
SC
123/*
124=for apidoc A|STRLEN|is_utf8_char|U8 *s
125
5da9da9e
JH
126Tests if some arbitrary number of bytes begins in a valid UTF-8
127character. Note that an ASCII character is a valid UTF-8 character.
128The actual number of bytes in the UTF-8 character will be returned if
129it is valid, otherwise 0.
eebe1485 130
5da9da9e 131=cut */
067a85ef 132STRLEN
386d01d6
GS
133Perl_is_utf8_char(pTHX_ U8 *s)
134{
135 U8 u = *s;
067a85ef
A
136 STRLEN slen, len;
137 UV uv, ouv;
386d01d6 138
60006e79 139 if (UTF8_IS_ASCII(u))
386d01d6
GS
140 return 1;
141
60006e79 142 if (!UTF8_IS_START(u))
386d01d6
GS
143 return 0;
144
9f07fdcd 145 len = UTF8SKIP(s);
386d01d6 146
60006e79 147 if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
067a85ef
A
148 return 0;
149
386d01d6
GS
150 slen = len - 1;
151 s++;
067a85ef
A
152 uv = u;
153 ouv = uv;
386d01d6 154 while (slen--) {
60006e79 155 if (!UTF8_IS_CONTINUATION(*s))
386d01d6 156 return 0;
8850bf83 157 uv = UTF8_ACCUMULATE(uv, *s);
067a85ef
A
158 if (uv < ouv)
159 return 0;
160 ouv = uv;
386d01d6
GS
161 s++;
162 }
067a85ef 163
5bbb0b5a 164 if (UNISKIP(uv) < len)
067a85ef
A
165 return 0;
166
386d01d6
GS
167 return len;
168}
169
6662521e 170/*
eebe1485 171=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
6662521e 172
5da9da9e
JH
173Returns true if first C<len> bytes of the given string form a valid UTF8
174string, false otherwise. Note that 'a valid UTF8 string' does not mean
175'a string that contains UTF8' because a valid ASCII string is a valid
176UTF8 string.
6662521e
GS
177
178=cut
179*/
180
8e84507e 181bool
6662521e
GS
182Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
183{
067a85ef 184 U8* x = s;
1aa99e6b 185 U8* send;
067a85ef
A
186 STRLEN c;
187
1aa99e6b 188 if (!len)
6cd5fe39 189 len = strlen((char *)s);
1aa99e6b
IH
190 send = s + len;
191
6662521e
GS
192 while (x < send) {
193 c = is_utf8_char(x);
067a85ef
A
194 if (!c)
195 return FALSE;
6662521e 196 x += c;
6662521e 197 }
60006e79
JH
198 if (x != send)
199 return FALSE;
067a85ef
A
200
201 return TRUE;
6662521e
GS
202}
203
67e989fb 204/*
65c50fde 205=for apidoc A|UV|utf8_to_uv|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
67e989fb
JH
206
207Returns the character value of the first character in the string C<s>
ba210ebe 208which is assumed to be in UTF8 encoding and no longer than C<curlen>;
7df053ec 209C<retlen> will be set to the length, in bytes, of that character.
67e989fb
JH
210
211If C<s> does not point to a well-formed UTF8 character, the behaviour
dcad2880
JH
212is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
213it is assumed that the caller will raise a warning, and this function
28d3d195
JH
214will silently just set C<retlen> to C<-1> and return zero. If the
215C<flags> does not contain UTF8_CHECK_ONLY, warnings about
216malformations will be given, C<retlen> will be set to the expected
217length of the UTF-8 character in bytes, and zero will be returned.
218
219The C<flags> can also contain various flags to allow deviations from
220the strict UTF-8 encoding (see F<utf8.h>).
67e989fb 221
dcad2880 222=cut */
67e989fb 223
a0ed51b3 224UV
dcad2880 225Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
a0ed51b3 226{
ba210ebe
JH
227 UV uv = *s, ouv;
228 STRLEN len = 1;
7bf1b6bb
PP
229#ifdef EBCDIC
230 bool dowarn = 0;
231#else
ba210ebe 232 bool dowarn = ckWARN_d(WARN_UTF8);
7bf1b6bb 233#endif
ba210ebe 234 STRLEN expectlen = 0;
a0dbb045
JH
235 U32 warning = 0;
236
237/* This list is a superset of the UTF8_ALLOW_XXX. */
238
239#define UTF8_WARN_EMPTY 1
240#define UTF8_WARN_CONTINUATION 2
241#define UTF8_WARN_NON_CONTINUATION 3
242#define UTF8_WARN_FE_FF 4
243#define UTF8_WARN_SHORT 5
244#define UTF8_WARN_OVERFLOW 6
245#define UTF8_WARN_SURROGATE 7
246#define UTF8_WARN_BOM 8
247#define UTF8_WARN_LONG 9
248#define UTF8_WARN_FFFF 10
249
250 if (curlen == 0 &&
251 !(flags & UTF8_ALLOW_EMPTY)) {
252 warning = UTF8_WARN_EMPTY;
0c443dc2
JH
253 goto malformed;
254 }
255
421a8bf2 256 if (UTF8_IS_ASCII(uv)) {
a0ed51b3
LW
257 if (retlen)
258 *retlen = 1;
3bd709b1 259 return ASCII_TO_NATIVE(*s);
a0ed51b3 260 }
67e989fb 261
421a8bf2 262 if (UTF8_IS_CONTINUATION(uv) &&
fcc8fcf6 263 !(flags & UTF8_ALLOW_CONTINUATION)) {
a0dbb045 264 warning = UTF8_WARN_CONTINUATION;
ba210ebe
JH
265 goto malformed;
266 }
267
421a8bf2 268 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
fcc8fcf6 269 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045 270 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe
JH
271 goto malformed;
272 }
fcc8fcf6
JH
273
274 if ((uv == 0xfe || uv == 0xff) &&
275 !(flags & UTF8_ALLOW_FE_FF)) {
a0dbb045 276 warning = UTF8_WARN_FE_FF;
ba210ebe 277 goto malformed;
a0ed51b3 278 }
fcc8fcf6 279
ba210ebe
JH
280 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
281 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
282 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
283 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
284 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
285 else if (!(uv & 0x01)) { len = 7; uv = 0; }
3c77ea2b 286 else { len = 13; uv = 0; } /* whoa! */
fcc8fcf6 287
a0ed51b3
LW
288 if (retlen)
289 *retlen = len;
ba210ebe
JH
290
291 expectlen = len;
292
fcc8fcf6
JH
293 if ((curlen < expectlen) &&
294 !(flags & UTF8_ALLOW_SHORT)) {
a0dbb045 295 warning = UTF8_WARN_SHORT;
ba210ebe
JH
296 goto malformed;
297 }
298
299 len--;
a0ed51b3 300 s++;
ba210ebe
JH
301 ouv = uv;
302
a0ed51b3 303 while (len--) {
421a8bf2
JH
304 if (!UTF8_IS_CONTINUATION(*s) &&
305 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045
JH
306 s--;
307 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe 308 goto malformed;
a0ed51b3
LW
309 }
310 else
8850bf83 311 uv = UTF8_ACCUMULATE(uv, *s);
a0dbb045
JH
312 if (!(uv > ouv)) {
313 /* These cannot be allowed. */
314 if (uv == ouv) {
315 if (!(flags & UTF8_ALLOW_LONG)) {
316 warning = UTF8_WARN_LONG;
317 goto malformed;
318 }
319 }
320 else { /* uv < ouv */
321 /* This cannot be allowed. */
322 warning = UTF8_WARN_OVERFLOW;
323 goto malformed;
324 }
ba210ebe
JH
325 }
326 s++;
327 ouv = uv;
328 }
329
421a8bf2 330 if (UNICODE_IS_SURROGATE(uv) &&
fcc8fcf6 331 !(flags & UTF8_ALLOW_SURROGATE)) {
a0dbb045 332 warning = UTF8_WARN_SURROGATE;
ba210ebe 333 goto malformed;
421a8bf2 334 } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
fcc8fcf6 335 !(flags & UTF8_ALLOW_BOM)) {
a0dbb045 336 warning = UTF8_WARN_BOM;
ba210ebe 337 goto malformed;
fcc8fcf6
JH
338 } else if ((expectlen > UNISKIP(uv)) &&
339 !(flags & UTF8_ALLOW_LONG)) {
a0dbb045 340 warning = UTF8_WARN_LONG;
ba210ebe 341 goto malformed;
421a8bf2 342 } else if (UNICODE_IS_ILLEGAL(uv) &&
a9917092 343 !(flags & UTF8_ALLOW_FFFF)) {
a0dbb045 344 warning = UTF8_WARN_FFFF;
a9917092 345 goto malformed;
a0ed51b3 346 }
ba210ebe 347
a0ed51b3 348 return uv;
ba210ebe
JH
349
350malformed:
351
fcc8fcf6 352 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 353 if (retlen)
cc366d4b 354 *retlen = -1;
ba210ebe
JH
355 return 0;
356 }
357
a0dbb045
JH
358 if (dowarn) {
359 SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
360
361 switch (warning) {
362 case 0: /* Intentionally empty. */ break;
363 case UTF8_WARN_EMPTY:
364 Perl_sv_catpvf(aTHX_ sv, "(empty string)");
365 break;
366 case UTF8_WARN_CONTINUATION:
367 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
368 break;
369 case UTF8_WARN_NON_CONTINUATION:
370 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
371 (UV)s[1], uv);
372 break;
373 case UTF8_WARN_FE_FF:
374 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
375 break;
376 case UTF8_WARN_SHORT:
377 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
378 curlen, curlen == 1 ? "" : "s", expectlen);
379 break;
380 case UTF8_WARN_OVERFLOW:
381 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
382 ouv, *s);
383 break;
384 case UTF8_WARN_SURROGATE:
385 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
386 break;
387 case UTF8_WARN_BOM:
388 Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
389 break;
390 case UTF8_WARN_LONG:
391 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
392 expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
393 break;
394 case UTF8_WARN_FFFF:
395 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
396 break;
397 default:
398 Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
399 break;
400 }
401
402 if (warning) {
403 char *s = SvPVX(sv);
404
405 if (PL_op)
406 Perl_warner(aTHX_ WARN_UTF8,
407 "%s in %s", s, PL_op_desc[PL_op->op_type]);
408 else
409 Perl_warner(aTHX_ WARN_UTF8, "%s", s);
410 }
411 }
412
ba210ebe 413 if (retlen)
28d3d195 414 *retlen = expectlen ? expectlen : len;
ba210ebe 415
28d3d195 416 return 0;
a0ed51b3
LW
417}
418
8e84507e 419/*
eebe1485 420=for apidoc A|U8* s|utf8_to_uv_simple|STRLEN *retlen
8e84507e
NIS
421
422Returns the character value of the first character in the string C<s>
423which is assumed to be in UTF8 encoding; C<retlen> will be set to the
7df053ec 424length, in bytes, of that character.
8e84507e 425
ba210ebe
JH
426If C<s> does not point to a well-formed UTF8 character, zero is
427returned and retlen is set, if possible, to -1.
8e84507e
NIS
428
429=cut
430*/
431
432UV
dcad2880 433Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
8e84507e 434{
2e4dc9fc 435 return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0);
8e84507e
NIS
436}
437
b76347f2 438/*
eebe1485 439=for apidoc A|STRLEN|utf8_length|U8* s|U8 *e
b76347f2
JH
440
441Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
442Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
443up past C<e>, croaks.
b76347f2
JH
444
445=cut
446*/
447
448STRLEN
449Perl_utf8_length(pTHX_ U8* s, U8* e)
450{
451 STRLEN len = 0;
452
8850bf83
JH
453 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
454 * the bitops (especially ~) can create illegal UTF-8.
455 * In other words: in Perl UTF-8 is not just for Unicode. */
456
b76347f2 457 if (e < s)
02eb7b47 458 Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
b76347f2 459 while (s < e) {
02eb7b47 460 U8 t = UTF8SKIP(s);
b76347f2
JH
461
462 if (e - s < t)
02eb7b47 463 Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
b76347f2
JH
464 s += t;
465 len++;
466 }
467
468 return len;
469}
470
b06226ff 471/*
eebe1485 472=for apidoc A|IV|utf8_distance|U8 *a|U8 *b
b06226ff
JH
473
474Returns the number of UTF8 characters between the UTF-8 pointers C<a>
475and C<b>.
476
477WARNING: use only if you *know* that the pointers point inside the
478same UTF-8 buffer.
479
480=cut */
a0ed51b3 481
02eb7b47 482IV
864dbfa3 483Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
a0ed51b3 484{
02eb7b47
JH
485 IV off = 0;
486
8850bf83
JH
487 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
488 * the bitops (especially ~) can create illegal UTF-8.
489 * In other words: in Perl UTF-8 is not just for Unicode. */
490
a0ed51b3
LW
491 if (a < b) {
492 while (a < b) {
02eb7b47
JH
493 U8 c = UTF8SKIP(a);
494
495 if (b - a < c)
496 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
497 a += c;
a0ed51b3
LW
498 off--;
499 }
500 }
501 else {
502 while (b < a) {
02eb7b47
JH
503 U8 c = UTF8SKIP(b);
504
505 if (a - b < c)
506 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
507 b += c;
a0ed51b3
LW
508 off++;
509 }
510 }
02eb7b47 511
a0ed51b3
LW
512 return off;
513}
514
b06226ff 515/*
eebe1485 516=for apidoc A|U8*|utf8_hop|U8 *s|I32 off
b06226ff 517
8850bf83
JH
518Return the UTF-8 pointer C<s> displaced by C<off> characters, either
519forward or backward.
b06226ff
JH
520
521WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
522the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
523on the first byte of character or just after the last byte of a character.
b06226ff
JH
524
525=cut */
a0ed51b3
LW
526
527U8 *
864dbfa3 528Perl_utf8_hop(pTHX_ U8 *s, I32 off)
a0ed51b3 529{
8850bf83
JH
530 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
531 * the bitops (especially ~) can create illegal UTF-8.
532 * In other words: in Perl UTF-8 is not just for Unicode. */
533
a0ed51b3
LW
534 if (off >= 0) {
535 while (off--)
536 s += UTF8SKIP(s);
537 }
538 else {
539 while (off++) {
540 s--;
8850bf83
JH
541 while (UTF8_IS_CONTINUATION(*s))
542 s--;
a0ed51b3
LW
543 }
544 }
545 return s;
546}
547
6940069f 548/*
eebe1485 549=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
6940069f 550
246fae53
MG
551Converts a string C<s> of length C<len> from UTF8 into byte encoding.
552Unlike C<bytes_to_utf8>, this over-writes the original string, and
553updates len to contain the new length.
67e989fb 554Returns zero on failure, setting C<len> to -1.
6940069f
GS
555
556=cut
557*/
558
559U8 *
246fae53 560Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
6940069f 561{
6940069f
GS
562 U8 *send;
563 U8 *d;
dcad2880 564 U8 *save = s;
246fae53
MG
565
566 /* ensure valid UTF8 and chars < 256 before updating string */
dcad2880
JH
567 for (send = s + *len; s < send; ) {
568 U8 c = *s++;
569
9f9ab905 570 if (c >= 0x80 &&
dcad2880
JH
571 ((s >= send) ||
572 ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
573 *len = -1;
574 return 0;
575 }
246fae53 576 }
dcad2880
JH
577
578 d = s = save;
6940069f 579 while (s < send) {
ed646e6e
SC
580 STRLEN ulen;
581 *d++ = (U8)utf8_to_uv_simple(s, &ulen);
582 s += ulen;
6940069f
GS
583 }
584 *d = '\0';
246fae53 585 *len = d - save;
6940069f
GS
586 return save;
587}
588
589/*
f9a63242
JH
590=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
591
592Converts a string C<s> of length C<len> from UTF8 into byte encoding.
593Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
594the newly-created string, and updates C<len> to contain the new
595length. Returns the original string if no conversion occurs, C<len>
596is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
5970 if C<s> is converted or contains all 7bit characters.
f9a63242
JH
598
599=cut */
600
601U8 *
602Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8)
603{
604 U8 *send;
605 U8 *d;
606 U8 *start = s;
607 I32 count = 0;
608
609 if (!*is_utf8)
610 return start;
611
ef9edfd0 612 /* ensure valid UTF8 and chars < 256 before converting string */
f9a63242
JH
613 for (send = s + *len; s < send;) {
614 U8 c = *s++;
615 if (!UTF8_IS_ASCII(c)) {
616 if (UTF8_IS_CONTINUATION(c) || s >= send ||
df84a23b 617 !UTF8_IS_CONTINUATION(*s) || UTF8_IS_DOWNGRADEABLE_START(c))
f9a63242
JH
618 return start;
619 s++, count++;
620 }
621 }
622
623 *is_utf8 = 0;
624
625 if (!count)
626 return start;
627
628 Newz(801, d, (*len) - count + 1, U8);
ef9edfd0 629 s = start; start = d;
f9a63242
JH
630 while (s < send) {
631 U8 c = *s++;
90f44359 632
f9a63242
JH
633 if (UTF8_IS_ASCII(c))
634 *d++ = c;
635 else
90f44359 636 *d++ = UTF8_ACCUMULATE(c, *s++);
f9a63242
JH
637 }
638 *d = '\0';
639 *len = d - start;
640 return start;
641}
642
643/*
eebe1485 644=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
6940069f
GS
645
646Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
6662521e
GS
647Returns a pointer to the newly-created string, and sets C<len> to
648reflect the new length.
6940069f 649
497711e7 650=cut
6940069f
GS
651*/
652
653U8*
6662521e 654Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
6940069f 655{
6940069f
GS
656 U8 *send;
657 U8 *d;
658 U8 *dst;
6662521e 659 send = s + (*len);
6940069f 660
6662521e 661 Newz(801, d, (*len) * 2 + 1, U8);
6940069f
GS
662 dst = d;
663
664 while (s < send) {
90f44359 665 if (UTF8_IS_ASCII(*s))
6940069f
GS
666 *d++ = *s++;
667 else {
668 UV uv = *s++;
90f44359
JH
669
670 *d++ = UTF8_EIGHT_BIT_HI(uv);
671 *d++ = UTF8_EIGHT_BIT_LO(uv);
6940069f
GS
672 }
673 }
674 *d = '\0';
6662521e 675 *len = d-dst;
6940069f
GS
676 return dst;
677}
678
a0ed51b3 679/*
dea0fc0b 680 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
681 *
682 * Destination must be pre-extended to 3/2 source. Do not use in-place.
683 * We optimize for native, for obvious reasons. */
684
685U8*
dea0fc0b 686Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 687{
dea0fc0b
JH
688 U8* pend;
689 U8* dstart = d;
690
691 if (bytelen & 1)
a7867d0a 692 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
dea0fc0b
JH
693
694 pend = p + bytelen;
695
a0ed51b3 696 while (p < pend) {
dea0fc0b
JH
697 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
698 p += 2;
a0ed51b3
LW
699 if (uv < 0x80) {
700 *d++ = uv;
701 continue;
702 }
703 if (uv < 0x800) {
704 *d++ = (( uv >> 6) | 0xc0);
705 *d++ = (( uv & 0x3f) | 0x80);
706 continue;
707 }
708 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
dea0fc0b
JH
709 UV low = *p++;
710 if (low < 0xdc00 || low >= 0xdfff)
711 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
a0ed51b3
LW
712 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
713 }
714 if (uv < 0x10000) {
715 *d++ = (( uv >> 12) | 0xe0);
716 *d++ = (((uv >> 6) & 0x3f) | 0x80);
717 *d++ = (( uv & 0x3f) | 0x80);
718 continue;
719 }
720 else {
721 *d++ = (( uv >> 18) | 0xf0);
722 *d++ = (((uv >> 12) & 0x3f) | 0x80);
723 *d++ = (((uv >> 6) & 0x3f) | 0x80);
724 *d++ = (( uv & 0x3f) | 0x80);
725 continue;
726 }
727 }
dea0fc0b 728 *newlen = d - dstart;
a0ed51b3
LW
729 return d;
730}
731
732/* Note: this one is slightly destructive of the source. */
733
734U8*
dea0fc0b 735Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
736{
737 U8* s = (U8*)p;
738 U8* send = s + bytelen;
739 while (s < send) {
740 U8 tmp = s[0];
741 s[0] = s[1];
742 s[1] = tmp;
743 s += 2;
744 }
dea0fc0b 745 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
746}
747
748/* for now these are all defined (inefficiently) in terms of the utf8 versions */
749
750bool
864dbfa3 751Perl_is_uni_alnum(pTHX_ U32 c)
a0ed51b3 752{
ad391ad9 753 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
754 uv_to_utf8(tmpbuf, (UV)c);
755 return is_utf8_alnum(tmpbuf);
756}
757
758bool
b8c5462f
JH
759Perl_is_uni_alnumc(pTHX_ U32 c)
760{
ad391ad9 761 U8 tmpbuf[UTF8_MAXLEN+1];
b8c5462f
JH
762 uv_to_utf8(tmpbuf, (UV)c);
763 return is_utf8_alnumc(tmpbuf);
764}
765
766bool
864dbfa3 767Perl_is_uni_idfirst(pTHX_ U32 c)
a0ed51b3 768{
ad391ad9 769 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
770 uv_to_utf8(tmpbuf, (UV)c);
771 return is_utf8_idfirst(tmpbuf);
772}
773
774bool
864dbfa3 775Perl_is_uni_alpha(pTHX_ U32 c)
a0ed51b3 776{
ad391ad9 777 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
778 uv_to_utf8(tmpbuf, (UV)c);
779 return is_utf8_alpha(tmpbuf);
780}
781
782bool
4d61ec05
GS
783Perl_is_uni_ascii(pTHX_ U32 c)
784{
ad391ad9 785 U8 tmpbuf[UTF8_MAXLEN+1];
4d61ec05
GS
786 uv_to_utf8(tmpbuf, (UV)c);
787 return is_utf8_ascii(tmpbuf);
788}
789
790bool
864dbfa3 791Perl_is_uni_space(pTHX_ U32 c)
a0ed51b3 792{
ad391ad9 793 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
794 uv_to_utf8(tmpbuf, (UV)c);
795 return is_utf8_space(tmpbuf);
796}
797
798bool
864dbfa3 799Perl_is_uni_digit(pTHX_ U32 c)
a0ed51b3 800{
ad391ad9 801 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
802 uv_to_utf8(tmpbuf, (UV)c);
803 return is_utf8_digit(tmpbuf);
804}
805
806bool
864dbfa3 807Perl_is_uni_upper(pTHX_ U32 c)
a0ed51b3 808{
ad391ad9 809 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
810 uv_to_utf8(tmpbuf, (UV)c);
811 return is_utf8_upper(tmpbuf);
812}
813
814bool
864dbfa3 815Perl_is_uni_lower(pTHX_ U32 c)
a0ed51b3 816{
ad391ad9 817 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
818 uv_to_utf8(tmpbuf, (UV)c);
819 return is_utf8_lower(tmpbuf);
820}
821
822bool
b8c5462f
JH
823Perl_is_uni_cntrl(pTHX_ U32 c)
824{
ad391ad9 825 U8 tmpbuf[UTF8_MAXLEN+1];
b8c5462f
JH
826 uv_to_utf8(tmpbuf, (UV)c);
827 return is_utf8_cntrl(tmpbuf);
828}
829
830bool
831Perl_is_uni_graph(pTHX_ U32 c)
832{
ad391ad9 833 U8 tmpbuf[UTF8_MAXLEN+1];
b8c5462f
JH
834 uv_to_utf8(tmpbuf, (UV)c);
835 return is_utf8_graph(tmpbuf);
836}
837
838bool
864dbfa3 839Perl_is_uni_print(pTHX_ U32 c)
a0ed51b3 840{
ad391ad9 841 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
842 uv_to_utf8(tmpbuf, (UV)c);
843 return is_utf8_print(tmpbuf);
844}
845
b8c5462f 846bool
f248d071 847Perl_is_uni_punct(pTHX_ U32 c)
b8c5462f 848{
ad391ad9 849 U8 tmpbuf[UTF8_MAXLEN+1];
b8c5462f
JH
850 uv_to_utf8(tmpbuf, (UV)c);
851 return is_utf8_punct(tmpbuf);
852}
853
4d61ec05
GS
854bool
855Perl_is_uni_xdigit(pTHX_ U32 c)
856{
ad391ad9 857 U8 tmpbuf[UTF8_MAXLEN+1];
4d61ec05
GS
858 uv_to_utf8(tmpbuf, (UV)c);
859 return is_utf8_xdigit(tmpbuf);
860}
861
a0ed51b3 862U32
864dbfa3 863Perl_to_uni_upper(pTHX_ U32 c)
a0ed51b3 864{
ad391ad9 865 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
866 uv_to_utf8(tmpbuf, (UV)c);
867 return to_utf8_upper(tmpbuf);
868}
869
870U32
864dbfa3 871Perl_to_uni_title(pTHX_ U32 c)
a0ed51b3 872{
ad391ad9 873 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
874 uv_to_utf8(tmpbuf, (UV)c);
875 return to_utf8_title(tmpbuf);
876}
877
878U32
864dbfa3 879Perl_to_uni_lower(pTHX_ U32 c)
a0ed51b3 880{
ad391ad9 881 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3
LW
882 uv_to_utf8(tmpbuf, (UV)c);
883 return to_utf8_lower(tmpbuf);
884}
885
886/* for now these all assume no locale info available for Unicode > 255 */
887
888bool
864dbfa3 889Perl_is_uni_alnum_lc(pTHX_ U32 c)
a0ed51b3
LW
890{
891 return is_uni_alnum(c); /* XXX no locale support yet */
892}
893
894bool
b8c5462f
JH
895Perl_is_uni_alnumc_lc(pTHX_ U32 c)
896{
897 return is_uni_alnumc(c); /* XXX no locale support yet */
898}
899
900bool
864dbfa3 901Perl_is_uni_idfirst_lc(pTHX_ U32 c)
a0ed51b3
LW
902{
903 return is_uni_idfirst(c); /* XXX no locale support yet */
904}
905
906bool
864dbfa3 907Perl_is_uni_alpha_lc(pTHX_ U32 c)
a0ed51b3
LW
908{
909 return is_uni_alpha(c); /* XXX no locale support yet */
910}
911
912bool
4d61ec05
GS
913Perl_is_uni_ascii_lc(pTHX_ U32 c)
914{
915 return is_uni_ascii(c); /* XXX no locale support yet */
916}
917
918bool
864dbfa3 919Perl_is_uni_space_lc(pTHX_ U32 c)
a0ed51b3
LW
920{
921 return is_uni_space(c); /* XXX no locale support yet */
922}
923
924bool
864dbfa3 925Perl_is_uni_digit_lc(pTHX_ U32 c)
a0ed51b3
LW
926{
927 return is_uni_digit(c); /* XXX no locale support yet */
928}
929
930bool
864dbfa3 931Perl_is_uni_upper_lc(pTHX_ U32 c)
a0ed51b3
LW
932{
933 return is_uni_upper(c); /* XXX no locale support yet */
934}
935
936bool
864dbfa3 937Perl_is_uni_lower_lc(pTHX_ U32 c)
a0ed51b3
LW
938{
939 return is_uni_lower(c); /* XXX no locale support yet */
940}
941
942bool
b8c5462f
JH
943Perl_is_uni_cntrl_lc(pTHX_ U32 c)
944{
945 return is_uni_cntrl(c); /* XXX no locale support yet */
946}
947
948bool
949Perl_is_uni_graph_lc(pTHX_ U32 c)
950{
951 return is_uni_graph(c); /* XXX no locale support yet */
952}
953
954bool
864dbfa3 955Perl_is_uni_print_lc(pTHX_ U32 c)
a0ed51b3
LW
956{
957 return is_uni_print(c); /* XXX no locale support yet */
958}
959
b8c5462f
JH
960bool
961Perl_is_uni_punct_lc(pTHX_ U32 c)
962{
963 return is_uni_punct(c); /* XXX no locale support yet */
964}
965
4d61ec05
GS
966bool
967Perl_is_uni_xdigit_lc(pTHX_ U32 c)
968{
969 return is_uni_xdigit(c); /* XXX no locale support yet */
970}
971
a0ed51b3 972U32
864dbfa3 973Perl_to_uni_upper_lc(pTHX_ U32 c)
a0ed51b3
LW
974{
975 return to_uni_upper(c); /* XXX no locale support yet */
976}
977
978U32
864dbfa3 979Perl_to_uni_title_lc(pTHX_ U32 c)
a0ed51b3
LW
980{
981 return to_uni_title(c); /* XXX no locale support yet */
982}
983
984U32
864dbfa3 985Perl_to_uni_lower_lc(pTHX_ U32 c)
a0ed51b3
LW
986{
987 return to_uni_lower(c); /* XXX no locale support yet */
988}
989
a0ed51b3 990bool
864dbfa3 991Perl_is_utf8_alnum(pTHX_ U8 *p)
a0ed51b3 992{
386d01d6
GS
993 if (!is_utf8_char(p))
994 return FALSE;
a0ed51b3 995 if (!PL_utf8_alnum)
289d4f09
ML
996 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
997 * descendant of isalnum(3), in other words, it doesn't
998 * contain the '_'. --jhi */
999 PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1000 return swash_fetch(PL_utf8_alnum, p);
1001/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1002#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1003 if (!PL_utf8_alnum)
1004 PL_utf8_alnum = swash_init("utf8", "",
1005 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1006 return swash_fetch(PL_utf8_alnum, p);
1007#endif
1008}
1009
1010bool
b8c5462f
JH
1011Perl_is_utf8_alnumc(pTHX_ U8 *p)
1012{
386d01d6
GS
1013 if (!is_utf8_char(p))
1014 return FALSE;
b8c5462f
JH
1015 if (!PL_utf8_alnum)
1016 PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1017 return swash_fetch(PL_utf8_alnum, p);
1018/* return is_utf8_alpha(p) || is_utf8_digit(p); */
1019#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1020 if (!PL_utf8_alnum)
1021 PL_utf8_alnum = swash_init("utf8", "",
1022 sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1023 return swash_fetch(PL_utf8_alnum, p);
1024#endif
1025}
1026
1027bool
864dbfa3 1028Perl_is_utf8_idfirst(pTHX_ U8 *p)
a0ed51b3
LW
1029{
1030 return *p == '_' || is_utf8_alpha(p);
1031}
1032
1033bool
864dbfa3 1034Perl_is_utf8_alpha(pTHX_ U8 *p)
a0ed51b3 1035{
386d01d6
GS
1036 if (!is_utf8_char(p))
1037 return FALSE;
a0ed51b3 1038 if (!PL_utf8_alpha)
e24b16f9 1039 PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1040 return swash_fetch(PL_utf8_alpha, p);
1041}
1042
1043bool
b8c5462f
JH
1044Perl_is_utf8_ascii(pTHX_ U8 *p)
1045{
386d01d6
GS
1046 if (!is_utf8_char(p))
1047 return FALSE;
b8c5462f
JH
1048 if (!PL_utf8_ascii)
1049 PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1050 return swash_fetch(PL_utf8_ascii, p);
1051}
1052
1053bool
864dbfa3 1054Perl_is_utf8_space(pTHX_ U8 *p)
a0ed51b3 1055{
386d01d6
GS
1056 if (!is_utf8_char(p))
1057 return FALSE;
a0ed51b3 1058 if (!PL_utf8_space)
3bec3564 1059 PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1060 return swash_fetch(PL_utf8_space, p);
1061}
1062
1063bool
864dbfa3 1064Perl_is_utf8_digit(pTHX_ U8 *p)
a0ed51b3 1065{
386d01d6
GS
1066 if (!is_utf8_char(p))
1067 return FALSE;
a0ed51b3 1068 if (!PL_utf8_digit)
e24b16f9 1069 PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1070 return swash_fetch(PL_utf8_digit, p);
1071}
1072
1073bool
864dbfa3 1074Perl_is_utf8_upper(pTHX_ U8 *p)
a0ed51b3 1075{
386d01d6
GS
1076 if (!is_utf8_char(p))
1077 return FALSE;
a0ed51b3 1078 if (!PL_utf8_upper)
e24b16f9 1079 PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1080 return swash_fetch(PL_utf8_upper, p);
1081}
1082
1083bool
864dbfa3 1084Perl_is_utf8_lower(pTHX_ U8 *p)
a0ed51b3 1085{
386d01d6
GS
1086 if (!is_utf8_char(p))
1087 return FALSE;
a0ed51b3 1088 if (!PL_utf8_lower)
e24b16f9 1089 PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1090 return swash_fetch(PL_utf8_lower, p);
1091}
1092
1093bool
b8c5462f
JH
1094Perl_is_utf8_cntrl(pTHX_ U8 *p)
1095{
386d01d6
GS
1096 if (!is_utf8_char(p))
1097 return FALSE;
b8c5462f
JH
1098 if (!PL_utf8_cntrl)
1099 PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1100 return swash_fetch(PL_utf8_cntrl, p);
1101}
1102
1103bool
1104Perl_is_utf8_graph(pTHX_ U8 *p)
1105{
386d01d6
GS
1106 if (!is_utf8_char(p))
1107 return FALSE;
b8c5462f
JH
1108 if (!PL_utf8_graph)
1109 PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1110 return swash_fetch(PL_utf8_graph, p);
1111}
1112
1113bool
864dbfa3 1114Perl_is_utf8_print(pTHX_ U8 *p)
a0ed51b3 1115{
386d01d6
GS
1116 if (!is_utf8_char(p))
1117 return FALSE;
a0ed51b3 1118 if (!PL_utf8_print)
e24b16f9 1119 PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1120 return swash_fetch(PL_utf8_print, p);
1121}
1122
1123bool
b8c5462f
JH
1124Perl_is_utf8_punct(pTHX_ U8 *p)
1125{
386d01d6
GS
1126 if (!is_utf8_char(p))
1127 return FALSE;
b8c5462f
JH
1128 if (!PL_utf8_punct)
1129 PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1130 return swash_fetch(PL_utf8_punct, p);
1131}
1132
1133bool
1134Perl_is_utf8_xdigit(pTHX_ U8 *p)
1135{
386d01d6
GS
1136 if (!is_utf8_char(p))
1137 return FALSE;
b8c5462f
JH
1138 if (!PL_utf8_xdigit)
1139 PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1140 return swash_fetch(PL_utf8_xdigit, p);
1141}
1142
1143bool
864dbfa3 1144Perl_is_utf8_mark(pTHX_ U8 *p)
a0ed51b3 1145{
386d01d6
GS
1146 if (!is_utf8_char(p))
1147 return FALSE;
a0ed51b3 1148 if (!PL_utf8_mark)
e24b16f9 1149 PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
a0ed51b3
LW
1150 return swash_fetch(PL_utf8_mark, p);
1151}
1152
2104c8d9 1153UV
864dbfa3 1154Perl_to_utf8_upper(pTHX_ U8 *p)
a0ed51b3
LW
1155{
1156 UV uv;
1157
1158 if (!PL_utf8_toupper)
e24b16f9 1159 PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
a0ed51b3 1160 uv = swash_fetch(PL_utf8_toupper, p);
756820e3 1161 return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
a0ed51b3
LW
1162}
1163
2104c8d9 1164UV
864dbfa3 1165Perl_to_utf8_title(pTHX_ U8 *p)
a0ed51b3
LW
1166{
1167 UV uv;
1168
1169 if (!PL_utf8_totitle)
e24b16f9 1170 PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
a0ed51b3 1171 uv = swash_fetch(PL_utf8_totitle, p);
756820e3 1172 return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
a0ed51b3
LW
1173}
1174
2104c8d9 1175UV
864dbfa3 1176Perl_to_utf8_lower(pTHX_ U8 *p)
a0ed51b3
LW
1177{
1178 UV uv;
1179
1180 if (!PL_utf8_tolower)
e24b16f9 1181 PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
a0ed51b3 1182 uv = swash_fetch(PL_utf8_tolower, p);
756820e3 1183 return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
a0ed51b3
LW
1184}
1185
1186/* a "swash" is a swatch hash */
1187
1188SV*
864dbfa3 1189Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3
LW
1190{
1191 SV* retval;
bf1fed83 1192 SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
8e84507e 1193 dSP;
ce3b816e
GS
1194
1195 if (!gv_stashpv(pkg, 0)) { /* demand load utf8 */
1196 ENTER;
1197 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1198 LEAVE;
1199 }
1200 SPAGAIN;
a0ed51b3
LW
1201 PUSHSTACKi(PERLSI_MAGIC);
1202 PUSHMARK(SP);
1203 EXTEND(SP,5);
1204 PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1205 PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1206 PUSHs(listsv);
1207 PUSHs(sv_2mortal(newSViv(minbits)));
1208 PUSHs(sv_2mortal(newSViv(none)));
1209 PUTBACK;
1210 ENTER;
1211 SAVEI32(PL_hints);
1212 PL_hints = 0;
1213 save_re_context();
bf1fed83
JH
1214 if (PL_curcop == &PL_compiling)
1215 /* XXX ought to be handled by lex_start */
1216 sv_setpv(tokenbufsv, PL_tokenbuf);
864dbfa3 1217 if (call_method("SWASHNEW", G_SCALAR))
8e84507e 1218 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1219 else
e24b16f9 1220 retval = &PL_sv_undef;
a0ed51b3
LW
1221 LEAVE;
1222 POPSTACK;
e24b16f9 1223 if (PL_curcop == &PL_compiling) {
bf1fed83
JH
1224 STRLEN len;
1225 char* pv = SvPV(tokenbufsv, len);
1226
1227 Copy(pv, PL_tokenbuf, len+1, char);
e24b16f9 1228 PL_curcop->op_private = PL_hints;
a0ed51b3
LW
1229 }
1230 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
cea2e8a9 1231 Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
a0ed51b3
LW
1232 return retval;
1233}
1234
1235UV
864dbfa3 1236Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
a0ed51b3
LW
1237{
1238 HV* hv = (HV*)SvRV(sv);
1239 U32 klen = UTF8SKIP(ptr) - 1;
1240 U32 off = ptr[klen] & 127; /* NB: 64 bit always 0 when len > 1 */
1241 STRLEN slen;
1242 STRLEN needents = (klen ? 64 : 128);
dfe13c55 1243 U8 *tmps;
a0ed51b3
LW
1244 U32 bit;
1245 SV *retval;
1246
1247 /*
1248 * This single-entry cache saves about 1/3 of the utf8 overhead in test
1249 * suite. (That is, only 7-8% overall over just a hash cache. Still,
1250 * it's nothing to sniff at.) Pity we usually come through at least
1251 * two function calls to get here...
1252 *
1253 * NB: this code assumes that swatches are never modified, once generated!
1254 */
1255
1256 if (hv == PL_last_swash_hv &&
1257 klen == PL_last_swash_klen &&
12ae5dfc 1258 (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
a0ed51b3
LW
1259 {
1260 tmps = PL_last_swash_tmps;
1261 slen = PL_last_swash_slen;
1262 }
1263 else {
1264 /* Try our second-level swatch cache, kept in a hash. */
dfe13c55 1265 SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
a0ed51b3
LW
1266
1267 /* If not cached, generate it via utf8::SWASHGET */
dfe13c55 1268 if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
a0ed51b3
LW
1269 dSP;
1270 ENTER;
1271 SAVETMPS;
1272 save_re_context();
1273 PUSHSTACKi(PERLSI_MAGIC);
1274 PUSHMARK(SP);
1275 EXTEND(SP,3);
1276 PUSHs((SV*)sv);
756820e3 1277 PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1))));
a0ed51b3
LW
1278 PUSHs(sv_2mortal(newSViv(needents)));
1279 PUTBACK;
864dbfa3 1280 if (call_method("SWASHGET", G_SCALAR))
8e84507e 1281 retval = newSVsv(*PL_stack_sp--);
a0ed51b3 1282 else
e24b16f9 1283 retval = &PL_sv_undef;
a0ed51b3
LW
1284 POPSTACK;
1285 FREETMPS;
1286 LEAVE;
e24b16f9
GS
1287 if (PL_curcop == &PL_compiling)
1288 PL_curcop->op_private = PL_hints;
a0ed51b3 1289
dfe13c55 1290 svp = hv_store(hv, (char*)ptr, klen, retval, 0);
a0ed51b3 1291
dfe13c55 1292 if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
cea2e8a9 1293 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
a0ed51b3
LW
1294 }
1295
1296 PL_last_swash_hv = hv;
1297 PL_last_swash_klen = klen;
1298 PL_last_swash_tmps = tmps;
1299 PL_last_swash_slen = slen;
1300 if (klen)
1301 Copy(ptr, PL_last_swash_key, klen, U8);
1302 }
1303
9faf8d75 1304 switch ((int)((slen << 3) / needents)) {
a0ed51b3
LW
1305 case 1:
1306 bit = 1 << (off & 7);
1307 off >>= 3;
1308 return (tmps[off] & bit) != 0;
1309 case 8:
1310 return tmps[off];
1311 case 16:
1312 off <<= 1;
1313 return (tmps[off] << 8) + tmps[off + 1] ;
1314 case 32:
1315 off <<= 2;
1316 return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1317 }
cea2e8a9 1318 Perl_croak(aTHX_ "panic: swash_fetch");
a0ed51b3
LW
1319 return 0;
1320}