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