This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Speed up utf8.c a bit
[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))
3c614e38
AD
286 c = 0;
287 }
288 else
289 c = is_utf8_char_slow(x, c);
646ca15d
JH
290#else
291 c = is_utf8_char(x);
292#endif /* #ifdef IS_UTF8_CHAR */
1acdb0da 293 if (!c)
768c67ee 294 goto out;
1acdb0da 295 }
6662521e 296 x += c;
6662521e 297 }
768c67ee
JH
298
299 out:
60006e79
JH
300 if (x != send)
301 return FALSE;
067a85ef
A
302
303 return TRUE;
6662521e
GS
304}
305
67e989fb 306/*
814fafa7
NC
307Implemented as a macro in utf8.h
308
309=for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **ep
310
311Like is_utf8_string() but stores the location of the failure (in the
312case of "utf8ness failure") or the location s+len (in the case of
313"utf8ness success") in the C<ep>.
314
315See also is_utf8_string_loclen() and is_utf8_string().
316
768c67ee 317=for apidoc A|bool|is_utf8_string_loclen|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el
81cd54e3 318
e3e4599f 319Like is_utf8_string() but stores the location of the failure (in the
768c67ee
JH
320case of "utf8ness failure") or the location s+len (in the case of
321"utf8ness success") in the C<ep>, and the number of UTF-8
322encoded characters in the C<el>.
323
324See also is_utf8_string_loc() and is_utf8_string().
81cd54e3
JH
325
326=cut
327*/
328
329bool
768c67ee 330Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
81cd54e3 331{
7fc63493
AL
332 const U8* x = s;
333 const U8* send;
81cd54e3 334 STRLEN c;
3ebfea28 335 STRLEN outlen = 0;
96a5add6 336 PERL_UNUSED_CONTEXT;
81cd54e3 337
44f8325f 338 if (!len)
e1ec3a88 339 len = strlen((const char *)s);
81cd54e3
JH
340 send = s + len;
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 363 x += c;
3ebfea28 364 outlen++;
81cd54e3 365 }
768c67ee
JH
366
367 out:
3ebfea28
AL
368 if (el)
369 *el = outlen;
370
768c67ee
JH
371 if (ep)
372 *ep = x;
3ebfea28 373 return (x == send);
81cd54e3
JH
374}
375
376/*
768c67ee 377
7fc63493 378=for apidoc A|UV|utf8n_to_uvuni|const U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
67e989fb 379
9041c2e3
NIS
380Bottom level UTF-8 decode routine.
381Returns the unicode code point value of the first character in the string C<s>
1e54db1a 382which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
7df053ec 383C<retlen> will be set to the length, in bytes, of that character.
67e989fb 384
1e54db1a 385If C<s> does not point to a well-formed UTF-8 character, the behaviour
dcad2880
JH
386is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
387it is assumed that the caller will raise a warning, and this function
28d3d195
JH
388will silently just set C<retlen> to C<-1> and return zero. If the
389C<flags> does not contain UTF8_CHECK_ONLY, warnings about
390malformations will be given, C<retlen> will be set to the expected
391length of the UTF-8 character in bytes, and zero will be returned.
392
393The C<flags> can also contain various flags to allow deviations from
394the strict UTF-8 encoding (see F<utf8.h>).
67e989fb 395
9041c2e3
NIS
396Most code should use utf8_to_uvchr() rather than call this directly.
397
37607a96
PK
398=cut
399*/
67e989fb 400
a0ed51b3 401UV
7fc63493 402Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 403{
97aff369 404 dVAR;
d4c19fe8 405 const U8 * const s0 = s;
9c5ffd7c 406 UV uv = *s, ouv = 0;
ba210ebe 407 STRLEN len = 1;
7fc63493
AL
408 const bool dowarn = ckWARN_d(WARN_UTF8);
409 const UV startbyte = *s;
ba210ebe 410 STRLEN expectlen = 0;
a0dbb045
JH
411 U32 warning = 0;
412
413/* This list is a superset of the UTF8_ALLOW_XXX. */
414
415#define UTF8_WARN_EMPTY 1
416#define UTF8_WARN_CONTINUATION 2
417#define UTF8_WARN_NON_CONTINUATION 3
418#define UTF8_WARN_FE_FF 4
419#define UTF8_WARN_SHORT 5
420#define UTF8_WARN_OVERFLOW 6
421#define UTF8_WARN_SURROGATE 7
c867b360
JH
422#define UTF8_WARN_LONG 8
423#define UTF8_WARN_FFFF 9 /* Also FFFE. */
a0dbb045
JH
424
425 if (curlen == 0 &&
426 !(flags & UTF8_ALLOW_EMPTY)) {
427 warning = UTF8_WARN_EMPTY;
0c443dc2
JH
428 goto malformed;
429 }
430
1d72bdf6 431 if (UTF8_IS_INVARIANT(uv)) {
a0ed51b3
LW
432 if (retlen)
433 *retlen = 1;
c4d5f83a 434 return (UV) (NATIVE_TO_UTF(*s));
a0ed51b3 435 }
67e989fb 436
421a8bf2 437 if (UTF8_IS_CONTINUATION(uv) &&
fcc8fcf6 438 !(flags & UTF8_ALLOW_CONTINUATION)) {
a0dbb045 439 warning = UTF8_WARN_CONTINUATION;
ba210ebe
JH
440 goto malformed;
441 }
442
421a8bf2 443 if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
fcc8fcf6 444 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045 445 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe
JH
446 goto malformed;
447 }
9041c2e3 448
1d72bdf6 449#ifdef EBCDIC
75383841 450 uv = NATIVE_TO_UTF(uv);
1d72bdf6 451#else
fcc8fcf6
JH
452 if ((uv == 0xfe || uv == 0xff) &&
453 !(flags & UTF8_ALLOW_FE_FF)) {
a0dbb045 454 warning = UTF8_WARN_FE_FF;
ba210ebe 455 goto malformed;
a0ed51b3 456 }
1d72bdf6
NIS
457#endif
458
ba210ebe
JH
459 if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
460 else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
461 else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
462 else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
1d72bdf6
NIS
463#ifdef EBCDIC
464 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
465 else { len = 7; uv &= 0x01; }
466#else
ba210ebe
JH
467 else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
468 else if (!(uv & 0x01)) { len = 7; uv = 0; }
1d72bdf6
NIS
469 else { len = 13; uv = 0; } /* whoa! */
470#endif
471
a0ed51b3
LW
472 if (retlen)
473 *retlen = len;
9041c2e3 474
ba210ebe
JH
475 expectlen = len;
476
fcc8fcf6
JH
477 if ((curlen < expectlen) &&
478 !(flags & UTF8_ALLOW_SHORT)) {
a0dbb045 479 warning = UTF8_WARN_SHORT;
ba210ebe
JH
480 goto malformed;
481 }
482
483 len--;
a0ed51b3 484 s++;
ba210ebe
JH
485 ouv = uv;
486
a0ed51b3 487 while (len--) {
421a8bf2
JH
488 if (!UTF8_IS_CONTINUATION(*s) &&
489 !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
a0dbb045
JH
490 s--;
491 warning = UTF8_WARN_NON_CONTINUATION;
ba210ebe 492 goto malformed;
a0ed51b3
LW
493 }
494 else
8850bf83 495 uv = UTF8_ACCUMULATE(uv, *s);
a0dbb045
JH
496 if (!(uv > ouv)) {
497 /* These cannot be allowed. */
498 if (uv == ouv) {
75dbc644 499 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
a0dbb045
JH
500 warning = UTF8_WARN_LONG;
501 goto malformed;
502 }
503 }
504 else { /* uv < ouv */
505 /* This cannot be allowed. */
506 warning = UTF8_WARN_OVERFLOW;
507 goto malformed;
508 }
ba210ebe
JH
509 }
510 s++;
511 ouv = uv;
512 }
513
421a8bf2 514 if (UNICODE_IS_SURROGATE(uv) &&
fcc8fcf6 515 !(flags & UTF8_ALLOW_SURROGATE)) {
a0dbb045 516 warning = UTF8_WARN_SURROGATE;
ba210ebe 517 goto malformed;
eb160463 518 } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
fcc8fcf6 519 !(flags & UTF8_ALLOW_LONG)) {
a0dbb045 520 warning = UTF8_WARN_LONG;
ba210ebe 521 goto malformed;
421a8bf2 522 } else if (UNICODE_IS_ILLEGAL(uv) &&
a9917092 523 !(flags & UTF8_ALLOW_FFFF)) {
a0dbb045 524 warning = UTF8_WARN_FFFF;
a9917092 525 goto malformed;
a0ed51b3 526 }
ba210ebe 527
a0ed51b3 528 return uv;
ba210ebe
JH
529
530malformed:
531
fcc8fcf6 532 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 533 if (retlen)
cc366d4b 534 *retlen = -1;
ba210ebe
JH
535 return 0;
536 }
537
a0dbb045 538 if (dowarn) {
396482e1 539 SV* const sv = sv_2mortal(newSVpvs("Malformed UTF-8 character "));
a0dbb045
JH
540
541 switch (warning) {
542 case 0: /* Intentionally empty. */ break;
543 case UTF8_WARN_EMPTY:
396482e1 544 sv_catpvs(sv, "(empty string)");
a0dbb045
JH
545 break;
546 case UTF8_WARN_CONTINUATION:
097fb8e2 547 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
a0dbb045
JH
548 break;
549 case UTF8_WARN_NON_CONTINUATION:
097fb8e2
JH
550 if (s == s0)
551 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
552 (UV)s[1], startbyte);
551405c4
AL
553 else {
554 const int len = (int)(s-s0);
097fb8e2 555 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
556 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
557 }
558
a0dbb045
JH
559 break;
560 case UTF8_WARN_FE_FF:
561 Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
562 break;
563 case UTF8_WARN_SHORT:
097fb8e2 564 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
5d7488b2 565 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
b31f83c2 566 expectlen = curlen; /* distance for caller to skip */
a0dbb045
JH
567 break;
568 case UTF8_WARN_OVERFLOW:
097fb8e2
JH
569 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
570 ouv, *s, startbyte);
a0dbb045
JH
571 break;
572 case UTF8_WARN_SURROGATE:
573 Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
574 break;
a0dbb045 575 case UTF8_WARN_LONG:
097fb8e2 576 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
5d7488b2 577 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
a0dbb045
JH
578 break;
579 case UTF8_WARN_FFFF:
580 Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
581 break;
582 default:
396482e1 583 sv_catpvs(sv, "(unknown reason)");
a0dbb045
JH
584 break;
585 }
586
587 if (warning) {
44f8325f 588 const char * const s = SvPVX_const(sv);
a0dbb045
JH
589
590 if (PL_op)
9014280d 591 Perl_warner(aTHX_ packWARN(WARN_UTF8),
53e06cf0 592 "%s in %s", s, OP_DESC(PL_op));
a0dbb045 593 else
9014280d 594 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
a0dbb045
JH
595 }
596 }
597
ba210ebe 598 if (retlen)
28d3d195 599 *retlen = expectlen ? expectlen : len;
ba210ebe 600
28d3d195 601 return 0;
a0ed51b3
LW
602}
603
8e84507e 604/*
7fc63493 605=for apidoc A|UV|utf8_to_uvchr|const U8 *s|STRLEN *retlen
9041c2e3
NIS
606
607Returns the native character value of the first character in the string C<s>
1e54db1a 608which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
609length, in bytes, of that character.
610
1e54db1a 611If C<s> does not point to a well-formed UTF-8 character, zero is
9041c2e3
NIS
612returned and retlen is set, if possible, to -1.
613
614=cut
615*/
616
617UV
7fc63493 618Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
9041c2e3 619{
1754c1a1
NC
620 return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
621 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
9041c2e3
NIS
622}
623
624/*
7fc63493 625=for apidoc A|UV|utf8_to_uvuni|const U8 *s|STRLEN *retlen
9041c2e3
NIS
626
627Returns the Unicode code point of the first character in the string C<s>
1e54db1a 628which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
9041c2e3
NIS
629length, in bytes, of that character.
630
631This function should only be used when returned UV is considered
632an index into the Unicode semantic tables (e.g. swashes).
633
1e54db1a 634If C<s> does not point to a well-formed UTF-8 character, zero is
ba210ebe 635returned and retlen is set, if possible, to -1.
8e84507e
NIS
636
637=cut
638*/
639
640UV
7fc63493 641Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
8e84507e 642{
9041c2e3 643 /* Call the low level routine asking for checks */
89ebb4a3 644 return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
872c91ae 645 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
8e84507e
NIS
646}
647
b76347f2 648/*
35a4481c 649=for apidoc A|STRLEN|utf8_length|const U8 *s|const U8 *e
b76347f2
JH
650
651Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
652Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
653up past C<e>, croaks.
b76347f2
JH
654
655=cut
656*/
657
658STRLEN
35a4481c 659Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2 660{
97aff369 661 dVAR;
b76347f2
JH
662 STRLEN len = 0;
663
8850bf83
JH
664 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
665 * the bitops (especially ~) can create illegal UTF-8.
666 * In other words: in Perl UTF-8 is not just for Unicode. */
667
a3b680e6
AL
668 if (e < s)
669 goto warn_and_return;
b76347f2 670 while (s < e) {
4373e329 671 const U8 t = UTF8SKIP(s);
901b21bf 672 if (e - s < t) {
a3b680e6 673 warn_and_return:
901b21bf
JH
674 if (ckWARN_d(WARN_UTF8)) {
675 if (PL_op)
676 Perl_warner(aTHX_ packWARN(WARN_UTF8),
a3b680e6 677 "%s in %s", unees, OP_DESC(PL_op));
901b21bf
JH
678 else
679 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
680 }
681 return len;
682 }
b76347f2
JH
683 s += t;
684 len++;
685 }
686
687 return len;
688}
689
b06226ff 690/*
35a4481c 691=for apidoc A|IV|utf8_distance|const U8 *a|const U8 *b
b06226ff 692
1e54db1a 693Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
b06226ff
JH
694and C<b>.
695
696WARNING: use only if you *know* that the pointers point inside the
697same UTF-8 buffer.
698
37607a96
PK
699=cut
700*/
a0ed51b3 701
02eb7b47 702IV
35a4481c 703Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
a0ed51b3 704{
bf1665bc 705 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
a0ed51b3
LW
706}
707
b06226ff 708/*
37607a96 709=for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
b06226ff 710
8850bf83
JH
711Return the UTF-8 pointer C<s> displaced by C<off> characters, either
712forward or backward.
b06226ff
JH
713
714WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
715the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
716on the first byte of character or just after the last byte of a character.
b06226ff 717
37607a96
PK
718=cut
719*/
a0ed51b3
LW
720
721U8 *
4373e329 722Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
a0ed51b3 723{
96a5add6 724 PERL_UNUSED_CONTEXT;
8850bf83
JH
725 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
726 * the bitops (especially ~) can create illegal UTF-8.
727 * In other words: in Perl UTF-8 is not just for Unicode. */
728
a0ed51b3
LW
729 if (off >= 0) {
730 while (off--)
731 s += UTF8SKIP(s);
732 }
733 else {
734 while (off++) {
735 s--;
8850bf83
JH
736 while (UTF8_IS_CONTINUATION(*s))
737 s--;
a0ed51b3
LW
738 }
739 }
4373e329 740 return (U8 *)s;
a0ed51b3
LW
741}
742
6940069f 743/*
eebe1485 744=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
6940069f 745
1e54db1a 746Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
246fae53
MG
747Unlike C<bytes_to_utf8>, this over-writes the original string, and
748updates len to contain the new length.
67e989fb 749Returns zero on failure, setting C<len> to -1.
6940069f 750
95be277c
NC
751If you need a copy of the string, see C<bytes_from_utf8>.
752
6940069f
GS
753=cut
754*/
755
756U8 *
37607a96 757Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 758{
d4c19fe8
AL
759 U8 * const save = s;
760 U8 * const send = s + *len;
6940069f 761 U8 *d;
246fae53 762
1e54db1a 763 /* ensure valid UTF-8 and chars < 256 before updating string */
d4c19fe8 764 while (s < send) {
dcad2880
JH
765 U8 c = *s++;
766
1d72bdf6
NIS
767 if (!UTF8_IS_INVARIANT(c) &&
768 (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
769 || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
dcad2880
JH
770 *len = -1;
771 return 0;
772 }
246fae53 773 }
dcad2880
JH
774
775 d = s = save;
6940069f 776 while (s < send) {
ed646e6e 777 STRLEN ulen;
9041c2e3 778 *d++ = (U8)utf8_to_uvchr(s, &ulen);
ed646e6e 779 s += ulen;
6940069f
GS
780 }
781 *d = '\0';
246fae53 782 *len = d - save;
6940069f
GS
783 return save;
784}
785
786/*
e1ec3a88 787=for apidoc A|U8 *|bytes_from_utf8|const U8 *s|STRLEN *len|bool *is_utf8
f9a63242 788
1e54db1a 789Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
35a4481c 790Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
791the newly-created string, and updates C<len> to contain the new
792length. Returns the original string if no conversion occurs, C<len>
793is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
7940 if C<s> is converted or contains all 7bit characters.
f9a63242 795
37607a96
PK
796=cut
797*/
f9a63242
JH
798
799U8 *
e1ec3a88 800Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 801{
f9a63242 802 U8 *d;
e1ec3a88
AL
803 const U8 *start = s;
804 const U8 *send;
f9a63242
JH
805 I32 count = 0;
806
96a5add6 807 PERL_UNUSED_CONTEXT;
f9a63242 808 if (!*is_utf8)
73d840c0 809 return (U8 *)start;
f9a63242 810
1e54db1a 811 /* ensure valid UTF-8 and chars < 256 before converting string */
f9a63242 812 for (send = s + *len; s < send;) {
e1ec3a88 813 U8 c = *s++;
1d72bdf6 814 if (!UTF8_IS_INVARIANT(c)) {
db42d148
NIS
815 if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
816 (c = *s++) && UTF8_IS_CONTINUATION(c))
817 count++;
818 else
73d840c0 819 return (U8 *)start;
db42d148 820 }
f9a63242
JH
821 }
822
823 *is_utf8 = 0;
824
212542aa 825 Newx(d, (*len) - count + 1, U8);
ef9edfd0 826 s = start; start = d;
f9a63242
JH
827 while (s < send) {
828 U8 c = *s++;
c4d5f83a
NIS
829 if (!UTF8_IS_INVARIANT(c)) {
830 /* Then it is two-byte encoded */
831 c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
832 c = ASCII_TO_NATIVE(c);
833 }
834 *d++ = c;
f9a63242
JH
835 }
836 *d = '\0';
837 *len = d - start;
73d840c0 838 return (U8 *)start;
f9a63242
JH
839}
840
841/*
35a4481c 842=for apidoc A|U8 *|bytes_to_utf8|const U8 *s|STRLEN *len
6940069f 843
1e54db1a 844Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
6662521e
GS
845Returns a pointer to the newly-created string, and sets C<len> to
846reflect the new length.
6940069f 847
1e54db1a 848If you want to convert to UTF-8 from other encodings than ASCII,
c9ada85f
JH
849see sv_recode_to_utf8().
850
497711e7 851=cut
6940069f
GS
852*/
853
854U8*
35a4481c 855Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
6940069f 856{
35a4481c 857 const U8 * const send = s + (*len);
6940069f
GS
858 U8 *d;
859 U8 *dst;
96a5add6 860 PERL_UNUSED_CONTEXT;
6940069f 861
212542aa 862 Newx(d, (*len) * 2 + 1, U8);
6940069f
GS
863 dst = d;
864
865 while (s < send) {
35a4481c 866 const UV uv = NATIVE_TO_ASCII(*s++);
c4d5f83a 867 if (UNI_IS_INVARIANT(uv))
eb160463 868 *d++ = (U8)UTF_TO_NATIVE(uv);
6940069f 869 else {
eb160463
GS
870 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
871 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
6940069f
GS
872 }
873 }
874 *d = '\0';
6662521e 875 *len = d-dst;
6940069f
GS
876 return dst;
877}
878
a0ed51b3 879/*
dea0fc0b 880 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
881 *
882 * Destination must be pre-extended to 3/2 source. Do not use in-place.
883 * We optimize for native, for obvious reasons. */
884
885U8*
dea0fc0b 886Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 887{
dea0fc0b
JH
888 U8* pend;
889 U8* dstart = d;
890
1de9afcd
RGS
891 if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
892 d[0] = 0;
893 *newlen = 1;
894 return d;
895 }
896
dea0fc0b 897 if (bytelen & 1)
014ead4b 898 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVf, (UV)bytelen);
dea0fc0b
JH
899
900 pend = p + bytelen;
901
a0ed51b3 902 while (p < pend) {
dea0fc0b
JH
903 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
904 p += 2;
a0ed51b3 905 if (uv < 0x80) {
eb160463 906 *d++ = (U8)uv;
a0ed51b3
LW
907 continue;
908 }
909 if (uv < 0x800) {
eb160463
GS
910 *d++ = (U8)(( uv >> 6) | 0xc0);
911 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
912 continue;
913 }
914 if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
30f84f9e
DT
915 UV low = (p[0] << 8) + p[1];
916 p += 2;
dea0fc0b
JH
917 if (low < 0xdc00 || low >= 0xdfff)
918 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
a0ed51b3
LW
919 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
920 }
921 if (uv < 0x10000) {
eb160463
GS
922 *d++ = (U8)(( uv >> 12) | 0xe0);
923 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
924 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
925 continue;
926 }
927 else {
eb160463
GS
928 *d++ = (U8)(( uv >> 18) | 0xf0);
929 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
930 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
931 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
932 continue;
933 }
934 }
dea0fc0b 935 *newlen = d - dstart;
a0ed51b3
LW
936 return d;
937}
938
939/* Note: this one is slightly destructive of the source. */
940
941U8*
dea0fc0b 942Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
943{
944 U8* s = (U8*)p;
d4c19fe8 945 U8* const send = s + bytelen;
a0ed51b3 946 while (s < send) {
d4c19fe8 947 const U8 tmp = s[0];
a0ed51b3
LW
948 s[0] = s[1];
949 s[1] = tmp;
950 s += 2;
951 }
dea0fc0b 952 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
953}
954
955/* for now these are all defined (inefficiently) in terms of the utf8 versions */
956
957bool
84afefe6 958Perl_is_uni_alnum(pTHX_ UV c)
a0ed51b3 959{
89ebb4a3 960 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 961 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
962 return is_utf8_alnum(tmpbuf);
963}
964
965bool
84afefe6 966Perl_is_uni_alnumc(pTHX_ UV c)
b8c5462f 967{
89ebb4a3 968 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 969 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
970 return is_utf8_alnumc(tmpbuf);
971}
972
973bool
84afefe6 974Perl_is_uni_idfirst(pTHX_ UV c)
a0ed51b3 975{
89ebb4a3 976 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 977 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
978 return is_utf8_idfirst(tmpbuf);
979}
980
981bool
84afefe6 982Perl_is_uni_alpha(pTHX_ UV c)
a0ed51b3 983{
89ebb4a3 984 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 985 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
986 return is_utf8_alpha(tmpbuf);
987}
988
989bool
84afefe6 990Perl_is_uni_ascii(pTHX_ UV c)
4d61ec05 991{
89ebb4a3 992 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 993 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
994 return is_utf8_ascii(tmpbuf);
995}
996
997bool
84afefe6 998Perl_is_uni_space(pTHX_ UV c)
a0ed51b3 999{
89ebb4a3 1000 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1001 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1002 return is_utf8_space(tmpbuf);
1003}
1004
1005bool
84afefe6 1006Perl_is_uni_digit(pTHX_ UV c)
a0ed51b3 1007{
89ebb4a3 1008 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1009 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1010 return is_utf8_digit(tmpbuf);
1011}
1012
1013bool
84afefe6 1014Perl_is_uni_upper(pTHX_ UV c)
a0ed51b3 1015{
89ebb4a3 1016 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1017 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1018 return is_utf8_upper(tmpbuf);
1019}
1020
1021bool
84afefe6 1022Perl_is_uni_lower(pTHX_ UV c)
a0ed51b3 1023{
89ebb4a3 1024 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1025 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1026 return is_utf8_lower(tmpbuf);
1027}
1028
1029bool
84afefe6 1030Perl_is_uni_cntrl(pTHX_ UV c)
b8c5462f 1031{
89ebb4a3 1032 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1033 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1034 return is_utf8_cntrl(tmpbuf);
1035}
1036
1037bool
84afefe6 1038Perl_is_uni_graph(pTHX_ UV c)
b8c5462f 1039{
89ebb4a3 1040 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1041 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1042 return is_utf8_graph(tmpbuf);
1043}
1044
1045bool
84afefe6 1046Perl_is_uni_print(pTHX_ UV c)
a0ed51b3 1047{
89ebb4a3 1048 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1049 uvchr_to_utf8(tmpbuf, c);
a0ed51b3
LW
1050 return is_utf8_print(tmpbuf);
1051}
1052
b8c5462f 1053bool
84afefe6 1054Perl_is_uni_punct(pTHX_ UV c)
b8c5462f 1055{
89ebb4a3 1056 U8 tmpbuf[UTF8_MAXBYTES+1];
230880c1 1057 uvchr_to_utf8(tmpbuf, c);
b8c5462f
JH
1058 return is_utf8_punct(tmpbuf);
1059}
1060
4d61ec05 1061bool
84afefe6 1062Perl_is_uni_xdigit(pTHX_ UV c)
4d61ec05 1063{
89ebb4a3 1064 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
230880c1 1065 uvchr_to_utf8(tmpbuf, c);
4d61ec05
GS
1066 return is_utf8_xdigit(tmpbuf);
1067}
1068
84afefe6
JH
1069UV
1070Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1071{
0ebc6274
JH
1072 uvchr_to_utf8(p, c);
1073 return to_utf8_upper(p, p, lenp);
a0ed51b3
LW
1074}
1075
84afefe6
JH
1076UV
1077Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1078{
0ebc6274
JH
1079 uvchr_to_utf8(p, c);
1080 return to_utf8_title(p, p, lenp);
a0ed51b3
LW
1081}
1082
84afefe6
JH
1083UV
1084Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1085{
0ebc6274
JH
1086 uvchr_to_utf8(p, c);
1087 return to_utf8_lower(p, p, lenp);
a0ed51b3
LW
1088}
1089
84afefe6
JH
1090UV
1091Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1092{
0ebc6274
JH
1093 uvchr_to_utf8(p, c);
1094 return to_utf8_fold(p, p, lenp);
84afefe6
JH
1095}
1096
a0ed51b3
LW
1097/* for now these all assume no locale info available for Unicode > 255 */
1098
1099bool
84afefe6 1100Perl_is_uni_alnum_lc(pTHX_ UV c)
a0ed51b3
LW
1101{
1102 return is_uni_alnum(c); /* XXX no locale support yet */
1103}
1104
1105bool
84afefe6 1106Perl_is_uni_alnumc_lc(pTHX_ UV c)
b8c5462f
JH
1107{
1108 return is_uni_alnumc(c); /* XXX no locale support yet */
1109}
1110
1111bool
84afefe6 1112Perl_is_uni_idfirst_lc(pTHX_ UV c)
a0ed51b3
LW
1113{
1114 return is_uni_idfirst(c); /* XXX no locale support yet */
1115}
1116
1117bool
84afefe6 1118Perl_is_uni_alpha_lc(pTHX_ UV c)
a0ed51b3
LW
1119{
1120 return is_uni_alpha(c); /* XXX no locale support yet */
1121}
1122
1123bool
84afefe6 1124Perl_is_uni_ascii_lc(pTHX_ UV c)
4d61ec05
GS
1125{
1126 return is_uni_ascii(c); /* XXX no locale support yet */
1127}
1128
1129bool
84afefe6 1130Perl_is_uni_space_lc(pTHX_ UV c)
a0ed51b3
LW
1131{
1132 return is_uni_space(c); /* XXX no locale support yet */
1133}
1134
1135bool
84afefe6 1136Perl_is_uni_digit_lc(pTHX_ UV c)
a0ed51b3
LW
1137{
1138 return is_uni_digit(c); /* XXX no locale support yet */
1139}
1140
1141bool
84afefe6 1142Perl_is_uni_upper_lc(pTHX_ UV c)
a0ed51b3
LW
1143{
1144 return is_uni_upper(c); /* XXX no locale support yet */
1145}
1146
1147bool
84afefe6 1148Perl_is_uni_lower_lc(pTHX_ UV c)
a0ed51b3
LW
1149{
1150 return is_uni_lower(c); /* XXX no locale support yet */
1151}
1152
1153bool
84afefe6 1154Perl_is_uni_cntrl_lc(pTHX_ UV c)
b8c5462f
JH
1155{
1156 return is_uni_cntrl(c); /* XXX no locale support yet */
1157}
1158
1159bool
84afefe6 1160Perl_is_uni_graph_lc(pTHX_ UV c)
b8c5462f
JH
1161{
1162 return is_uni_graph(c); /* XXX no locale support yet */
1163}
1164
1165bool
84afefe6 1166Perl_is_uni_print_lc(pTHX_ UV c)
a0ed51b3
LW
1167{
1168 return is_uni_print(c); /* XXX no locale support yet */
1169}
1170
b8c5462f 1171bool
84afefe6 1172Perl_is_uni_punct_lc(pTHX_ UV c)
b8c5462f
JH
1173{
1174 return is_uni_punct(c); /* XXX no locale support yet */
1175}
1176
4d61ec05 1177bool
84afefe6 1178Perl_is_uni_xdigit_lc(pTHX_ UV c)
4d61ec05
GS
1179{
1180 return is_uni_xdigit(c); /* XXX no locale support yet */
1181}
1182
b7ac61fa
JH
1183U32
1184Perl_to_uni_upper_lc(pTHX_ U32 c)
1185{
ee099d14
JH
1186 /* XXX returns only the first character -- do not use XXX */
1187 /* XXX no locale support yet */
1188 STRLEN len;
89ebb4a3 1189 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1190 return (U32)to_uni_upper(c, tmpbuf, &len);
b7ac61fa
JH
1191}
1192
1193U32
1194Perl_to_uni_title_lc(pTHX_ U32 c)
1195{
ee099d14
JH
1196 /* XXX returns only the first character XXX -- do not use XXX */
1197 /* XXX no locale support yet */
1198 STRLEN len;
89ebb4a3 1199 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1200 return (U32)to_uni_title(c, tmpbuf, &len);
b7ac61fa
JH
1201}
1202
1203U32
1204Perl_to_uni_lower_lc(pTHX_ U32 c)
1205{
ee099d14
JH
1206 /* XXX returns only the first character -- do not use XXX */
1207 /* XXX no locale support yet */
1208 STRLEN len;
89ebb4a3 1209 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
ee099d14 1210 return (U32)to_uni_lower(c, tmpbuf, &len);
b7ac61fa
JH
1211}
1212
7452cf6a 1213static bool
5141f98e 1214S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
bde6a22d
NC
1215 const char *const swashname)
1216{
97aff369 1217 dVAR;
bde6a22d
NC
1218 if (!is_utf8_char(p))
1219 return FALSE;
1220 if (!*swash)
711a919c 1221 *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
bde6a22d
NC
1222 return swash_fetch(*swash, p, TRUE) != 0;
1223}
1224
1225bool
7fc63493 1226Perl_is_utf8_alnum(pTHX_ const U8 *p)
a0ed51b3 1227{
97aff369 1228 dVAR;
671c33bf
NC
1229 /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1230 * descendant of isalnum(3), in other words, it doesn't
1231 * contain the '_'. --jhi */
d4c19fe8 1232 return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
a0ed51b3
LW
1233}
1234
1235bool
7fc63493 1236Perl_is_utf8_alnumc(pTHX_ const U8 *p)
b8c5462f 1237{
97aff369 1238 dVAR;
d4c19fe8 1239 return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnumC");
b8c5462f
JH
1240}
1241
1242bool
7fc63493 1243Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
a0ed51b3 1244{
97aff369 1245 dVAR;
82686b01
JH
1246 if (*p == '_')
1247 return TRUE;
bde6a22d 1248 /* is_utf8_idstart would be more logical. */
d4c19fe8 1249 return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
82686b01
JH
1250}
1251
1252bool
7fc63493 1253Perl_is_utf8_idcont(pTHX_ const U8 *p)
82686b01 1254{
97aff369 1255 dVAR;
82686b01
JH
1256 if (*p == '_')
1257 return TRUE;
d4c19fe8 1258 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
a0ed51b3
LW
1259}
1260
1261bool
7fc63493 1262Perl_is_utf8_alpha(pTHX_ const U8 *p)
a0ed51b3 1263{
97aff369 1264 dVAR;
d4c19fe8 1265 return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
a0ed51b3
LW
1266}
1267
1268bool
7fc63493 1269Perl_is_utf8_ascii(pTHX_ const U8 *p)
b8c5462f 1270{
97aff369 1271 dVAR;
d4c19fe8 1272 return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
b8c5462f
JH
1273}
1274
1275bool
7fc63493 1276Perl_is_utf8_space(pTHX_ const U8 *p)
a0ed51b3 1277{
97aff369 1278 dVAR;
d4c19fe8 1279 return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
a0ed51b3
LW
1280}
1281
1282bool
7fc63493 1283Perl_is_utf8_digit(pTHX_ const U8 *p)
a0ed51b3 1284{
97aff369 1285 dVAR;
d4c19fe8 1286 return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
a0ed51b3
LW
1287}
1288
1289bool
7fc63493 1290Perl_is_utf8_upper(pTHX_ const U8 *p)
a0ed51b3 1291{
97aff369 1292 dVAR;
d4c19fe8 1293 return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
a0ed51b3
LW
1294}
1295
1296bool
7fc63493 1297Perl_is_utf8_lower(pTHX_ const U8 *p)
a0ed51b3 1298{
97aff369 1299 dVAR;
d4c19fe8 1300 return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
a0ed51b3
LW
1301}
1302
1303bool
7fc63493 1304Perl_is_utf8_cntrl(pTHX_ const U8 *p)
b8c5462f 1305{
97aff369 1306 dVAR;
d4c19fe8 1307 return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
b8c5462f
JH
1308}
1309
1310bool
7fc63493 1311Perl_is_utf8_graph(pTHX_ const U8 *p)
b8c5462f 1312{
97aff369 1313 dVAR;
d4c19fe8 1314 return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
b8c5462f
JH
1315}
1316
1317bool
7fc63493 1318Perl_is_utf8_print(pTHX_ const U8 *p)
a0ed51b3 1319{
97aff369 1320 dVAR;
d4c19fe8 1321 return is_utf8_common(p, &PL_utf8_print, "IsPrint");
a0ed51b3
LW
1322}
1323
1324bool
7fc63493 1325Perl_is_utf8_punct(pTHX_ const U8 *p)
b8c5462f 1326{
97aff369 1327 dVAR;
d4c19fe8 1328 return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
b8c5462f
JH
1329}
1330
1331bool
7fc63493 1332Perl_is_utf8_xdigit(pTHX_ const U8 *p)
b8c5462f 1333{
97aff369 1334 dVAR;
d4c19fe8 1335 return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
b8c5462f
JH
1336}
1337
1338bool
7fc63493 1339Perl_is_utf8_mark(pTHX_ const U8 *p)
a0ed51b3 1340{
97aff369 1341 dVAR;
d4c19fe8 1342 return is_utf8_common(p, &PL_utf8_mark, "IsM");
a0ed51b3
LW
1343}
1344
6b5c0936
JH
1345/*
1346=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1347
1348The "p" contains the pointer to the UTF-8 string encoding
1349the character that is being converted.
1350
1351The "ustrp" is a pointer to the character buffer to put the
1352conversion result to. The "lenp" is a pointer to the length
1353of the result.
1354
0134edef 1355The "swashp" is a pointer to the swash to use.
6b5c0936 1356
0134edef 1357Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
8fe4d5b2 1358and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually,
0134edef 1359but not always, a multicharacter mapping), is tried first.
6b5c0936 1360
0134edef
JH
1361The "special" is a string like "utf8::ToSpecLower", which means the
1362hash %utf8::ToSpecLower. The access to the hash is through
1363Perl_to_utf8_case().
6b5c0936 1364
0134edef
JH
1365The "normal" is a string like "ToLower" which means the swash
1366%utf8::ToLower.
1367
1368=cut */
6b5c0936 1369
2104c8d9 1370UV
9a957fbc
AL
1371Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1372 SV **swashp, const char *normal, const char *special)
a0ed51b3 1373{
97aff369 1374 dVAR;
89ebb4a3 1375 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
0134edef 1376 STRLEN len = 0;
a0ed51b3 1377
aec46f14 1378 const UV uv0 = utf8_to_uvchr(p, NULL);
1feea2c7
JH
1379 /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1380 * are necessary in EBCDIC, they are redundant no-ops
1381 * in ASCII-ish platforms, and hopefully optimized away. */
f54cb97a 1382 const UV uv1 = NATIVE_TO_UNI(uv0);
1feea2c7 1383 uvuni_to_utf8(tmpbuf, uv1);
0134edef
JH
1384
1385 if (!*swashp) /* load on-demand */
1386 *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1387
b08cf34e
JH
1388 /* The 0xDF is the only special casing Unicode code point below 0x100. */
1389 if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
0134edef 1390 /* It might be "special" (sometimes, but not always,
2a37f04d 1391 * a multicharacter mapping) */
983ffd37 1392 HV *hv;
b08cf34e
JH
1393 SV **svp;
1394
1395 if ((hv = get_hv(special, FALSE)) &&
1396 (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1397 (*svp)) {
cfd0369c 1398 const char *s;
47654450 1399
cfd0369c 1400 s = SvPV_const(*svp, len);
47654450
JH
1401 if (len == 1)
1402 len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2a37f04d 1403 else {
2f9475ad
JH
1404#ifdef EBCDIC
1405 /* If we have EBCDIC we need to remap the characters
1406 * since any characters in the low 256 are Unicode
1407 * code points, not EBCDIC. */
7cda7a3d 1408 U8 *t = (U8*)s, *tend = t + len, *d;
2f9475ad
JH
1409
1410 d = tmpbuf;
b08cf34e 1411 if (SvUTF8(*svp)) {
2f9475ad
JH
1412 STRLEN tlen = 0;
1413
1414 while (t < tend) {
d4c19fe8 1415 const UV c = utf8_to_uvchr(t, &tlen);
2f9475ad
JH
1416 if (tlen > 0) {
1417 d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1418 t += tlen;
1419 }
1420 else
1421 break;
1422 }
1423 }
1424 else {
36fec512
JH
1425 while (t < tend) {
1426 d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1427 t++;
1428 }
2f9475ad
JH
1429 }
1430 len = d - tmpbuf;
1431 Copy(tmpbuf, ustrp, len, U8);
1432#else
d2dcd0fb 1433 Copy(s, ustrp, len, U8);
2f9475ad 1434#endif
29e98929 1435 }
983ffd37 1436 }
0134edef
JH
1437 }
1438
1439 if (!len && *swashp) {
d4c19fe8
AL
1440 const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1441
0134edef
JH
1442 if (uv2) {
1443 /* It was "normal" (a single character mapping). */
d4c19fe8 1444 const UV uv3 = UNI_TO_NATIVE(uv2);
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);
623e6609 1613 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 1614 }
bc45ce41
JH
1615 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1616 if (SvPOK(retval))
35c1215d 1617 Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
95b63a38 1618 (void*)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)
623e6609 1714 CopHINTS_set(PL_curcop, PL_hints);
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 1747}
2b9d42f0 1748
979f2922
ST
1749/* Note:
1750 * Returns a swatch (a bit vector string) for a code point sequence
1751 * that starts from the value C<start> and comprises the number C<span>.
1752 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1753 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1754 */
1755STATIC SV*
1756S_swash_get(pTHX_ SV* swash, UV start, UV span)
1757{
1758 SV *swatch;
711a919c 1759 U8 *l, *lend, *x, *xend, *s;
979f2922
ST
1760 STRLEN lcur, xcur, scur;
1761
1762 HV* const hv = (HV*)SvRV(swash);
017a3ce5
GA
1763 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1764 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1765 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1766 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1767 SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
0bd48802
AL
1768 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1769 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
1770 const STRLEN bits = SvUV(*bitssvp);
1771 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1772 const UV none = SvUV(*nonesvp);
1773 const UV end = start + span;
979f2922
ST
1774
1775 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
660a4616
ST
1776 Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1777 (UV)bits);
979f2922
ST
1778 }
1779
1780 /* create and initialize $swatch */
396482e1 1781 swatch = newSVpvs("");
979f2922
ST
1782 scur = octets ? (span * octets) : (span + 7) / 8;
1783 SvGROW(swatch, scur + 1);
1784 s = (U8*)SvPVX(swatch);
1785 if (octets && none) {
0bd48802 1786 const U8* const e = s + scur;
979f2922
ST
1787 while (s < e) {
1788 if (bits == 8)
1789 *s++ = (U8)(none & 0xff);
1790 else if (bits == 16) {
1791 *s++ = (U8)((none >> 8) & 0xff);
1792 *s++ = (U8)( none & 0xff);
1793 }
1794 else if (bits == 32) {
1795 *s++ = (U8)((none >> 24) & 0xff);
1796 *s++ = (U8)((none >> 16) & 0xff);
1797 *s++ = (U8)((none >> 8) & 0xff);
1798 *s++ = (U8)( none & 0xff);
1799 }
1800 }
1801 *s = '\0';
1802 }
1803 else {
1804 (void)memzero((U8*)s, scur + 1);
1805 }
1806 SvCUR_set(swatch, scur);
1807 s = (U8*)SvPVX(swatch);
1808
1809 /* read $swash->{LIST} */
1810 l = (U8*)SvPV(*listsvp, lcur);
1811 lend = l + lcur;
1812 while (l < lend) {
1813 UV min, max, val, key;
1814 STRLEN numlen;
1815 I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1816
0bd48802 1817 U8* const nl = (U8*)memchr(l, '\n', lend - l);
979f2922
ST
1818
1819 numlen = lend - l;
1820 min = grok_hex((char *)l, &numlen, &flags, NULL);
1821 if (numlen)
1822 l += numlen;
1823 else if (nl) {
1824 l = nl + 1; /* 1 is length of "\n" */
1825 continue;
1826 }
1827 else {
1828 l = lend; /* to LIST's end at which \n is not found */
1829 break;
1830 }
1831
1832 if (isBLANK(*l)) {
1833 ++l;
1834 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1835 numlen = lend - l;
1836 max = grok_hex((char *)l, &numlen, &flags, NULL);
1837 if (numlen)
1838 l += numlen;
1839 else
1840 max = min;
1841
1842 if (octets) {
1843 if (isBLANK(*l)) {
1844 ++l;
1845 flags = PERL_SCAN_SILENT_ILLDIGIT |
1846 PERL_SCAN_DISALLOW_PREFIX;
1847 numlen = lend - l;
1848 val = grok_hex((char *)l, &numlen, &flags, NULL);
1849 if (numlen)
1850 l += numlen;
1851 else
1852 val = 0;
1853 }
1854 else {
1855 val = 0;
1856 if (typeto) {
1857 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1858 typestr, l);
1859 }
1860 }
1861 }
711a919c
ST
1862 else
1863 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
1864 }
1865 else {
1866 max = min;
1867 if (octets) {
1868 val = 0;
1869 if (typeto) {
1870 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1871 }
1872 }
711a919c
ST
1873 else
1874 val = 0; /* bits == 1, then val should be ignored */
979f2922
ST
1875 }
1876
1877 if (nl)
1878 l = nl + 1;
1879 else
1880 l = lend;
1881
1882 if (max < start)
1883 continue;
1884
1885 if (octets) {
1886 if (min < start) {
1887 if (!none || val < none) {
1888 val += start - min;
1889 }
1890 min = start;
1891 }
1892 for (key = min; key <= max; key++) {
1893 STRLEN offset;
1894 if (key >= end)
1895 goto go_out_list;
1896 /* offset must be non-negative (start <= min <= key < end) */
1897 offset = octets * (key - start);
1898 if (bits == 8)
1899 s[offset] = (U8)(val & 0xff);
1900 else if (bits == 16) {
1901 s[offset ] = (U8)((val >> 8) & 0xff);
1902 s[offset + 1] = (U8)( val & 0xff);
1903 }
1904 else if (bits == 32) {
1905 s[offset ] = (U8)((val >> 24) & 0xff);
1906 s[offset + 1] = (U8)((val >> 16) & 0xff);
1907 s[offset + 2] = (U8)((val >> 8) & 0xff);
1908 s[offset + 3] = (U8)( val & 0xff);
1909 }
1910
1911 if (!none || val < none)
1912 ++val;
1913 }
1914 }
711a919c 1915 else { /* bits == 1, then val should be ignored */
979f2922
ST
1916 if (min < start)
1917 min = start;
1918 for (key = min; key <= max; key++) {
0bd48802 1919 const STRLEN offset = (STRLEN)(key - start);
979f2922
ST
1920 if (key >= end)
1921 goto go_out_list;
1922 s[offset >> 3] |= 1 << (offset & 7);
1923 }
1924 }
1925 } /* while */
1926 go_out_list:
1927
1928 /* read $swash->{EXTRAS} */
1929 x = (U8*)SvPV(*extssvp, xcur);
1930 xend = x + xcur;
1931 while (x < xend) {
1932 STRLEN namelen;
1933 U8 *namestr;
1934 SV** othersvp;
1935 HV* otherhv;
1936 STRLEN otherbits;
1937 SV **otherbitssvp, *other;
711a919c 1938 U8 *s, *o, *nl;
979f2922
ST
1939 STRLEN slen, olen;
1940
1941 U8 opc = *x++;
1942 if (opc == '\n')
1943 continue;
1944
1945 nl = (U8*)memchr(x, '\n', xend - x);
1946
1947 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
1948 if (nl) {
1949 x = nl + 1; /* 1 is length of "\n" */
1950 continue;
1951 }
1952 else {
1953 x = xend; /* to EXTRAS' end at which \n is not found */
1954 break;
1955 }
1956 }
1957
1958 namestr = x;
1959 if (nl) {
1960 namelen = nl - namestr;
1961 x = nl + 1;
1962 }
1963 else {
1964 namelen = xend - namestr;
1965 x = xend;
1966 }
1967
1968 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
660a4616 1969 otherhv = (HV*)SvRV(*othersvp);
017a3ce5 1970 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
979f2922
ST
1971 otherbits = (STRLEN)SvUV(*otherbitssvp);
1972 if (bits < otherbits)
660a4616 1973 Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
979f2922
ST
1974
1975 /* The "other" swatch must be destroyed after. */
1976 other = swash_get(*othersvp, start, span);
1977 o = (U8*)SvPV(other, olen);
1978
1979 if (!olen)
660a4616 1980 Perl_croak(aTHX_ "panic: swash_get got improper swatch");
979f2922
ST
1981
1982 s = (U8*)SvPV(swatch, slen);
1983 if (bits == 1 && otherbits == 1) {
1984 if (slen != olen)
660a4616 1985 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
979f2922
ST
1986
1987 switch (opc) {
1988 case '+':
1989 while (slen--)
1990 *s++ |= *o++;
1991 break;
1992 case '!':
1993 while (slen--)
1994 *s++ |= ~*o++;
1995 break;
1996 case '-':
1997 while (slen--)
1998 *s++ &= ~*o++;
1999 break;
2000 case '&':
2001 while (slen--)
2002 *s++ &= *o++;
2003 break;
2004 default:
2005 break;
2006 }
2007 }
711a919c 2008 else {
979f2922
ST
2009 STRLEN otheroctets = otherbits >> 3;
2010 STRLEN offset = 0;
2011 U8* send = s + slen;
2012
2013 while (s < send) {
2014 UV otherval = 0;
2015
2016 if (otherbits == 1) {
2017 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2018 ++offset;
2019 }
2020 else {
2021 STRLEN vlen = otheroctets;
2022 otherval = *o++;
2023 while (--vlen) {
2024 otherval <<= 8;
2025 otherval |= *o++;
2026 }
2027 }
2028
711a919c 2029 if (opc == '+' && otherval)
6f207bd3 2030 NOOP; /* replace with otherval */
979f2922
ST
2031 else if (opc == '!' && !otherval)
2032 otherval = 1;
2033 else if (opc == '-' && otherval)
2034 otherval = 0;
2035 else if (opc == '&' && !otherval)
2036 otherval = 0;
2037 else {
711a919c 2038 s += octets; /* no replacement */
979f2922
ST
2039 continue;
2040 }
2041
2042 if (bits == 8)
2043 *s++ = (U8)( otherval & 0xff);
2044 else if (bits == 16) {
2045 *s++ = (U8)((otherval >> 8) & 0xff);
2046 *s++ = (U8)( otherval & 0xff);
2047 }
2048 else if (bits == 32) {
2049 *s++ = (U8)((otherval >> 24) & 0xff);
2050 *s++ = (U8)((otherval >> 16) & 0xff);
2051 *s++ = (U8)((otherval >> 8) & 0xff);
2052 *s++ = (U8)( otherval & 0xff);
2053 }
2054 }
2055 }
2056 sv_free(other); /* through with it! */
2057 } /* while */
2058 return swatch;
2059}
2060
0f830e0b
NC
2061/*
2062=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
2063
2064Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2065of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2066bytes available. The return value is the pointer to the byte after the
2067end of the new character. In other words,
2068
2069 d = uvchr_to_utf8(d, uv);
2070
2071is the recommended wide native character-aware way of saying
2072
2073 *(d++) = uv;
2074
2075=cut
2076*/
2077
2078/* On ASCII machines this is normally a macro but we want a
2079 real function in case XS code wants it
2080*/
0f830e0b
NC
2081U8 *
2082Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2083{
2084 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2085}
2086
b851fbc1
JH
2087U8 *
2088Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2089{
2090 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2091}
2b9d42f0
NIS
2092
2093/*
0f830e0b
NC
2094=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
2095flags
2096
2097Returns the native character value of the first character in the string
2098C<s>
2099which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2100length, in bytes, of that character.
2101
2102Allows length and flags to be passed to low level routine.
2103
2104=cut
2105*/
2106/* On ASCII machines this is normally a macro but we want
2107 a real function in case XS code wants it
2108*/
0f830e0b
NC
2109UV
2110Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2111U32 flags)
2112{
2113 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2114 return UNI_TO_NATIVE(uv);
2115}
2116
2117/*
d2cc3551
JH
2118=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
2119
2120Build to the scalar dsv a displayable version of the string spv,
2121length len, the displayable version being at most pvlim bytes long
2122(if longer, the rest is truncated and "..." will be appended).
0a2ef054 2123
9e55ce06 2124The flags argument can have UNI_DISPLAY_ISPRINT set to display
00e86452 2125isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
0a2ef054
JH
2126to display the \\[nrfta\\] as the backslashed versions (like '\n')
2127(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2128UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2129UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2130
d2cc3551
JH
2131The pointer to the PV of the dsv is returned.
2132
2133=cut */
e6b2e755 2134char *
e1ec3a88 2135Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
e6b2e755
JH
2136{
2137 int truncated = 0;
e1ec3a88 2138 const char *s, *e;
e6b2e755
JH
2139
2140 sv_setpvn(dsv, "", 0);
e1ec3a88 2141 for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
e6b2e755 2142 UV u;
a49f32c6
NC
2143 /* This serves double duty as a flag and a character to print after
2144 a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2145 */
2146 char ok = 0;
c728cb41 2147
e6b2e755
JH
2148 if (pvlim && SvCUR(dsv) >= pvlim) {
2149 truncated++;
2150 break;
2151 }
2152 u = utf8_to_uvchr((U8*)s, 0);
c728cb41 2153 if (u < 256) {
a3b680e6 2154 const unsigned char c = (unsigned char)u & 0xFF;
0bd48802 2155 if (flags & UNI_DISPLAY_BACKSLASH) {
a49f32c6 2156 switch (c) {
c728cb41 2157 case '\n':
a49f32c6 2158 ok = 'n'; break;
c728cb41 2159 case '\r':
a49f32c6 2160 ok = 'r'; break;
c728cb41 2161 case '\t':
a49f32c6 2162 ok = 't'; break;
c728cb41 2163 case '\f':
a49f32c6 2164 ok = 'f'; break;
c728cb41 2165 case '\a':
a49f32c6 2166 ok = 'a'; break;
c728cb41 2167 case '\\':
a49f32c6 2168 ok = '\\'; break;
c728cb41
JH
2169 default: break;
2170 }
a49f32c6
NC
2171 if (ok) {
2172 Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok);
2173 }
c728cb41 2174 }
00e86452 2175 /* isPRINT() is the locale-blind version. */
a49f32c6
NC
2176 if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2177 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2178 ok = 1;
0a2ef054 2179 }
c728cb41
JH
2180 }
2181 if (!ok)
9e55ce06 2182 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
e6b2e755
JH
2183 }
2184 if (truncated)
396482e1 2185 sv_catpvs(dsv, "...");
e6b2e755
JH
2186
2187 return SvPVX(dsv);
2188}
2b9d42f0 2189
d2cc3551
JH
2190/*
2191=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
2192
2193Build to the scalar dsv a displayable version of the scalar sv,
0a2ef054 2194the displayable version being at most pvlim bytes long
d2cc3551 2195(if longer, the rest is truncated and "..." will be appended).
0a2ef054
JH
2196
2197The flags argument is as in pv_uni_display().
2198
d2cc3551
JH
2199The pointer to the PV of the dsv is returned.
2200
d4c19fe8
AL
2201=cut
2202*/
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 */