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