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