This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change meaning of UNI_IS_INVARIANT on EBCDIC platforms
[perl5.git] / utf8.c
CommitLineData
a0ed51b3
LW
1/* utf8.c
2 *
1129b882 3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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/*
4ac71550
TC
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 *
cdad3b53 16 * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
a0ed51b3
LW
17 *
18 * 'Well do I understand your speech,' he answered in the same language;
19 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
4ac71550 20 * as is the custom in the West, if you wish to be answered?'
cdad3b53 21 * --Gandalf, addressing Théoden's door wardens
4ac71550
TC
22 *
23 * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
24 *
25 * ...the travellers perceived that the floor was paved with stones of many
26 * hues; branching runes and strange devices intertwined beneath their feet.
4ac71550
TC
27 *
28 * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
29 */
30
31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_UTF8_C
a0ed51b3 33#include "perl.h"
b992490d 34#include "invlist_inline.h"
a0ed51b3 35
27da23d5
JH
36static const char unees[] =
37 "Malformed UTF-8 character (unexpected end of string)";
901b21bf 38
48ef279e 39/*
ccfc67b7 40=head1 Unicode Support
7fefc6c1 41These are various utility functions for manipulating UTF8-encoded
72d33970 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
eaf7a4d2
CS
47=cut
48*/
49
50/*
7bbfa158 51=for apidoc is_invariant_string
eaf7a4d2 52
b8ed1ca9
KW
53Returns true iff the first C<len> bytes of the string C<s> are the same
54regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
55EBCDIC machines). That is, if they are UTF-8 invariant. On ASCII-ish
56machines, all the ASCII characters and only the ASCII characters fit this
7bbfa158 57definition. On EBCDIC machines, the ASCII-range characters are invariant, but
b8ed1ca9
KW
58so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
59EBCDIC).
eaf7a4d2 60
75200dff
KW
61If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
62use this option, that C<s> can't have embedded C<NUL> characters and has to
63have a terminating C<NUL> byte).
9f7e3d64 64
a1433954 65See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
eaf7a4d2
CS
66
67=cut
68*/
69
70bool
7bbfa158 71Perl_is_invariant_string(const U8 *s, STRLEN len)
eaf7a4d2
CS
72{
73 const U8* const send = s + (len ? len : strlen((const char *)s));
74 const U8* x = s;
75
7bbfa158 76 PERL_ARGS_ASSERT_IS_INVARIANT_STRING;
eaf7a4d2
CS
77
78 for (; x < send; ++x) {
79 if (!UTF8_IS_INVARIANT(*x))
80 break;
81 }
82
83 return x == send;
84}
85
86/*
378516de 87=for apidoc uvoffuni_to_utf8_flags
eebe1485 88
a27992cc 89THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
de69f3af
KW
90Instead, B<Almost all code should use L</uvchr_to_utf8> or
91L</uvchr_to_utf8_flags>>.
a27992cc 92
de69f3af
KW
93This function is like them, but the input is a strict Unicode
94(as opposed to native) code point. Only in very rare circumstances should code
95not be using the native code point.
949cf498 96
efa9cd84 97For details, see the description for L</uvchr_to_utf8_flags>.
949cf498 98
eebe1485
SC
99=cut
100*/
101
dfe13c55 102U8 *
378516de 103Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
a0ed51b3 104{
378516de 105 PERL_ARGS_ASSERT_UVOFFUNI_TO_UTF8_FLAGS;
7918f24d 106
2d1545e5 107 if (OFFUNI_IS_INVARIANT(uv)) {
d9432125
KW
108 *d++ = (U8) LATIN1_TO_NATIVE(uv);
109 return d;
110 }
111
9415f659
KW
112#ifdef EBCDIC
113 /* Not representable in UTF-EBCDIC */
114 flags |= UNICODE_DISALLOW_FE_FF;
115#endif
116
979f77b6 117 /* The first problematic code point is the first surrogate */
57162cb6
KW
118 if ( flags /* It's common to turn off all these */
119 && uv >= UNICODE_SURROGATE_FIRST
0cfa64bf 120 && ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
979f77b6 121 {
949cf498
KW
122 if (UNICODE_IS_SURROGATE(uv)) {
123 if (flags & UNICODE_WARN_SURROGATE) {
8457b38f 124 Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),
949cf498
KW
125 "UTF-16 surrogate U+%04"UVXf, uv);
126 }
127 if (flags & UNICODE_DISALLOW_SURROGATE) {
128 return NULL;
129 }
130 }
131 else if (UNICODE_IS_SUPER(uv)) {
132 if (flags & UNICODE_WARN_SUPER
133 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_WARN_FE_FF)))
134 {
8457b38f 135 Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE),
949cf498
KW
136 "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
137 }
138 if (flags & UNICODE_DISALLOW_SUPER
139 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF)))
140 {
9415f659
KW
141#ifdef EBCDIC
142 Perl_die(aTHX_ "Can't represent character for Ox%"UVXf" on this platform", uv);
661d43c4 143 NOT_REACHED; /* NOTREACHED */
9415f659 144#endif
949cf498
KW
145 return NULL;
146 }
147 }
148 else if (UNICODE_IS_NONCHAR(uv)) {
149 if (flags & UNICODE_WARN_NONCHAR) {
8457b38f 150 Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),
ba707cdc 151 "Unicode non-character U+%04"UVXf" is not recommended for open interchange",
949cf498
KW
152 uv);
153 }
154 if (flags & UNICODE_DISALLOW_NONCHAR) {
155 return NULL;
156 }
157 }
507b9800 158 }
d9432125 159
2d331972 160#if defined(EBCDIC)
d9432125 161 {
5aaebcb3 162 STRLEN len = OFFUNISKIP(uv);
1d72bdf6
NIS
163 U8 *p = d+len-1;
164 while (p > d) {
bc3632a8 165 *p-- = (U8) I8_TO_NATIVE_UTF8((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1d72bdf6
NIS
166 uv >>= UTF_ACCUMULATION_SHIFT;
167 }
bc3632a8 168 *p = (U8) I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1d72bdf6
NIS
169 return d+len;
170 }
171#else /* Non loop style */
a0ed51b3 172 if (uv < 0x800) {
eb160463
GS
173 *d++ = (U8)(( uv >> 6) | 0xc0);
174 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
175 return d;
176 }
177 if (uv < 0x10000) {
eb160463
GS
178 *d++ = (U8)(( uv >> 12) | 0xe0);
179 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
180 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
181 return d;
182 }
183 if (uv < 0x200000) {
eb160463
GS
184 *d++ = (U8)(( uv >> 18) | 0xf0);
185 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
186 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
187 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
188 return d;
189 }
190 if (uv < 0x4000000) {
eb160463
GS
191 *d++ = (U8)(( uv >> 24) | 0xf8);
192 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
193 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
194 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
195 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
196 return d;
197 }
198 if (uv < 0x80000000) {
eb160463
GS
199 *d++ = (U8)(( uv >> 30) | 0xfc);
200 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
201 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
202 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
203 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
204 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
205 return d;
206 }
6588300d 207#ifdef UTF8_QUAD_MAX
d7578b48 208 if (uv < UTF8_QUAD_MAX)
a0ed51b3
LW
209#endif
210 {
eb160463
GS
211 *d++ = 0xfe; /* Can't match U+FEFF! */
212 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
213 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
214 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
215 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
216 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
217 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
218 return d;
219 }
6588300d 220#ifdef UTF8_QUAD_MAX
a0ed51b3 221 {
eb160463
GS
222 *d++ = 0xff; /* Can't match U+FFFE! */
223 *d++ = 0x80; /* 6 Reserved bits */
224 *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
225 *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
226 *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
227 *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
228 *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
229 *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
230 *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
231 *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
232 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
233 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
234 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
235 return d;
236 }
237#endif
537124e4 238#endif /* Non loop style */
a0ed51b3 239}
646ca15d 240/*
07693fe6
KW
241=for apidoc uvchr_to_utf8
242
bcb1a2d4 243Adds the UTF-8 representation of the native code point C<uv> to the end
f2fc1b45 244of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
c749c9fd
KW
245C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
246the byte after the end of the new character. In other words,
07693fe6
KW
247
248 d = uvchr_to_utf8(d, uv);
249
250is the recommended wide native character-aware way of saying
251
252 *(d++) = uv;
253
de69f3af
KW
254This function accepts any UV as input. To forbid or warn on non-Unicode code
255points, or those that may be problematic, see L</uvchr_to_utf8_flags>.
256
07693fe6
KW
257=cut
258*/
259
de69f3af
KW
260/* This is also a macro */
261PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
262
07693fe6
KW
263U8 *
264Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
265{
de69f3af 266 return uvchr_to_utf8(d, uv);
07693fe6
KW
267}
268
de69f3af
KW
269/*
270=for apidoc uvchr_to_utf8_flags
271
272Adds the UTF-8 representation of the native code point C<uv> to the end
f2fc1b45 273of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
c749c9fd
KW
274C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
275the byte after the end of the new character. In other words,
de69f3af
KW
276
277 d = uvchr_to_utf8_flags(d, uv, flags);
278
279or, in most cases,
280
281 d = uvchr_to_utf8_flags(d, uv, 0);
282
283This is the Unicode-aware way of saying
284
285 *(d++) = uv;
286
287This function will convert to UTF-8 (and not warn) even code points that aren't
288legal Unicode or are problematic, unless C<flags> contains one or more of the
289following flags:
290
796b6530 291If C<uv> is a Unicode surrogate code point and C<UNICODE_WARN_SURROGATE> is set,
de69f3af 292the function will raise a warning, provided UTF8 warnings are enabled. If instead
796b6530 293C<UNICODE_DISALLOW_SURROGATE> is set, the function will fail and return NULL.
de69f3af
KW
294If both flags are set, the function will both warn and return NULL.
295
796b6530 296The C<UNICODE_WARN_NONCHAR> and C<UNICODE_DISALLOW_NONCHAR> flags
de69f3af 297affect how the function handles a Unicode non-character. And likewise, the
796b6530 298C<UNICODE_WARN_SUPER> and C<UNICODE_DISALLOW_SUPER> flags affect the handling of
de69f3af
KW
299code points that are
300above the Unicode maximum of 0x10FFFF. Code points above 0x7FFF_FFFF (which are
301even less portable) can be warned and/or disallowed even if other above-Unicode
796b6530
KW
302code points are accepted, by the C<UNICODE_WARN_FE_FF> and
303C<UNICODE_DISALLOW_FE_FF> flags.
de69f3af 304
796b6530
KW
305And finally, the flag C<UNICODE_WARN_ILLEGAL_INTERCHANGE> selects all four of
306the above WARN flags; and C<UNICODE_DISALLOW_ILLEGAL_INTERCHANGE> selects all
307four DISALLOW flags.
de69f3af
KW
308
309=cut
310*/
311
312/* This is also a macro */
313PERL_CALLCONV U8* Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags);
314
07693fe6
KW
315U8 *
316Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
317{
de69f3af 318 return uvchr_to_utf8_flags(d, uv, flags);
07693fe6
KW
319}
320
321/*
87cea99e 322=for apidoc is_utf8_string
6662521e 323
a1433954 324Returns true if the first C<len> bytes of string C<s> form a valid
9f7e3d64 325UTF-8 string, false otherwise. If C<len> is 0, it will be calculated
75200dff
KW
326using C<strlen(s)> (which means if you use this option, that C<s> can't have
327embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
328that all characters being ASCII constitute 'a valid UTF-8 string'.
6662521e 329
7bbfa158 330See also L</is_invariant_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
768c67ee 331
6662521e
GS
332=cut
333*/
334
8e84507e 335bool
668b6d8d 336Perl_is_utf8_string(const U8 *s, STRLEN len)
6662521e 337{
35da51f7 338 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 339 const U8* x = s;
067a85ef 340
7918f24d 341 PERL_ARGS_ASSERT_IS_UTF8_STRING;
1aa99e6b 342
6662521e 343 while (x < send) {
6302f837
KW
344 STRLEN len = isUTF8_CHAR(x, send);
345 if (UNLIKELY(! len)) {
346 return FALSE;
347 }
348 x += len;
6662521e 349 }
768c67ee 350
067a85ef 351 return TRUE;
6662521e
GS
352}
353
67e989fb 354/*
814fafa7
NC
355Implemented as a macro in utf8.h
356
87cea99e 357=for apidoc is_utf8_string_loc
814fafa7 358
a1433954
KW
359Like L</is_utf8_string> but stores the location of the failure (in the
360case of "utf8ness failure") or the location C<s>+C<len> (in the case of
814fafa7
NC
361"utf8ness success") in the C<ep>.
362
a1433954 363See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
814fafa7 364
87cea99e 365=for apidoc is_utf8_string_loclen
81cd54e3 366
a1433954
KW
367Like L</is_utf8_string>() but stores the location of the failure (in the
368case of "utf8ness failure") or the location C<s>+C<len> (in the case of
768c67ee
JH
369"utf8ness success") in the C<ep>, and the number of UTF-8
370encoded characters in the C<el>.
371
a1433954 372See also L</is_utf8_string_loc>() and L</is_utf8_string>().
81cd54e3
JH
373
374=cut
375*/
376
377bool
668b6d8d 378Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
81cd54e3 379{
35da51f7 380 const U8* const send = s + (len ? len : strlen((const char *)s));
7fc63493 381 const U8* x = s;
3ebfea28 382 STRLEN outlen = 0;
7918f24d
NC
383
384 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
81cd54e3 385
81cd54e3 386 while (x < send) {
6302f837
KW
387 STRLEN len = isUTF8_CHAR(x, send);
388 if (UNLIKELY(! len)) {
389 goto out;
390 }
391 x += len;
392 outlen++;
81cd54e3 393 }
768c67ee
JH
394
395 out:
3ebfea28
AL
396 if (el)
397 *el = outlen;
398
768c67ee
JH
399 if (ep)
400 *ep = x;
3ebfea28 401 return (x == send);
81cd54e3
JH
402}
403
404/*
768c67ee 405
de69f3af 406=for apidoc utf8n_to_uvchr
378516de
KW
407
408THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
de69f3af 409Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
67e989fb 410
9041c2e3 411Bottom level UTF-8 decode routine.
de69f3af 412Returns the native code point value of the first character in the string C<s>,
746afd53
KW
413which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
414C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
415the length, in bytes, of that character.
949cf498
KW
416
417The value of C<flags> determines the behavior when C<s> does not point to a
418well-formed UTF-8 character. If C<flags> is 0, when a malformation is found,
524080c4
KW
419zero is returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>) is the
420next possible position in C<s> that could begin a non-malformed character.
421Also, if UTF-8 warnings haven't been lexically disabled, a warning is raised.
949cf498
KW
422
423Various ALLOW flags can be set in C<flags> to allow (and not warn on)
424individual types of malformations, such as the sequence being overlong (that
425is, when there is a shorter sequence that can express the same code point;
426overlong sequences are expressly forbidden in the UTF-8 standard due to
427potential security issues). Another malformation example is the first byte of
428a character not being a legal first byte. See F<utf8.h> for the list of such
524080c4
KW
429flags. For allowed 0 length strings, this function returns 0; for allowed
430overlong sequences, the computed code point is returned; for all other allowed
431malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no
432determinable reasonable value.
949cf498 433
796b6530 434The C<UTF8_CHECK_ONLY> flag overrides the behavior when a non-allowed (by other
949cf498
KW
435flags) malformation is found. If this flag is set, the routine assumes that
436the caller will raise a warning, and this function will silently just set
d088425d
KW
437C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
438
75200dff 439Note that this API requires disambiguation between successful decoding a C<NUL>
796b6530 440character, and an error return (unless the C<UTF8_CHECK_ONLY> flag is set), as
d088425d 441in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
75200dff
KW
442first byte of C<s> is 0 as well. If so, the input was a C<NUL>; if not, the
443input had an error.
949cf498
KW
444
445Certain code points are considered problematic. These are Unicode surrogates,
746afd53 446Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
949cf498 447By default these are considered regular code points, but certain situations
5eafe189 448warrant special handling for them. If C<flags> contains
796b6530
KW
449C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, all three classes are treated as
450malformations and handled as such. The flags C<UTF8_DISALLOW_SURROGATE>,
451C<UTF8_DISALLOW_NONCHAR>, and C<UTF8_DISALLOW_SUPER> (meaning above the legal
452Unicode maximum) can be set to disallow these categories individually.
453
454The flags C<UTF8_WARN_ILLEGAL_INTERCHANGE>, C<UTF8_WARN_SURROGATE>,
455C<UTF8_WARN_NONCHAR>, and C<UTF8_WARN_SUPER> will cause warning messages to be
456raised for their respective categories, but otherwise the code points are
457considered valid (not malformations). To get a category to both be treated as
458a malformation and raise a warning, specify both the WARN and DISALLOW flags.
949cf498 459(But note that warnings are not raised if lexically disabled nor if
796b6530 460C<UTF8_CHECK_ONLY> is also specified.)
949cf498
KW
461
462Very large code points (above 0x7FFF_FFFF) are considered more problematic than
463the others that are above the Unicode legal maximum. There are several
eb83ed87
KW
464reasons: they requre at least 32 bits to represent them on ASCII platforms, are
465not representable at all on EBCDIC platforms, and the original UTF-8
466specification never went above this number (the current 0x10FFFF limit was
467imposed later). (The smaller ones, those that fit into 32 bits, are
468representable by a UV on ASCII platforms, but not by an IV, which means that
469the number of operations that can be performed on them is quite restricted.)
470The UTF-8 encoding on ASCII platforms for these large code points begins with a
796b6530 471byte containing 0xFE or 0xFF. The C<UTF8_DISALLOW_FE_FF> flag will cause them to
eb83ed87 472be treated as malformations, while allowing smaller above-Unicode code points.
796b6530 473(Of course C<UTF8_DISALLOW_SUPER> will treat all above-Unicode code points,
72d33970 474including these, as malformations.)
796b6530 475Similarly, C<UTF8_WARN_FE_FF> acts just like
eb83ed87 476the other WARN flags, but applies just to these code points.
949cf498
KW
477
478All other code points corresponding to Unicode characters, including private
479use and those yet to be assigned, are never considered malformed and never
480warn.
67e989fb 481
37607a96
PK
482=cut
483*/
67e989fb 484
a0ed51b3 485UV
de69f3af 486Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
a0ed51b3 487{
d4c19fe8 488 const U8 * const s0 = s;
eb83ed87 489 U8 overflow_byte = '\0'; /* Save byte in case of overflow */
0b8d30e8 490 U8 * send;
eb83ed87
KW
491 UV uv = *s;
492 STRLEN expectlen;
949cf498 493 SV* sv = NULL;
eb83ed87
KW
494 UV outlier_ret = 0; /* return value when input is in error or problematic
495 */
496 UV pack_warn = 0; /* Save result of packWARN() for later */
497 bool unexpected_non_continuation = FALSE;
498 bool overflowed = FALSE;
2f8f112e 499 bool do_overlong_test = TRUE; /* May have to skip this test */
a0dbb045 500
eb83ed87 501 const char* const malformed_text = "Malformed UTF-8 character";
7918f24d 502
de69f3af 503 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
a0dbb045 504
eb83ed87
KW
505 /* The order of malformation tests here is important. We should consume as
506 * few bytes as possible in order to not skip any valid character. This is
507 * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
508 * http://unicode.org/reports/tr36 for more discussion as to why. For
509 * example, once we've done a UTF8SKIP, we can tell the expected number of
510 * bytes, and could fail right off the bat if the input parameters indicate
511 * that there are too few available. But it could be that just that first
512 * byte is garbled, and the intended character occupies fewer bytes. If we
513 * blindly assumed that the first byte is correct, and skipped based on
514 * that number, we could skip over a valid input character. So instead, we
515 * always examine the sequence byte-by-byte.
516 *
517 * We also should not consume too few bytes, otherwise someone could inject
518 * things. For example, an input could be deliberately designed to
519 * overflow, and if this code bailed out immediately upon discovering that,
e2660c54 520 * returning to the caller C<*retlen> pointing to the very next byte (one
eb83ed87
KW
521 * which is actually part of of the overflowing sequence), that could look
522 * legitimate to the caller, which could discard the initial partial
523 * sequence and process the rest, inappropriately */
524
525 /* Zero length strings, if allowed, of necessity are zero */
b5b9af04 526 if (UNLIKELY(curlen == 0)) {
eb83ed87
KW
527 if (retlen) {
528 *retlen = 0;
529 }
a0dbb045 530
eb83ed87
KW
531 if (flags & UTF8_ALLOW_EMPTY) {
532 return 0;
533 }
534 if (! (flags & UTF8_CHECK_ONLY)) {
535 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
536 }
0c443dc2
JH
537 goto malformed;
538 }
539
eb83ed87
KW
540 expectlen = UTF8SKIP(s);
541
542 /* A well-formed UTF-8 character, as the vast majority of calls to this
543 * function will be for, has this expected length. For efficiency, set
544 * things up here to return it. It will be overriden only in those rare
545 * cases where a malformation is found */
546 if (retlen) {
547 *retlen = expectlen;
548 }
549
550 /* An invariant is trivially well-formed */
1d72bdf6 551 if (UTF8_IS_INVARIANT(uv)) {
de69f3af 552 return uv;
a0ed51b3 553 }
67e989fb 554
eb83ed87 555 /* A continuation character can't start a valid sequence */
b5b9af04 556 if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
eb83ed87
KW
557 if (flags & UTF8_ALLOW_CONTINUATION) {
558 if (retlen) {
559 *retlen = 1;
560 }
561 return UNICODE_REPLACEMENT;
562 }
ba210ebe 563
eb83ed87
KW
564 if (! (flags & UTF8_CHECK_ONLY)) {
565 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
566 }
567 curlen = 1;
ba210ebe
JH
568 goto malformed;
569 }
9041c2e3 570
dcd27b3c
KW
571 /* Here is not a continuation byte, nor an invariant. The only thing left
572 * is a start byte (possibly for an overlong) */
573
1d72bdf6 574#ifdef EBCDIC
bc3632a8 575 uv = NATIVE_UTF8_TO_I8(uv);
1d72bdf6
NIS
576#endif
577
eb83ed87
KW
578 /* Remove the leading bits that indicate the number of bytes in the
579 * character's whole UTF-8 sequence, leaving just the bits that are part of
580 * the value */
581 uv &= UTF_START_MASK(expectlen);
ba210ebe 582
eb83ed87
KW
583 /* Now, loop through the remaining bytes in the character's sequence,
584 * accumulating each into the working value as we go. Be sure to not look
585 * past the end of the input string */
0b8d30e8
KW
586 send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
587
eb83ed87 588 for (s = s0 + 1; s < send; s++) {
b5b9af04 589 if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
eb83ed87
KW
590#ifndef EBCDIC /* Can't overflow in EBCDIC */
591 if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
592
593 /* The original implementors viewed this malformation as more
594 * serious than the others (though I, khw, don't understand
595 * why, since other malformations also give very very wrong
596 * results), so there is no way to turn off checking for it.
597 * Set a flag, but keep going in the loop, so that we absorb
598 * the rest of the bytes that comprise the character. */
599 overflowed = TRUE;
600 overflow_byte = *s; /* Save for warning message's use */
601 }
602#endif
8850bf83 603 uv = UTF8_ACCUMULATE(uv, *s);
eb83ed87
KW
604 }
605 else {
606 /* Here, found a non-continuation before processing all expected
607 * bytes. This byte begins a new character, so quit, even if
608 * allowing this malformation. */
609 unexpected_non_continuation = TRUE;
610 break;
611 }
612 } /* End of loop through the character's bytes */
613
614 /* Save how many bytes were actually in the character */
615 curlen = s - s0;
616
617 /* The loop above finds two types of malformations: non-continuation and/or
618 * overflow. The non-continuation malformation is really a too-short
619 * malformation, as it means that the current character ended before it was
620 * expected to (being terminated prematurely by the beginning of the next
621 * character, whereas in the too-short malformation there just are too few
622 * bytes available to hold the character. In both cases, the check below
623 * that we have found the expected number of bytes would fail if executed.)
624 * Thus the non-continuation malformation is really unnecessary, being a
625 * subset of the too-short malformation. But there may be existing
626 * applications that are expecting the non-continuation type, so we retain
627 * it, and return it in preference to the too-short malformation. (If this
628 * code were being written from scratch, the two types might be collapsed
629 * into one.) I, khw, am also giving priority to returning the
630 * non-continuation and too-short malformations over overflow when multiple
631 * ones are present. I don't know of any real reason to prefer one over
632 * the other, except that it seems to me that multiple-byte errors trumps
633 * errors from a single byte */
b5b9af04 634 if (UNLIKELY(unexpected_non_continuation)) {
eb83ed87
KW
635 if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
636 if (! (flags & UTF8_CHECK_ONLY)) {
637 if (curlen == 1) {
638 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
639 }
640 else {
641 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
a0dbb045
JH
642 }
643 }
eb83ed87
KW
644 goto malformed;
645 }
646 uv = UNICODE_REPLACEMENT;
2f8f112e
KW
647
648 /* Skip testing for overlongs, as the REPLACEMENT may not be the same
649 * as what the original expectations were. */
650 do_overlong_test = FALSE;
eb83ed87
KW
651 if (retlen) {
652 *retlen = curlen;
653 }
654 }
b5b9af04 655 else if (UNLIKELY(curlen < expectlen)) {
eb83ed87
KW
656 if (! (flags & UTF8_ALLOW_SHORT)) {
657 if (! (flags & UTF8_CHECK_ONLY)) {
658 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
a0dbb045 659 }
eb83ed87
KW
660 goto malformed;
661 }
662 uv = UNICODE_REPLACEMENT;
2f8f112e 663 do_overlong_test = FALSE;
eb83ed87
KW
664 if (retlen) {
665 *retlen = curlen;
666 }
667 }
668
ea5ced44 669#ifndef EBCDIC /* EBCDIC can't overflow */
b5b9af04 670 if (UNLIKELY(overflowed)) {
eb83ed87 671 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0));
ba210ebe 672 goto malformed;
eb83ed87
KW
673 }
674#endif
675
2f8f112e 676 if (do_overlong_test
5aaebcb3 677 && expectlen > (STRLEN) OFFUNISKIP(uv)
2f8f112e
KW
678 && ! (flags & UTF8_ALLOW_LONG))
679 {
eb83ed87
KW
680 /* The overlong malformation has lower precedence than the others.
681 * Note that if this malformation is allowed, we return the actual
682 * value, instead of the replacement character. This is because this
683 * value is actually well-defined. */
684 if (! (flags & UTF8_CHECK_ONLY)) {
5aaebcb3 685 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", OFFUNISKIP(uv), *s0));
eb83ed87
KW
686 }
687 goto malformed;
688 }
689
1a89bb6c 690 /* Here, the input is considered to be well-formed, but it still could be a
eb83ed87
KW
691 * problematic code point that is not allowed by the input parameters. */
692 if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */
693 && (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE
694 |UTF8_WARN_ILLEGAL_INTERCHANGE)))
695 {
949cf498 696 if (UNICODE_IS_SURROGATE(uv)) {
ea5ced44
KW
697
698 /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary
699 * generation of the sv, since no warnings are raised under CHECK */
eb83ed87 700 if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
54f4afef 701 && ckWARN_d(WARN_SURROGATE))
eb83ed87 702 {
111d382d 703 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
54f4afef 704 pack_warn = packWARN(WARN_SURROGATE);
949cf498
KW
705 }
706 if (flags & UTF8_DISALLOW_SURROGATE) {
707 goto disallowed;
708 }
709 }
949cf498 710 else if ((uv > PERL_UNICODE_MAX)) {
eb83ed87 711 if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
ea5ced44 712 && ckWARN_d(WARN_NON_UNICODE))
eb83ed87 713 {
111d382d 714 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
54f4afef 715 pack_warn = packWARN(WARN_NON_UNICODE);
949cf498 716 }
ea5ced44
KW
717#ifndef EBCDIC /* EBCDIC always allows FE, FF */
718
719 /* The first byte being 0xFE or 0xFF is a subset of the SUPER code
720 * points. We test for these after the regular SUPER ones, and
721 * before possibly bailing out, so that the more dire warning
722 * overrides the regular one, if applicable */
723 if ((*s0 & 0xFE) == 0xFE /* matches both FE, FF */
724 && (flags & (UTF8_WARN_FE_FF|UTF8_DISALLOW_FE_FF)))
725 {
726 if ((flags & (UTF8_WARN_FE_FF|UTF8_CHECK_ONLY))
727 == UTF8_WARN_FE_FF
728 && ckWARN_d(WARN_UTF8))
729 {
730 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%"UVXf" is not Unicode, and not portable", uv));
731 pack_warn = packWARN(WARN_UTF8);
732 }
733 if (flags & UTF8_DISALLOW_FE_FF) {
734 goto disallowed;
735 }
736 }
737#endif
949cf498
KW
738 if (flags & UTF8_DISALLOW_SUPER) {
739 goto disallowed;
740 }
741 }
4190d317
KW
742 else if (UNICODE_IS_NONCHAR(uv)) {
743 if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
54f4afef 744 && ckWARN_d(WARN_NONCHAR))
4190d317 745 {
ba707cdc 746 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv));
54f4afef 747 pack_warn = packWARN(WARN_NONCHAR);
4190d317
KW
748 }
749 if (flags & UTF8_DISALLOW_NONCHAR) {
750 goto disallowed;
751 }
752 }
949cf498 753
eb83ed87 754 if (sv) {
de69f3af
KW
755 outlier_ret = uv; /* Note we don't bother to convert to native,
756 as all the outlier code points are the same
757 in both ASCII and EBCDIC */
eb83ed87
KW
758 goto do_warn;
759 }
760
949cf498
KW
761 /* Here, this is not considered a malformed character, so drop through
762 * to return it */
a0ed51b3 763 }
ba210ebe 764
de69f3af 765 return UNI_TO_NATIVE(uv);
ba210ebe 766
eb83ed87
KW
767 /* There are three cases which get to beyond this point. In all 3 cases:
768 * <sv> if not null points to a string to print as a warning.
769 * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
770 * set.
771 * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
772 * This is done by initializing it to 0, and changing it only
773 * for case 1).
774 * The 3 cases are:
775 * 1) The input is valid but problematic, and to be warned about. The
776 * return value is the resultant code point; <*retlen> is set to
777 * <curlen>, the number of bytes that comprise the code point.
778 * <pack_warn> contains the result of packWARN() for the warning
779 * types. The entry point for this case is the label <do_warn>;
780 * 2) The input is a valid code point but disallowed by the parameters to
781 * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
782 * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
783 * comprise the code point. <pack_warn> contains the result of
784 * packWARN() for the warning types. The entry point for this case is
785 * the label <disallowed>.
786 * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
787 * is set, <*relen> is -1; otherwise it is <curlen>, the number of
788 * bytes that comprise the malformation. All such malformations are
789 * assumed to be warning type <utf8>. The entry point for this case
790 * is the label <malformed>.
791 */
949cf498 792
7b52d656 793 malformed:
ba210ebe 794
eb83ed87
KW
795 if (sv && ckWARN_d(WARN_UTF8)) {
796 pack_warn = packWARN(WARN_UTF8);
797 }
798
7b52d656 799 disallowed:
eb83ed87 800
fcc8fcf6 801 if (flags & UTF8_CHECK_ONLY) {
ba210ebe 802 if (retlen)
10edeb5d 803 *retlen = ((STRLEN) -1);
ba210ebe
JH
804 return 0;
805 }
806
7b52d656 807 do_warn:
5b311467 808
eb83ed87
KW
809 if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
810 if warnings are to be raised. */
f555bc63 811 const char * const string = SvPVX_const(sv);
a0dbb045 812
f555bc63
KW
813 if (PL_op)
814 Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
815 else
816 Perl_warner(aTHX_ pack_warn, "%s", string);
a0dbb045
JH
817 }
818
eb83ed87
KW
819 if (retlen) {
820 *retlen = curlen;
821 }
ba210ebe 822
eb83ed87 823 return outlier_ret;
a0ed51b3
LW
824}
825
8e84507e 826/*
ec5f19d0
KW
827=for apidoc utf8_to_uvchr_buf
828
829Returns the native code point of the first character in the string C<s> which
830is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
524080c4 831C<*retlen> will be set to the length, in bytes, of that character.
ec5f19d0 832
524080c4
KW
833If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
834enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
796b6530 835C<NULL>) to -1. If those warnings are off, the computed value, if well-defined
173db420 836(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
796b6530 837C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
173db420 838the next possible position in C<s> that could begin a non-malformed character.
de69f3af 839See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
173db420 840returned.
ec5f19d0
KW
841
842=cut
843*/
844
845
846UV
847Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
848{
ec5f19d0
KW
849 assert(s < send);
850
851 return utf8n_to_uvchr(s, send - s, retlen,
852 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
853}
854
27d6c58a 855/* Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
3986bb7c 856 * there are no malformations in the input UTF-8 string C<s>. surrogates,
57b0056d 857 * non-character code points, and non-Unicode code points are allowed. */
27d6c58a
KW
858
859UV
860Perl_valid_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
861{
010ab96b
KW
862 UV expectlen = UTF8SKIP(s);
863 const U8* send = s + expectlen;
9ff2f0f7 864 UV uv = *s;
3986bb7c 865
27d6c58a 866 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
81611534 867 PERL_UNUSED_CONTEXT;
27d6c58a 868
010ab96b
KW
869 if (retlen) {
870 *retlen = expectlen;
871 }
872
873 /* An invariant is trivially returned */
874 if (expectlen == 1) {
9ff2f0f7 875 return uv;
010ab96b
KW
876 }
877
9ff2f0f7
KW
878#ifdef EBCDIC
879 uv = NATIVE_UTF8_TO_I8(uv);
880#endif
881
010ab96b
KW
882 /* Remove the leading bits that indicate the number of bytes, leaving just
883 * the bits that are part of the value */
884 uv &= UTF_START_MASK(expectlen);
885
886 /* Now, loop through the remaining bytes, accumulating each into the
887 * working total as we go. (I khw tried unrolling the loop for up to 4
888 * bytes, but there was no performance improvement) */
889 for (++s; s < send; s++) {
890 uv = UTF8_ACCUMULATE(uv, *s);
891 }
892
3986bb7c 893 return UNI_TO_NATIVE(uv);
010ab96b 894
27d6c58a
KW
895}
896
ec5f19d0 897/*
ec5f19d0
KW
898=for apidoc utf8_to_uvuni_buf
899
de69f3af
KW
900Only in very rare circumstances should code need to be dealing in Unicode
901(as opposed to native) code points. In those few cases, use
902C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>> instead.
4f83cdcd
KW
903
904Returns the Unicode (not-native) code point of the first character in the
905string C<s> which
ec5f19d0
KW
906is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
907C<retlen> will be set to the length, in bytes, of that character.
908
524080c4
KW
909If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
910enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
911NULL) to -1. If those warnings are off, the computed value if well-defined (or
912the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
913is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
914next possible position in C<s> that could begin a non-malformed character.
de69f3af 915See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
ec5f19d0
KW
916
917=cut
918*/
919
920UV
921Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
922{
923 PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
924
925 assert(send > s);
926
927 /* Call the low level routine asking for checks */
de69f3af
KW
928 return NATIVE_TO_UNI(Perl_utf8n_to_uvchr(aTHX_ s, send -s, retlen,
929 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY));
ec5f19d0
KW
930}
931
b76347f2 932/*
87cea99e 933=for apidoc utf8_length
b76347f2
JH
934
935Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
936Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
937up past C<e>, croaks.
b76347f2
JH
938
939=cut
940*/
941
942STRLEN
35a4481c 943Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2
JH
944{
945 STRLEN len = 0;
946
7918f24d
NC
947 PERL_ARGS_ASSERT_UTF8_LENGTH;
948
8850bf83
JH
949 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
950 * the bitops (especially ~) can create illegal UTF-8.
951 * In other words: in Perl UTF-8 is not just for Unicode. */
952
a3b680e6
AL
953 if (e < s)
954 goto warn_and_return;
b76347f2 955 while (s < e) {
4cbf4130 956 s += UTF8SKIP(s);
8e91ec7f
AV
957 len++;
958 }
959
960 if (e != s) {
961 len--;
962 warn_and_return:
9b387841
NC
963 if (PL_op)
964 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
965 "%s in %s", unees, OP_DESC(PL_op));
966 else
61a12c31 967 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
b76347f2
JH
968 }
969
970 return len;
971}
972
b06226ff 973/*
87cea99e 974=for apidoc utf8_distance
b06226ff 975
1e54db1a 976Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
b06226ff
JH
977and C<b>.
978
979WARNING: use only if you *know* that the pointers point inside the
980same UTF-8 buffer.
981
37607a96
PK
982=cut
983*/
a0ed51b3 984
02eb7b47 985IV
35a4481c 986Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
a0ed51b3 987{
7918f24d
NC
988 PERL_ARGS_ASSERT_UTF8_DISTANCE;
989
bf1665bc 990 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
a0ed51b3
LW
991}
992
b06226ff 993/*
87cea99e 994=for apidoc utf8_hop
b06226ff 995
8850bf83
JH
996Return the UTF-8 pointer C<s> displaced by C<off> characters, either
997forward or backward.
b06226ff
JH
998
999WARNING: do not use the following unless you *know* C<off> is within
8850bf83
JH
1000the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1001on the first byte of character or just after the last byte of a character.
b06226ff 1002
37607a96
PK
1003=cut
1004*/
a0ed51b3
LW
1005
1006U8 *
ddeaf645 1007Perl_utf8_hop(const U8 *s, I32 off)
a0ed51b3 1008{
7918f24d
NC
1009 PERL_ARGS_ASSERT_UTF8_HOP;
1010
8850bf83
JH
1011 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1012 * the bitops (especially ~) can create illegal UTF-8.
1013 * In other words: in Perl UTF-8 is not just for Unicode. */
1014
a0ed51b3
LW
1015 if (off >= 0) {
1016 while (off--)
1017 s += UTF8SKIP(s);
1018 }
1019 else {
1020 while (off++) {
1021 s--;
8850bf83
JH
1022 while (UTF8_IS_CONTINUATION(*s))
1023 s--;
a0ed51b3
LW
1024 }
1025 }
4373e329 1026 return (U8 *)s;
a0ed51b3
LW
1027}
1028
6940069f 1029/*
fed3ba5d
NC
1030=for apidoc bytes_cmp_utf8
1031
a1433954 1032Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
72d33970
FC
1033sequence of characters (stored as UTF-8)
1034in C<u>, C<ulen>. Returns 0 if they are
fed3ba5d
NC
1035equal, -1 or -2 if the first string is less than the second string, +1 or +2
1036if the first string is greater than the second string.
1037
1038-1 or +1 is returned if the shorter string was identical to the start of the
72d33970
FC
1039longer string. -2 or +2 is returned if
1040there was a difference between characters
fed3ba5d
NC
1041within the strings.
1042
1043=cut
1044*/
1045
1046int
1047Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
1048{
1049 const U8 *const bend = b + blen;
1050 const U8 *const uend = u + ulen;
1051
1052 PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
fed3ba5d
NC
1053
1054 while (b < bend && u < uend) {
1055 U8 c = *u++;
1056 if (!UTF8_IS_INVARIANT(c)) {
1057 if (UTF8_IS_DOWNGRADEABLE_START(c)) {
1058 if (u < uend) {
1059 U8 c1 = *u++;
1060 if (UTF8_IS_CONTINUATION(c1)) {
a62b247b 1061 c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
fed3ba5d
NC
1062 } else {
1063 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1064 "Malformed UTF-8 character "
1065 "(unexpected non-continuation byte 0x%02x"
1066 ", immediately after start byte 0x%02x)"
1067 /* Dear diag.t, it's in the pod. */
1068 "%s%s", c1, c,
1069 PL_op ? " in " : "",
1070 PL_op ? OP_DESC(PL_op) : "");
1071 return -2;
1072 }
1073 } else {
1074 if (PL_op)
1075 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1076 "%s in %s", unees, OP_DESC(PL_op));
1077 else
61a12c31 1078 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
fed3ba5d
NC
1079 return -2; /* Really want to return undef :-) */
1080 }
1081 } else {
1082 return -2;
1083 }
1084 }
1085 if (*b != c) {
1086 return *b < c ? -2 : +2;
1087 }
1088 ++b;
1089 }
1090
1091 if (b == bend && u == uend)
1092 return 0;
1093
1094 return b < bend ? +1 : -1;
1095}
1096
1097/*
87cea99e 1098=for apidoc utf8_to_bytes
6940069f 1099
2bbc8d55 1100Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954
KW
1101Unlike L</bytes_to_utf8>, this over-writes the original string, and
1102updates C<len> to contain the new length.
67e989fb 1103Returns zero on failure, setting C<len> to -1.
6940069f 1104
a1433954 1105If you need a copy of the string, see L</bytes_from_utf8>.
95be277c 1106
6940069f
GS
1107=cut
1108*/
1109
1110U8 *
37607a96 1111Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 1112{
d4c19fe8
AL
1113 U8 * const save = s;
1114 U8 * const send = s + *len;
6940069f 1115 U8 *d;
246fae53 1116
7918f24d 1117 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
81611534 1118 PERL_UNUSED_CONTEXT;
7918f24d 1119
1e54db1a 1120 /* ensure valid UTF-8 and chars < 256 before updating string */
d4c19fe8 1121 while (s < send) {
d59937ca
KW
1122 if (! UTF8_IS_INVARIANT(*s)) {
1123 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
1124 *len = ((STRLEN) -1);
1125 return 0;
1126 }
1127 s++;
dcad2880 1128 }
d59937ca 1129 s++;
246fae53 1130 }
dcad2880
JH
1131
1132 d = s = save;
6940069f 1133 while (s < send) {
80e0b38f
KW
1134 U8 c = *s++;
1135 if (! UTF8_IS_INVARIANT(c)) {
1136 /* Then it is two-byte encoded */
a62b247b 1137 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
80e0b38f
KW
1138 s++;
1139 }
1140 *d++ = c;
6940069f
GS
1141 }
1142 *d = '\0';
246fae53 1143 *len = d - save;
6940069f
GS
1144 return save;
1145}
1146
1147/*
87cea99e 1148=for apidoc bytes_from_utf8
f9a63242 1149
2bbc8d55 1150Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954 1151Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
1152the newly-created string, and updates C<len> to contain the new
1153length. Returns the original string if no conversion occurs, C<len>
72d33970 1154is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
2bbc8d55 11550 if C<s> is converted or consisted entirely of characters that are invariant
4a4088c4 1156in UTF-8 (i.e., US-ASCII on non-EBCDIC machines).
f9a63242 1157
37607a96
PK
1158=cut
1159*/
f9a63242
JH
1160
1161U8 *
e1ec3a88 1162Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 1163{
f9a63242 1164 U8 *d;
e1ec3a88
AL
1165 const U8 *start = s;
1166 const U8 *send;
f9a63242
JH
1167 I32 count = 0;
1168
7918f24d 1169 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
96a5add6 1170 PERL_UNUSED_CONTEXT;
f9a63242 1171 if (!*is_utf8)
73d840c0 1172 return (U8 *)start;
f9a63242 1173
1e54db1a 1174 /* ensure valid UTF-8 and chars < 256 before converting string */
f9a63242 1175 for (send = s + *len; s < send;) {
d59937ca
KW
1176 if (! UTF8_IS_INVARIANT(*s)) {
1177 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
73d840c0 1178 return (U8 *)start;
d59937ca
KW
1179 }
1180 count++;
1181 s++;
db42d148 1182 }
d59937ca 1183 s++;
f9a63242
JH
1184 }
1185
35da51f7 1186 *is_utf8 = FALSE;
f9a63242 1187
212542aa 1188 Newx(d, (*len) - count + 1, U8);
ef9edfd0 1189 s = start; start = d;
f9a63242
JH
1190 while (s < send) {
1191 U8 c = *s++;
1a91c45d 1192 if (! UTF8_IS_INVARIANT(c)) {
c4d5f83a 1193 /* Then it is two-byte encoded */
a62b247b 1194 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
1a91c45d 1195 s++;
c4d5f83a
NIS
1196 }
1197 *d++ = c;
f9a63242
JH
1198 }
1199 *d = '\0';
1200 *len = d - start;
73d840c0 1201 return (U8 *)start;
f9a63242
JH
1202}
1203
1204/*
87cea99e 1205=for apidoc bytes_to_utf8
6940069f 1206
ff97e5cf
KW
1207Converts a string C<s> of length C<len> bytes from the native encoding into
1208UTF-8.
6662521e 1209Returns a pointer to the newly-created string, and sets C<len> to
ff97e5cf 1210reflect the new length in bytes.
6940069f 1211
75200dff 1212A C<NUL> character will be written after the end of the string.
2bbc8d55
SP
1213
1214If you want to convert to UTF-8 from encodings other than
1215the native (Latin1 or EBCDIC),
a1433954 1216see L</sv_recode_to_utf8>().
c9ada85f 1217
497711e7 1218=cut
6940069f
GS
1219*/
1220
c682ebef
FC
1221/* This logic is duplicated in sv_catpvn_flags, so any bug fixes will
1222 likewise need duplication. */
1223
6940069f 1224U8*
35a4481c 1225Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
6940069f 1226{
35a4481c 1227 const U8 * const send = s + (*len);
6940069f
GS
1228 U8 *d;
1229 U8 *dst;
7918f24d
NC
1230
1231 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
96a5add6 1232 PERL_UNUSED_CONTEXT;
6940069f 1233
212542aa 1234 Newx(d, (*len) * 2 + 1, U8);
6940069f
GS
1235 dst = d;
1236
1237 while (s < send) {
55d09dc8
KW
1238 append_utf8_from_native_byte(*s, &d);
1239 s++;
6940069f
GS
1240 }
1241 *d = '\0';
6662521e 1242 *len = d-dst;
6940069f
GS
1243 return dst;
1244}
1245
a0ed51b3 1246/*
dea0fc0b 1247 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
1248 *
1249 * Destination must be pre-extended to 3/2 source. Do not use in-place.
1250 * We optimize for native, for obvious reasons. */
1251
1252U8*
dea0fc0b 1253Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 1254{
dea0fc0b
JH
1255 U8* pend;
1256 U8* dstart = d;
1257
7918f24d
NC
1258 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1259
dea0fc0b 1260 if (bytelen & 1)
f5992bc4 1261 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
dea0fc0b
JH
1262
1263 pend = p + bytelen;
1264
a0ed51b3 1265 while (p < pend) {
dea0fc0b
JH
1266 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1267 p += 2;
2d1545e5 1268 if (OFFUNI_IS_INVARIANT(uv)) {
56d37426 1269 *d++ = LATIN1_TO_NATIVE((U8) uv);
a0ed51b3
LW
1270 continue;
1271 }
56d37426
KW
1272 if (uv <= MAX_UTF8_TWO_BYTE) {
1273 *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv));
1274 *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv));
a0ed51b3
LW
1275 continue;
1276 }
46956fad
KW
1277#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
1278#define LAST_HIGH_SURROGATE 0xDBFF
1279#define FIRST_LOW_SURROGATE 0xDC00
1280#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
e23c50db
KW
1281
1282 /* This assumes that most uses will be in the first Unicode plane, not
1283 * needing surrogates */
1284 if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST
1285 && uv <= UNICODE_SURROGATE_LAST))
1286 {
1287 if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) {
1288 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1289 }
1290 else {
01ea242b 1291 UV low = (p[0] << 8) + p[1];
e23c50db
KW
1292 if ( UNLIKELY(low < FIRST_LOW_SURROGATE)
1293 || UNLIKELY(low > LAST_LOW_SURROGATE))
1294 {
01ea242b 1295 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
e23c50db
KW
1296 }
1297 p += 2;
46956fad
KW
1298 uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
1299 + (low - FIRST_LOW_SURROGATE) + 0x10000;
01ea242b 1300 }
a0ed51b3 1301 }
56d37426
KW
1302#ifdef EBCDIC
1303 d = uvoffuni_to_utf8_flags(d, uv, 0);
1304#else
a0ed51b3 1305 if (uv < 0x10000) {
eb160463
GS
1306 *d++ = (U8)(( uv >> 12) | 0xe0);
1307 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1308 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1309 continue;
1310 }
1311 else {
eb160463
GS
1312 *d++ = (U8)(( uv >> 18) | 0xf0);
1313 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1314 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1315 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
1316 continue;
1317 }
56d37426 1318#endif
a0ed51b3 1319 }
dea0fc0b 1320 *newlen = d - dstart;
a0ed51b3
LW
1321 return d;
1322}
1323
1324/* Note: this one is slightly destructive of the source. */
1325
1326U8*
dea0fc0b 1327Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
1328{
1329 U8* s = (U8*)p;
d4c19fe8 1330 U8* const send = s + bytelen;
7918f24d
NC
1331
1332 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1333
e0ea5e2d
NC
1334 if (bytelen & 1)
1335 Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1336 (UV)bytelen);
1337
a0ed51b3 1338 while (s < send) {
d4c19fe8 1339 const U8 tmp = s[0];
a0ed51b3
LW
1340 s[0] = s[1];
1341 s[1] = tmp;
1342 s += 2;
1343 }
dea0fc0b 1344 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
1345}
1346
922e8cb4
KW
1347bool
1348Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
1349{
1350 U8 tmpbuf[UTF8_MAXBYTES+1];
1351 uvchr_to_utf8(tmpbuf, c);
1352 return _is_utf8_FOO(classnum, tmpbuf);
1353}
1354
f9ae8fb6
JD
1355/* Internal function so we can deprecate the external one, and call
1356 this one from other deprecated functions in this file */
1357
f2645549
KW
1358bool
1359Perl__is_utf8_idstart(pTHX_ const U8 *p)
61b19385 1360{
f2645549 1361 PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
61b19385
KW
1362
1363 if (*p == '_')
1364 return TRUE;
f25ce844 1365 return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
61b19385
KW
1366}
1367
5092f92a 1368bool
eba68aa0
KW
1369Perl__is_uni_perl_idcont(pTHX_ UV c)
1370{
1371 U8 tmpbuf[UTF8_MAXBYTES+1];
1372 uvchr_to_utf8(tmpbuf, c);
1373 return _is_utf8_perl_idcont(tmpbuf);
1374}
1375
1376bool
f91dcd13
KW
1377Perl__is_uni_perl_idstart(pTHX_ UV c)
1378{
1379 U8 tmpbuf[UTF8_MAXBYTES+1];
1380 uvchr_to_utf8(tmpbuf, c);
1381 return _is_utf8_perl_idstart(tmpbuf);
1382}
1383
3a4c58c9
KW
1384UV
1385Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
1386{
1387 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 1388 * those, converting the result to UTF-8. The only difference between upper
3a4c58c9
KW
1389 * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
1390 * either "SS" or "Ss". Which one to use is passed into the routine in
1391 * 'S_or_s' to avoid a test */
1392
1393 UV converted = toUPPER_LATIN1_MOD(c);
1394
1395 PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
1396
1397 assert(S_or_s == 'S' || S_or_s == 's');
1398
6f2d5cbc 1399 if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for
f4cd282c 1400 characters in this range */
3a4c58c9
KW
1401 *p = (U8) converted;
1402 *lenp = 1;
1403 return converted;
1404 }
1405
1406 /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
1407 * which it maps to one of them, so as to only have to have one check for
1408 * it in the main case */
1409 if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
1410 switch (c) {
1411 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
1412 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
1413 break;
1414 case MICRO_SIGN:
1415 converted = GREEK_CAPITAL_LETTER_MU;
1416 break;
79e064b9
KW
1417#if UNICODE_MAJOR_VERSION > 2 \
1418 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
1419 && UNICODE_DOT_DOT_VERSION >= 8)
3a4c58c9
KW
1420 case LATIN_SMALL_LETTER_SHARP_S:
1421 *(p)++ = 'S';
1422 *p = S_or_s;
1423 *lenp = 2;
1424 return 'S';
79e064b9 1425#endif
3a4c58c9
KW
1426 default:
1427 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
e5964223 1428 NOT_REACHED; /* NOTREACHED */
3a4c58c9
KW
1429 }
1430 }
1431
1432 *(p)++ = UTF8_TWO_BYTE_HI(converted);
1433 *p = UTF8_TWO_BYTE_LO(converted);
1434 *lenp = 2;
1435
1436 return converted;
1437}
1438
50bda2c3
KW
1439/* Call the function to convert a UTF-8 encoded character to the specified case.
1440 * Note that there may be more than one character in the result.
1441 * INP is a pointer to the first byte of the input character
1442 * OUTP will be set to the first byte of the string of changed characters. It
1443 * needs to have space for UTF8_MAXBYTES_CASE+1 bytes
1444 * LENP will be set to the length in bytes of the string of changed characters
1445 *
1446 * The functions return the ordinal of the first character in the string of OUTP */
4a8240a3
KW
1447#define CALL_UPPER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_toupper, "ToUc", "")
1448#define CALL_TITLE_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_totitle, "ToTc", "")
1449#define CALL_LOWER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tolower, "ToLc", "")
50bda2c3
KW
1450
1451/* This additionally has the input parameter SPECIALS, which if non-zero will
1452 * cause this to use the SPECIALS hash for folding (meaning get full case
1453 * folding); otherwise, when zero, this implies a simple case fold */
4a8240a3 1454#define CALL_FOLD_CASE(INP, OUTP, LENP, SPECIALS) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tofold, "ToCf", (SPECIALS) ? "" : NULL)
c3fd2246 1455
84afefe6
JH
1456UV
1457Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1458{
a1433954
KW
1459 /* Convert the Unicode character whose ordinal is <c> to its uppercase
1460 * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
1461 * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
c3fd2246
KW
1462 * the changed version may be longer than the original character.
1463 *
1464 * The ordinal of the first character of the changed version is returned
1465 * (but note, as explained above, that there may be more.) */
1466
7918f24d
NC
1467 PERL_ARGS_ASSERT_TO_UNI_UPPER;
1468
3a4c58c9
KW
1469 if (c < 256) {
1470 return _to_upper_title_latin1((U8) c, p, lenp, 'S');
1471 }
1472
0ebc6274 1473 uvchr_to_utf8(p, c);
3a4c58c9 1474 return CALL_UPPER_CASE(p, p, lenp);
a0ed51b3
LW
1475}
1476
84afefe6
JH
1477UV
1478Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1479{
7918f24d
NC
1480 PERL_ARGS_ASSERT_TO_UNI_TITLE;
1481
3a4c58c9
KW
1482 if (c < 256) {
1483 return _to_upper_title_latin1((U8) c, p, lenp, 's');
1484 }
1485
0ebc6274 1486 uvchr_to_utf8(p, c);
3a4c58c9 1487 return CALL_TITLE_CASE(p, p, lenp);
a0ed51b3
LW
1488}
1489
afc16117 1490STATIC U8
81611534 1491S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp)
afc16117
KW
1492{
1493 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 1494 * those, converting the result to UTF-8. Since the result is always just
a1433954 1495 * one character, we allow <p> to be NULL */
afc16117
KW
1496
1497 U8 converted = toLOWER_LATIN1(c);
1498
1499 if (p != NULL) {
6f2d5cbc 1500 if (NATIVE_BYTE_IS_INVARIANT(converted)) {
afc16117
KW
1501 *p = converted;
1502 *lenp = 1;
1503 }
1504 else {
430c9760
KW
1505 /* Result is known to always be < 256, so can use the EIGHT_BIT
1506 * macros */
1507 *p = UTF8_EIGHT_BIT_HI(converted);
1508 *(p+1) = UTF8_EIGHT_BIT_LO(converted);
afc16117
KW
1509 *lenp = 2;
1510 }
1511 }
1512 return converted;
1513}
1514
84afefe6
JH
1515UV
1516Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 1517{
7918f24d
NC
1518 PERL_ARGS_ASSERT_TO_UNI_LOWER;
1519
afc16117
KW
1520 if (c < 256) {
1521 return to_lower_latin1((U8) c, p, lenp);
bca00c02
KW
1522 }
1523
afc16117 1524 uvchr_to_utf8(p, c);
968c5e6a 1525 return CALL_LOWER_CASE(p, p, lenp);
a0ed51b3
LW
1526}
1527
84afefe6 1528UV
51910141 1529Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int flags)
a1dde8de 1530{
51910141 1531 /* Corresponds to to_lower_latin1(); <flags> bits meanings:
1ca267a5 1532 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
51910141 1533 * FOLD_FLAGS_FULL iff full folding is to be used;
1ca267a5
KW
1534 *
1535 * Not to be used for locale folds
51910141 1536 */
f673fad4 1537
a1dde8de
KW
1538 UV converted;
1539
1540 PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
81611534 1541 PERL_UNUSED_CONTEXT;
a1dde8de 1542
1ca267a5
KW
1543 assert (! (flags & FOLD_FLAGS_LOCALE));
1544
a1dde8de
KW
1545 if (c == MICRO_SIGN) {
1546 converted = GREEK_SMALL_LETTER_MU;
1547 }
9b63e895
KW
1548#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
1549 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
1550 || UNICODE_DOT_DOT_VERSION > 0)
51910141 1551 else if ((flags & FOLD_FLAGS_FULL) && c == LATIN_SMALL_LETTER_SHARP_S) {
1ca267a5
KW
1552
1553 /* If can't cross 127/128 boundary, can't return "ss"; instead return
1554 * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}")
1555 * under those circumstances. */
1556 if (flags & FOLD_FLAGS_NOMIX_ASCII) {
1557 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
1558 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
1559 p, *lenp, U8);
1560 return LATIN_SMALL_LETTER_LONG_S;
1561 }
1562 else {
4f489194
KW
1563 *(p)++ = 's';
1564 *p = 's';
1565 *lenp = 2;
1566 return 's';
1ca267a5 1567 }
a1dde8de 1568 }
9b63e895 1569#endif
a1dde8de
KW
1570 else { /* In this range the fold of all other characters is their lower
1571 case */
1572 converted = toLOWER_LATIN1(c);
1573 }
1574
6f2d5cbc 1575 if (UVCHR_IS_INVARIANT(converted)) {
a1dde8de
KW
1576 *p = (U8) converted;
1577 *lenp = 1;
1578 }
1579 else {
1580 *(p)++ = UTF8_TWO_BYTE_HI(converted);
1581 *p = UTF8_TWO_BYTE_LO(converted);
1582 *lenp = 2;
1583 }
1584
1585 return converted;
1586}
1587
1588UV
31f05a37 1589Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
84afefe6 1590{
4b593389 1591
a0270393
KW
1592 /* Not currently externally documented, and subject to change
1593 * <flags> bits meanings:
1594 * FOLD_FLAGS_FULL iff full folding is to be used;
31f05a37
KW
1595 * FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
1596 * locale are to be used.
a0270393
KW
1597 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
1598 */
4b593389 1599
36bb2ab6 1600 PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
7918f24d 1601
780fcc9f
KW
1602 if (flags & FOLD_FLAGS_LOCALE) {
1603 /* Treat a UTF-8 locale as not being in locale at all */
1604 if (IN_UTF8_CTYPE_LOCALE) {
1605 flags &= ~FOLD_FLAGS_LOCALE;
1606 }
1607 else {
1608 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
e7b7ac46 1609 goto needs_full_generality;
780fcc9f 1610 }
31f05a37
KW
1611 }
1612
a1dde8de 1613 if (c < 256) {
e7b7ac46 1614 return _to_fold_latin1((U8) c, p, lenp,
31f05a37 1615 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
a1dde8de
KW
1616 }
1617
2f306ab9 1618 /* Here, above 255. If no special needs, just use the macro */
a0270393
KW
1619 if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
1620 uvchr_to_utf8(p, c);
1621 return CALL_FOLD_CASE(p, p, lenp, flags & FOLD_FLAGS_FULL);
1622 }
1623 else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with
1624 the special flags. */
1625 U8 utf8_c[UTF8_MAXBYTES + 1];
e7b7ac46
KW
1626
1627 needs_full_generality:
a0270393 1628 uvchr_to_utf8(utf8_c, c);
445bf929 1629 return _to_utf8_fold_flags(utf8_c, p, lenp, flags);
a0270393 1630 }
84afefe6
JH
1631}
1632
26483009 1633PERL_STATIC_INLINE bool
5141f98e 1634S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
f25ce844 1635 const char *const swashname, SV* const invlist)
bde6a22d 1636{
ea317ccb
KW
1637 /* returns a boolean giving whether or not the UTF8-encoded character that
1638 * starts at <p> is in the swash indicated by <swashname>. <swash>
1639 * contains a pointer to where the swash indicated by <swashname>
1640 * is to be stored; which this routine will do, so that future calls will
f25ce844
KW
1641 * look at <*swash> and only generate a swash if it is not null. <invlist>
1642 * is NULL or an inversion list that defines the swash. If not null, it
1643 * saves time during initialization of the swash.
ea317ccb
KW
1644 *
1645 * Note that it is assumed that the buffer length of <p> is enough to
1646 * contain all the bytes that comprise the character. Thus, <*p> should
1647 * have been checked before this call for mal-formedness enough to assure
1648 * that. */
1649
7918f24d
NC
1650 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1651
492a624f 1652 /* The API should have included a length for the UTF-8 character in <p>,
28123549 1653 * but it doesn't. We therefore assume that p has been validated at least
492a624f
KW
1654 * as far as there being enough bytes available in it to accommodate the
1655 * character without reading beyond the end, and pass that number on to the
1656 * validating routine */
6302f837 1657 if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
28123549
KW
1658 if (ckWARN_d(WARN_UTF8)) {
1659 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED,WARN_UTF8),
9816f121 1660 "Passing malformed UTF-8 to \"%s\" is deprecated", swashname);
28123549
KW
1661 if (ckWARN(WARN_UTF8)) { /* This will output details as to the
1662 what the malformation is */
1663 utf8_to_uvchr_buf(p, p + UTF8SKIP(p), NULL);
1664 }
1665 }
1666 return FALSE;
1667 }
87367d5f
KW
1668 if (!*swash) {
1669 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
f25ce844
KW
1670 *swash = _core_swash_init("utf8",
1671
1672 /* Only use the name if there is no inversion
1673 * list; otherwise will go out to disk */
1674 (invlist) ? "" : swashname,
1675
1676 &PL_sv_undef, 1, 0, invlist, &flags);
87367d5f 1677 }
28123549 1678
bde6a22d
NC
1679 return swash_fetch(*swash, p, TRUE) != 0;
1680}
1681
1682bool
922e8cb4
KW
1683Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
1684{
922e8cb4
KW
1685 PERL_ARGS_ASSERT__IS_UTF8_FOO;
1686
1687 assert(classnum < _FIRST_NON_SWASH_CC);
1688
f25ce844
KW
1689 return is_utf8_common(p,
1690 &PL_utf8_swash_ptrs[classnum],
1691 swash_property_names[classnum],
1692 PL_XPosix_ptrs[classnum]);
922e8cb4
KW
1693}
1694
1695bool
f2645549 1696Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
a0ed51b3 1697{
f2645549 1698 SV* invlist = NULL;
7918f24d 1699
f2645549 1700 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
7918f24d 1701
f2645549
KW
1702 if (! PL_utf8_perl_idstart) {
1703 invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
1704 }
60071a22 1705 return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart", invlist);
82686b01
JH
1706}
1707
1708bool
f2645549 1709Perl__is_utf8_xidstart(pTHX_ const U8 *p)
c11ff943 1710{
f2645549 1711 PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
c11ff943
KW
1712
1713 if (*p == '_')
1714 return TRUE;
f25ce844 1715 return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
c11ff943
KW
1716}
1717
1718bool
eba68aa0
KW
1719Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
1720{
b24b43f7 1721 SV* invlist = NULL;
eba68aa0
KW
1722
1723 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
1724
b24b43f7
KW
1725 if (! PL_utf8_perl_idcont) {
1726 invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
1727 }
60071a22 1728 return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont", invlist);
eba68aa0
KW
1729}
1730
eba68aa0 1731bool
f2645549 1732Perl__is_utf8_idcont(pTHX_ const U8 *p)
82686b01 1733{
f2645549 1734 PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
7918f24d 1735
f25ce844 1736 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
a0ed51b3
LW
1737}
1738
1739bool
f2645549 1740Perl__is_utf8_xidcont(pTHX_ const U8 *p)
c11ff943 1741{
f2645549 1742 PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
c11ff943 1743
f25ce844 1744 return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
c11ff943
KW
1745}
1746
1747bool
7dbf68d2
KW
1748Perl__is_utf8_mark(pTHX_ const U8 *p)
1749{
7dbf68d2
KW
1750 PERL_ARGS_ASSERT__IS_UTF8_MARK;
1751
f25ce844 1752 return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
7dbf68d2
KW
1753}
1754
6b5c0936 1755/*
87cea99e 1756=for apidoc to_utf8_case
6b5c0936 1757
6fae5207 1758C<p> contains the pointer to the UTF-8 string encoding
a1433954
KW
1759the character that is being converted. This routine assumes that the character
1760at C<p> is well-formed.
6b5c0936 1761
6fae5207
KW
1762C<ustrp> is a pointer to the character buffer to put the
1763conversion result to. C<lenp> is a pointer to the length
6b5c0936
JH
1764of the result.
1765
6fae5207 1766C<swashp> is a pointer to the swash to use.
6b5c0936 1767
a1433954 1768Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
796b6530 1769and loaded by C<SWASHNEW>, using F<lib/utf8_heavy.pl>. C<special> (usually,
0134edef 1770but not always, a multicharacter mapping), is tried first.
6b5c0936 1771
4a8240a3
KW
1772C<special> is a string, normally C<NULL> or C<"">. C<NULL> means to not use
1773any special mappings; C<""> means to use the special mappings. Values other
1774than these two are treated as the name of the hash containing the special
1775mappings, like C<"utf8::ToSpecLower">.
6b5c0936 1776
796b6530
KW
1777C<normal> is a string like C<"ToLower"> which means the swash
1778C<%utf8::ToLower>.
0134edef
JH
1779
1780=cut */
6b5c0936 1781
2104c8d9 1782UV
9a957fbc
AL
1783Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1784 SV **swashp, const char *normal, const char *special)
a0ed51b3 1785{
0134edef 1786 STRLEN len = 0;
f4cd282c 1787 const UV uv1 = valid_utf8_to_uvchr(p, NULL);
7918f24d
NC
1788
1789 PERL_ARGS_ASSERT_TO_UTF8_CASE;
1790
9ae3ac1a
KW
1791 /* Note that swash_fetch() doesn't output warnings for these because it
1792 * assumes we will */
8457b38f 1793 if (uv1 >= UNICODE_SURROGATE_FIRST) {
9ae3ac1a 1794 if (uv1 <= UNICODE_SURROGATE_LAST) {
8457b38f
KW
1795 if (ckWARN_d(WARN_SURROGATE)) {
1796 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
1797 Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
1798 "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1);
1799 }
9ae3ac1a
KW
1800 }
1801 else if (UNICODE_IS_SUPER(uv1)) {
8457b38f
KW
1802 if (ckWARN_d(WARN_NON_UNICODE)) {
1803 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
1804 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
1805 "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1);
1806 }
9ae3ac1a
KW
1807 }
1808
1809 /* Note that non-characters are perfectly legal, so no warning should
1810 * be given */
1811 }
1812
0134edef 1813 if (!*swashp) /* load on-demand */
5ab9d2ef 1814 *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
0134edef 1815
a6f87d8c 1816 if (special) {
0134edef 1817 /* It might be "special" (sometimes, but not always,
2a37f04d 1818 * a multicharacter mapping) */
4a8240a3 1819 HV *hv = NULL;
b08cf34e
JH
1820 SV **svp;
1821
4a8240a3
KW
1822 /* If passed in the specials name, use that; otherwise use any
1823 * given in the swash */
1824 if (*special != '\0') {
1825 hv = get_hv(special, 0);
1826 }
1827 else {
1828 svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0);
1829 if (svp) {
1830 hv = MUTABLE_HV(SvRV(*svp));
1831 }
1832 }
1833
176fe009 1834 if (hv
5f560d8a 1835 && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
176fe009
KW
1836 && (*svp))
1837 {
cfd0369c 1838 const char *s;
47654450 1839
cfd0369c 1840 s = SvPV_const(*svp, len);
47654450 1841 if (len == 1)
f4cd282c 1842 /* EIGHTBIT */
c80e42f3 1843 len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp;
2a37f04d 1844 else {
d2dcd0fb 1845 Copy(s, ustrp, len, U8);
29e98929 1846 }
983ffd37 1847 }
0134edef
JH
1848 }
1849
1850 if (!len && *swashp) {
4a4088c4 1851 const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
d4c19fe8 1852
0134edef
JH
1853 if (uv2) {
1854 /* It was "normal" (a single character mapping). */
f4cd282c 1855 len = uvchr_to_utf8(ustrp, uv2) - ustrp;
2a37f04d
JH
1856 }
1857 }
1feea2c7 1858
cbe07460
KW
1859 if (len) {
1860 if (lenp) {
1861 *lenp = len;
1862 }
1863 return valid_utf8_to_uvchr(ustrp, 0);
1864 }
1865
1866 /* Here, there was no mapping defined, which means that the code point maps
1867 * to itself. Return the inputs */
bfdf22ec 1868 len = UTF8SKIP(p);
ca9fab46
KW
1869 if (p != ustrp) { /* Don't copy onto itself */
1870 Copy(p, ustrp, len, U8);
1871 }
0134edef 1872
2a37f04d
JH
1873 if (lenp)
1874 *lenp = len;
1875
f4cd282c 1876 return uv1;
cbe07460 1877
a0ed51b3
LW
1878}
1879
051a06d4 1880STATIC UV
357aadde 1881S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
051a06d4 1882{
4a4088c4 1883 /* This is called when changing the case of a UTF-8-encoded character above
31f05a37
KW
1884 * the Latin1 range, and the operation is in a non-UTF-8 locale. If the
1885 * result contains a character that crosses the 255/256 boundary, disallow
1886 * the change, and return the original code point. See L<perlfunc/lc> for
1887 * why;
051a06d4 1888 *
a1433954
KW
1889 * p points to the original string whose case was changed; assumed
1890 * by this routine to be well-formed
051a06d4
KW
1891 * result the code point of the first character in the changed-case string
1892 * ustrp points to the changed-case string (<result> represents its first char)
1893 * lenp points to the length of <ustrp> */
1894
1895 UV original; /* To store the first code point of <p> */
1896
1897 PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
1898
a4f12ed7 1899 assert(UTF8_IS_ABOVE_LATIN1(*p));
051a06d4
KW
1900
1901 /* We know immediately if the first character in the string crosses the
1902 * boundary, so can skip */
1903 if (result > 255) {
1904
1905 /* Look at every character in the result; if any cross the
1906 * boundary, the whole thing is disallowed */
1907 U8* s = ustrp + UTF8SKIP(ustrp);
1908 U8* e = ustrp + *lenp;
1909 while (s < e) {
a4f12ed7 1910 if (! UTF8_IS_ABOVE_LATIN1(*s)) {
051a06d4
KW
1911 goto bad_crossing;
1912 }
1913 s += UTF8SKIP(s);
1914 }
1915
613abc6d
KW
1916 /* Here, no characters crossed, result is ok as-is, but we warn. */
1917 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p));
051a06d4
KW
1918 return result;
1919 }
1920
7b52d656 1921 bad_crossing:
051a06d4
KW
1922
1923 /* Failed, have to return the original */
4b88fb76 1924 original = valid_utf8_to_uvchr(p, lenp);
ab0b796c
KW
1925
1926 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
1927 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1928 "Can't do %s(\"\\x{%"UVXf"}\") on non-UTF-8 locale; "
1929 "resolved to \"\\x{%"UVXf"}\".",
357aadde 1930 OP_DESC(PL_op),
ab0b796c
KW
1931 original,
1932 original);
051a06d4
KW
1933 Copy(p, ustrp, *lenp, char);
1934 return original;
1935}
1936
d3e79532 1937/*
87cea99e 1938=for apidoc to_utf8_upper
d3e79532 1939
1f607577 1940Instead use L</toUPPER_utf8>.
a1433954 1941
d3e79532
JH
1942=cut */
1943
051a06d4 1944/* Not currently externally documented, and subject to change:
31f05a37
KW
1945 * <flags> is set iff iff the rules from the current underlying locale are to
1946 * be used. */
051a06d4 1947
2104c8d9 1948UV
31f05a37 1949Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
a0ed51b3 1950{
051a06d4
KW
1951 UV result;
1952
1953 PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
7918f24d 1954
780fcc9f
KW
1955 if (flags) {
1956 /* Treat a UTF-8 locale as not being in locale at all */
1957 if (IN_UTF8_CTYPE_LOCALE) {
1958 flags = FALSE;
1959 }
1960 else {
1961 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1962 }
31f05a37
KW
1963 }
1964
3a4c58c9 1965 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
1966 if (flags) {
1967 result = toUPPER_LC(*p);
1968 }
1969 else {
81c6c7ce 1970 return _to_upper_title_latin1(*p, ustrp, lenp, 'S');
051a06d4 1971 }
3a4c58c9
KW
1972 }
1973 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4 1974 if (flags) {
a62b247b 1975 U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
68067e4e 1976 result = toUPPER_LC(c);
051a06d4
KW
1977 }
1978 else {
a62b247b 1979 return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
81c6c7ce 1980 ustrp, lenp, 'S');
051a06d4
KW
1981 }
1982 }
4a4088c4 1983 else { /* UTF-8, ord above 255 */
051a06d4
KW
1984 result = CALL_UPPER_CASE(p, ustrp, lenp);
1985
1986 if (flags) {
357aadde 1987 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4
KW
1988 }
1989 return result;
1990 }
1991
4a4088c4 1992 /* Here, used locale rules. Convert back to UTF-8 */
051a06d4
KW
1993 if (UTF8_IS_INVARIANT(result)) {
1994 *ustrp = (U8) result;
1995 *lenp = 1;
1996 }
1997 else {
62cb07ea
KW
1998 *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
1999 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
051a06d4 2000 *lenp = 2;
3a4c58c9 2001 }
baa60164 2002
051a06d4 2003 return result;
983ffd37 2004}
a0ed51b3 2005
d3e79532 2006/*
87cea99e 2007=for apidoc to_utf8_title
d3e79532 2008
1f607577 2009Instead use L</toTITLE_utf8>.
a1433954 2010
d3e79532
JH
2011=cut */
2012
051a06d4 2013/* Not currently externally documented, and subject to change:
31f05a37
KW
2014 * <flags> is set iff the rules from the current underlying locale are to be
2015 * used. Since titlecase is not defined in POSIX, for other than a
2016 * UTF-8 locale, uppercase is used instead for code points < 256.
445bf929 2017 */
051a06d4 2018
983ffd37 2019UV
31f05a37 2020Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
983ffd37 2021{
051a06d4
KW
2022 UV result;
2023
2024 PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
7918f24d 2025
780fcc9f
KW
2026 if (flags) {
2027 /* Treat a UTF-8 locale as not being in locale at all */
2028 if (IN_UTF8_CTYPE_LOCALE) {
2029 flags = FALSE;
2030 }
2031 else {
2032 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2033 }
31f05a37
KW
2034 }
2035
3a4c58c9 2036 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
2037 if (flags) {
2038 result = toUPPER_LC(*p);
2039 }
2040 else {
81c6c7ce 2041 return _to_upper_title_latin1(*p, ustrp, lenp, 's');
051a06d4 2042 }
3a4c58c9
KW
2043 }
2044 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4 2045 if (flags) {
a62b247b 2046 U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
68067e4e 2047 result = toUPPER_LC(c);
051a06d4
KW
2048 }
2049 else {
a62b247b 2050 return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
81c6c7ce 2051 ustrp, lenp, 's');
051a06d4
KW
2052 }
2053 }
4a4088c4 2054 else { /* UTF-8, ord above 255 */
051a06d4
KW
2055 result = CALL_TITLE_CASE(p, ustrp, lenp);
2056
2057 if (flags) {
357aadde 2058 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4
KW
2059 }
2060 return result;
2061 }
2062
4a4088c4 2063 /* Here, used locale rules. Convert back to UTF-8 */
051a06d4
KW
2064 if (UTF8_IS_INVARIANT(result)) {
2065 *ustrp = (U8) result;
2066 *lenp = 1;
2067 }
2068 else {
62cb07ea
KW
2069 *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
2070 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
051a06d4 2071 *lenp = 2;
3a4c58c9
KW
2072 }
2073
051a06d4 2074 return result;
a0ed51b3
LW
2075}
2076
d3e79532 2077/*
87cea99e 2078=for apidoc to_utf8_lower
d3e79532 2079
1f607577 2080Instead use L</toLOWER_utf8>.
a1433954 2081
d3e79532
JH
2082=cut */
2083
051a06d4 2084/* Not currently externally documented, and subject to change:
31f05a37
KW
2085 * <flags> is set iff iff the rules from the current underlying locale are to
2086 * be used.
2087 */
051a06d4 2088
2104c8d9 2089UV
31f05a37 2090Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
a0ed51b3 2091{
051a06d4
KW
2092 UV result;
2093
051a06d4 2094 PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
7918f24d 2095
780fcc9f
KW
2096 if (flags) {
2097 /* Treat a UTF-8 locale as not being in locale at all */
2098 if (IN_UTF8_CTYPE_LOCALE) {
2099 flags = FALSE;
2100 }
2101 else {
2102 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2103 }
31f05a37
KW
2104 }
2105
968c5e6a 2106 if (UTF8_IS_INVARIANT(*p)) {
051a06d4
KW
2107 if (flags) {
2108 result = toLOWER_LC(*p);
2109 }
2110 else {
81c6c7ce 2111 return to_lower_latin1(*p, ustrp, lenp);
051a06d4 2112 }
968c5e6a
KW
2113 }
2114 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4 2115 if (flags) {
a62b247b 2116 U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
68067e4e 2117 result = toLOWER_LC(c);
051a06d4
KW
2118 }
2119 else {
a62b247b 2120 return to_lower_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
81c6c7ce 2121 ustrp, lenp);
051a06d4 2122 }
968c5e6a 2123 }
4a4088c4 2124 else { /* UTF-8, ord above 255 */
051a06d4
KW
2125 result = CALL_LOWER_CASE(p, ustrp, lenp);
2126
2127 if (flags) {
357aadde 2128 result = check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4 2129 }
968c5e6a 2130
051a06d4
KW
2131 return result;
2132 }
2133
4a4088c4 2134 /* Here, used locale rules. Convert back to UTF-8 */
051a06d4
KW
2135 if (UTF8_IS_INVARIANT(result)) {
2136 *ustrp = (U8) result;
2137 *lenp = 1;
2138 }
2139 else {
62cb07ea
KW
2140 *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
2141 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
051a06d4
KW
2142 *lenp = 2;
2143 }
2144
051a06d4 2145 return result;
b4e400f9
JH
2146}
2147
d3e79532 2148/*
87cea99e 2149=for apidoc to_utf8_fold
d3e79532 2150
1f607577 2151Instead use L</toFOLD_utf8>.
a1433954 2152
d3e79532
JH
2153=cut */
2154
051a06d4
KW
2155/* Not currently externally documented, and subject to change,
2156 * in <flags>
31f05a37
KW
2157 * bit FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
2158 * locale are to be used.
051a06d4
KW
2159 * bit FOLD_FLAGS_FULL is set iff full case folds are to be used;
2160 * otherwise simple folds
a0270393
KW
2161 * bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are
2162 * prohibited
445bf929 2163 */
36bb2ab6 2164
b4e400f9 2165UV
445bf929 2166Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
b4e400f9 2167{
051a06d4
KW
2168 UV result;
2169
36bb2ab6 2170 PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
7918f24d 2171
a0270393
KW
2172 /* These are mutually exclusive */
2173 assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
2174
50ba90ff
KW
2175 assert(p != ustrp); /* Otherwise overwrites */
2176
780fcc9f
KW
2177 if (flags & FOLD_FLAGS_LOCALE) {
2178 /* Treat a UTF-8 locale as not being in locale at all */
2179 if (IN_UTF8_CTYPE_LOCALE) {
2180 flags &= ~FOLD_FLAGS_LOCALE;
2181 }
2182 else {
2183 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2184 }
31f05a37
KW
2185 }
2186
a1dde8de 2187 if (UTF8_IS_INVARIANT(*p)) {
051a06d4 2188 if (flags & FOLD_FLAGS_LOCALE) {
d22b930b 2189 result = toFOLD_LC(*p);
051a06d4
KW
2190 }
2191 else {
81c6c7ce 2192 return _to_fold_latin1(*p, ustrp, lenp,
1ca267a5 2193 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
051a06d4 2194 }
a1dde8de
KW
2195 }
2196 else if UTF8_IS_DOWNGRADEABLE_START(*p) {
051a06d4 2197 if (flags & FOLD_FLAGS_LOCALE) {
a62b247b 2198 U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
68067e4e 2199 result = toFOLD_LC(c);
051a06d4
KW
2200 }
2201 else {
a62b247b 2202 return _to_fold_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
51910141 2203 ustrp, lenp,
1ca267a5 2204 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
051a06d4 2205 }
a1dde8de 2206 }
4a4088c4 2207 else { /* UTF-8, ord above 255 */
a0270393 2208 result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
a1dde8de 2209
1ca267a5
KW
2210 if (flags & FOLD_FLAGS_LOCALE) {
2211
76f2ffcd 2212# define LONG_S_T LATIN_SMALL_LIGATURE_LONG_S_T_UTF8
0766489e
KW
2213 const unsigned int long_s_t_len = sizeof(LONG_S_T) - 1;
2214
2215# ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8
2216# define CAP_SHARP_S LATIN_CAPITAL_LETTER_SHARP_S_UTF8
76f2ffcd
KW
2217
2218 const unsigned int cap_sharp_s_len = sizeof(CAP_SHARP_S) - 1;
76f2ffcd 2219
538e84ed
KW
2220 /* Special case these two characters, as what normally gets
2221 * returned under locale doesn't work */
76f2ffcd
KW
2222 if (UTF8SKIP(p) == cap_sharp_s_len
2223 && memEQ((char *) p, CAP_SHARP_S, cap_sharp_s_len))
1ca267a5 2224 {
ab0b796c
KW
2225 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
2226 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2227 "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
2228 "resolved to \"\\x{17F}\\x{17F}\".");
1ca267a5
KW
2229 goto return_long_s;
2230 }
0766489e
KW
2231 else
2232#endif
2233 if (UTF8SKIP(p) == long_s_t_len
76f2ffcd 2234 && memEQ((char *) p, LONG_S_T, long_s_t_len))
9fc2026f 2235 {
ab0b796c
KW
2236 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
2237 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2238 "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
2239 "resolved to \"\\x{FB06}\".");
9fc2026f
KW
2240 goto return_ligature_st;
2241 }
74894415
KW
2242
2243#if UNICODE_MAJOR_VERSION == 3 \
2244 && UNICODE_DOT_VERSION == 0 \
2245 && UNICODE_DOT_DOT_VERSION == 1
2246# define DOTTED_I LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE_UTF8
2247
2248 /* And special case this on this Unicode version only, for the same
2249 * reaons the other two are special cased. They would cross the
2250 * 255/256 boundary which is forbidden under /l, and so the code
2251 * wouldn't catch that they are equivalent (which they are only in
2252 * this release) */
2253 else if (UTF8SKIP(p) == sizeof(DOTTED_I) - 1
2254 && memEQ((char *) p, DOTTED_I, sizeof(DOTTED_I) - 1))
2255 {
2256 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
2257 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2258 "Can't do fc(\"\\x{0130}\") on non-UTF-8 locale; "
2259 "resolved to \"\\x{0131}\".");
2260 goto return_dotless_i;
2261 }
2262#endif
2263
357aadde 2264 return check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4 2265 }
a0270393
KW
2266 else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
2267 return result;
2268 }
2269 else {
4a4088c4 2270 /* This is called when changing the case of a UTF-8-encoded
9fc2026f
KW
2271 * character above the ASCII range, and the result should not
2272 * contain an ASCII character. */
a0270393
KW
2273
2274 UV original; /* To store the first code point of <p> */
2275
2276 /* Look at every character in the result; if any cross the
2277 * boundary, the whole thing is disallowed */
2278 U8* s = ustrp;
2279 U8* e = ustrp + *lenp;
2280 while (s < e) {
2281 if (isASCII(*s)) {
2282 /* Crossed, have to return the original */
2283 original = valid_utf8_to_uvchr(p, lenp);
1ca267a5 2284
9fc2026f 2285 /* But in these instances, there is an alternative we can
1ca267a5 2286 * return that is valid */
0766489e
KW
2287 if (original == LATIN_SMALL_LETTER_SHARP_S
2288#ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
2289 || original == LATIN_CAPITAL_LETTER_SHARP_S
2290#endif
2291 ) {
1ca267a5
KW
2292 goto return_long_s;
2293 }
9fc2026f
KW
2294 else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) {
2295 goto return_ligature_st;
2296 }
74894415
KW
2297#if UNICODE_MAJOR_VERSION == 3 \
2298 && UNICODE_DOT_VERSION == 0 \
2299 && UNICODE_DOT_DOT_VERSION == 1
2300
2301 else if (original == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
2302 goto return_dotless_i;
2303 }
2304#endif
a0270393
KW
2305 Copy(p, ustrp, *lenp, char);
2306 return original;
2307 }
2308 s += UTF8SKIP(s);
2309 }
051a06d4 2310
a0270393
KW
2311 /* Here, no characters crossed, result is ok as-is */
2312 return result;
2313 }
051a06d4
KW
2314 }
2315
4a4088c4 2316 /* Here, used locale rules. Convert back to UTF-8 */
051a06d4
KW
2317 if (UTF8_IS_INVARIANT(result)) {
2318 *ustrp = (U8) result;
2319 *lenp = 1;
2320 }
2321 else {
62cb07ea
KW
2322 *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
2323 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
051a06d4
KW
2324 *lenp = 2;
2325 }
2326
051a06d4 2327 return result;
1ca267a5
KW
2328
2329 return_long_s:
2330 /* Certain folds to 'ss' are prohibited by the options, but they do allow
2331 * folds to a string of two of these characters. By returning this
2332 * instead, then, e.g.,
2333 * fc("\x{1E9E}") eq fc("\x{17F}\x{17F}")
2334 * works. */
2335
2336 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
2337 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
2338 ustrp, *lenp, U8);
2339 return LATIN_SMALL_LETTER_LONG_S;
9fc2026f
KW
2340
2341 return_ligature_st:
2342 /* Two folds to 'st' are prohibited by the options; instead we pick one and
2343 * have the other one fold to it */
2344
2345 *lenp = sizeof(LATIN_SMALL_LIGATURE_ST_UTF8) - 1;
2346 Copy(LATIN_SMALL_LIGATURE_ST_UTF8, ustrp, *lenp, U8);
2347 return LATIN_SMALL_LIGATURE_ST;
74894415
KW
2348
2349#if UNICODE_MAJOR_VERSION == 3 \
2350 && UNICODE_DOT_VERSION == 0 \
2351 && UNICODE_DOT_DOT_VERSION == 1
2352
2353 return_dotless_i:
2354 *lenp = sizeof(LATIN_SMALL_LETTER_DOTLESS_I_UTF8) - 1;
2355 Copy(LATIN_SMALL_LETTER_DOTLESS_I_UTF8, ustrp, *lenp, U8);
2356 return LATIN_SMALL_LETTER_DOTLESS_I;
2357
2358#endif
2359
a0ed51b3
LW
2360}
2361
711a919c 2362/* Note:
f90a9a02 2363 * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().
711a919c
ST
2364 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
2365 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
2366 */
c4a5db0c 2367
a0ed51b3 2368SV*
7fc63493 2369Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3 2370{
c4a5db0c
KW
2371 PERL_ARGS_ASSERT_SWASH_INIT;
2372
2373 /* Returns a copy of a swash initiated by the called function. This is the
2374 * public interface, and returning a copy prevents others from doing
2375 * mischief on the original */
2376
5d3d13d1 2377 return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, NULL, NULL));
c4a5db0c
KW
2378}
2379
2380SV*
5d3d13d1 2381Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
c4a5db0c 2382{
2c1f00b9
YO
2383
2384 /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
2385 * use the following define */
2386
2387#define CORE_SWASH_INIT_RETURN(x) \
2388 PL_curpm= old_PL_curpm; \
2389 return x
2390
c4a5db0c 2391 /* Initialize and return a swash, creating it if necessary. It does this
87367d5f
KW
2392 * by calling utf8_heavy.pl in the general case. The returned value may be
2393 * the swash's inversion list instead if the input parameters allow it.
2394 * Which is returned should be immaterial to callers, as the only
923b6d4e
KW
2395 * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
2396 * and swash_to_invlist() handle both these transparently.
c4a5db0c
KW
2397 *
2398 * This interface should only be used by functions that won't destroy or
2399 * adversely change the swash, as doing so affects all other uses of the
2400 * swash in the program; the general public should use 'Perl_swash_init'
2401 * instead.
2402 *
2403 * pkg is the name of the package that <name> should be in.
2404 * name is the name of the swash to find. Typically it is a Unicode
2405 * property name, including user-defined ones
2406 * listsv is a string to initialize the swash with. It must be of the form
2407 * documented as the subroutine return value in
2408 * L<perlunicode/User-Defined Character Properties>
2409 * minbits is the number of bits required to represent each data element.
2410 * It is '1' for binary properties.
2411 * none I (khw) do not understand this one, but it is used only in tr///.
9a53f6cf 2412 * invlist is an inversion list to initialize the swash with (or NULL)
83199d38
KW
2413 * flags_p if non-NULL is the address of various input and output flag bits
2414 * to the routine, as follows: ('I' means is input to the routine;
2415 * 'O' means output from the routine. Only flags marked O are
2416 * meaningful on return.)
2417 * _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
2418 * came from a user-defined property. (I O)
5d3d13d1
KW
2419 * _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
2420 * when the swash cannot be located, to simply return NULL. (I)
87367d5f
KW
2421 * _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
2422 * return of an inversion list instead of a swash hash if this routine
2423 * thinks that would result in faster execution of swash_fetch() later
2424 * on. (I)
9a53f6cf
KW
2425 *
2426 * Thus there are three possible inputs to find the swash: <name>,
2427 * <listsv>, and <invlist>. At least one must be specified. The result
2428 * will be the union of the specified ones, although <listsv>'s various
aabbdbda
KW
2429 * actions can intersect, etc. what <name> gives. To avoid going out to
2430 * disk at all, <invlist> should specify completely what the swash should
2431 * have, and <listsv> should be &PL_sv_undef and <name> should be "".
9a53f6cf
KW
2432 *
2433 * <invlist> is only valid for binary properties */
c4a5db0c 2434
2c1f00b9
YO
2435 PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
2436
c4a5db0c 2437 SV* retval = &PL_sv_undef;
83199d38 2438 HV* swash_hv = NULL;
87367d5f
KW
2439 const int invlist_swash_boundary =
2440 (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
2441 ? 512 /* Based on some benchmarking, but not extensive, see commit
2442 message */
2443 : -1; /* Never return just an inversion list */
9a53f6cf
KW
2444
2445 assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
2446 assert(! invlist || minbits == 1);
2447
2c1f00b9
YO
2448 PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
2449 that triggered the swash init and the swash init perl logic itself.
2450 See perl #122747 */
2451
9a53f6cf
KW
2452 /* If data was passed in to go out to utf8_heavy to find the swash of, do
2453 * so */
2454 if (listsv != &PL_sv_undef || strNE(name, "")) {
69794297
KW
2455 dSP;
2456 const size_t pkg_len = strlen(pkg);
2457 const size_t name_len = strlen(name);
2458 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
2459 SV* errsv_save;
2460 GV *method;
2461
2462 PERL_ARGS_ASSERT__CORE_SWASH_INIT;
2463
2464 PUSHSTACKi(PERLSI_MAGIC);
ce3b816e 2465 ENTER;
69794297 2466 SAVEHINTS();
2782061f 2467 save_re_context();
650f067c
JL
2468 /* We might get here via a subroutine signature which uses a utf8
2469 * parameter name, at which point PL_subname will have been set
2470 * but not yet used. */
2471 save_item(PL_subname);
69794297
KW
2472 if (PL_parser && PL_parser->error_count)
2473 SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
2474 method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
4a4088c4 2475 if (!method) { /* demand load UTF-8 */
69794297 2476 ENTER;
db2c6cb3
FC
2477 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
2478 GvSV(PL_errgv) = NULL;
1a419e6b 2479#ifndef NO_TAINT_SUPPORT
69794297
KW
2480 /* It is assumed that callers of this routine are not passing in
2481 * any user derived data. */
2782061f
DM
2482 /* Need to do this after save_re_context() as it will set
2483 * PL_tainted to 1 while saving $1 etc (see the code after getrx:
2484 * in Perl_magic_get). Even line to create errsv_save can turn on
2485 * PL_tainted. */
284167a5
SM
2486 SAVEBOOL(TAINT_get);
2487 TAINT_NOT;
2488#endif
69794297
KW
2489 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
2490 NULL);
eed484f9 2491 {
db2c6cb3
FC
2492 /* Not ERRSV, as there is no need to vivify a scalar we are
2493 about to discard. */
2494 SV * const errsv = GvSV(PL_errgv);
2495 if (!SvTRUE(errsv)) {
2496 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
2497 SvREFCNT_dec(errsv);
2498 }
eed484f9 2499 }
69794297
KW
2500 LEAVE;
2501 }
2502 SPAGAIN;
2503 PUSHMARK(SP);
2504 EXTEND(SP,5);
2505 mPUSHp(pkg, pkg_len);
2506 mPUSHp(name, name_len);
2507 PUSHs(listsv);
2508 mPUSHi(minbits);
2509 mPUSHi(none);
2510 PUTBACK;
db2c6cb3
FC
2511 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
2512 GvSV(PL_errgv) = NULL;
69794297
KW
2513 /* If we already have a pointer to the method, no need to use
2514 * call_method() to repeat the lookup. */
c41800a8
KW
2515 if (method
2516 ? call_sv(MUTABLE_SV(method), G_SCALAR)
69794297
KW
2517 : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
2518 {
2519 retval = *PL_stack_sp--;
2520 SvREFCNT_inc(retval);
2521 }
eed484f9 2522 {
db2c6cb3
FC
2523 /* Not ERRSV. See above. */
2524 SV * const errsv = GvSV(PL_errgv);
2525 if (!SvTRUE(errsv)) {
2526 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
2527 SvREFCNT_dec(errsv);
2528 }
eed484f9 2529 }
ce3b816e 2530 LEAVE;
69794297
KW
2531 POPSTACK;
2532 if (IN_PERL_COMPILETIME) {
2533 CopHINTS_set(PL_curcop, PL_hints);
2534 }
2535 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
2536 if (SvPOK(retval))
2537
2538 /* If caller wants to handle missing properties, let them */
5d3d13d1 2539 if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
2c1f00b9 2540 CORE_SWASH_INIT_RETURN(NULL);
69794297
KW
2541 }
2542 Perl_croak(aTHX_
2543 "Can't find Unicode property definition \"%"SVf"\"",
2544 SVfARG(retval));
a25b5927 2545 NOT_REACHED; /* NOTREACHED */
69794297 2546 }
9a53f6cf 2547 } /* End of calling the module to find the swash */
36eb48b4 2548
83199d38
KW
2549 /* If this operation fetched a swash, and we will need it later, get it */
2550 if (retval != &PL_sv_undef
2551 && (minbits == 1 || (flags_p
2552 && ! (*flags_p
2553 & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
2554 {
2555 swash_hv = MUTABLE_HV(SvRV(retval));
2556
2557 /* If we don't already know that there is a user-defined component to
2558 * this swash, and the user has indicated they wish to know if there is
2559 * one (by passing <flags_p>), find out */
2560 if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
2561 SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
2562 if (user_defined && SvUV(*user_defined)) {
2563 *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
2564 }
2565 }
2566 }
2567
36eb48b4
KW
2568 /* Make sure there is an inversion list for binary properties */
2569 if (minbits == 1) {
2570 SV** swash_invlistsvp = NULL;
2571 SV* swash_invlist = NULL;
9a53f6cf 2572 bool invlist_in_swash_is_valid = FALSE;
02c85471
FC
2573 bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
2574 an unclaimed reference count */
36eb48b4 2575
9a53f6cf 2576 /* If this operation fetched a swash, get its already existing
83199d38 2577 * inversion list, or create one for it */
36eb48b4 2578
83199d38 2579 if (swash_hv) {
5c9f4bd2 2580 swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
9a53f6cf
KW
2581 if (swash_invlistsvp) {
2582 swash_invlist = *swash_invlistsvp;
2583 invlist_in_swash_is_valid = TRUE;
2584 }
2585 else {
36eb48b4 2586 swash_invlist = _swash_to_invlist(retval);
02c85471 2587 swash_invlist_unclaimed = TRUE;
9a53f6cf
KW
2588 }
2589 }
2590
2591 /* If an inversion list was passed in, have to include it */
2592 if (invlist) {
2593
2594 /* Any fetched swash will by now have an inversion list in it;
2595 * otherwise <swash_invlist> will be NULL, indicating that we
2596 * didn't fetch a swash */
2597 if (swash_invlist) {
2598
2599 /* Add the passed-in inversion list, which invalidates the one
2600 * already stored in the swash */
2601 invlist_in_swash_is_valid = FALSE;
2602 _invlist_union(invlist, swash_invlist, &swash_invlist);
2603 }
2604 else {
2605
87367d5f
KW
2606 /* Here, there is no swash already. Set up a minimal one, if
2607 * we are going to return a swash */
2608 if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
971d486f 2609 swash_hv = newHV();
4aca0fe6 2610 retval = newRV_noinc(MUTABLE_SV(swash_hv));
87367d5f 2611 }
9a53f6cf
KW
2612 swash_invlist = invlist;
2613 }
9a53f6cf
KW
2614 }
2615
2616 /* Here, we have computed the union of all the passed-in data. It may
2617 * be that there was an inversion list in the swash which didn't get
538e84ed 2618 * touched; otherwise save the computed one */
87367d5f
KW
2619 if (! invlist_in_swash_is_valid
2620 && (int) _invlist_len(swash_invlist) > invlist_swash_boundary)
2621 {
5c9f4bd2 2622 if (! hv_stores(MUTABLE_HV(SvRV(retval)), "V", swash_invlist))
69794297
KW
2623 {
2624 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2625 }
cc34d8c5
FC
2626 /* We just stole a reference count. */
2627 if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
2628 else SvREFCNT_inc_simple_void_NN(swash_invlist);
9a53f6cf 2629 }
87367d5f 2630
dbfdbd26
KW
2631 SvREADONLY_on(swash_invlist);
2632
c41800a8 2633 /* Use the inversion list stand-alone if small enough */
87367d5f
KW
2634 if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
2635 SvREFCNT_dec(retval);
02c85471
FC
2636 if (!swash_invlist_unclaimed)
2637 SvREFCNT_inc_simple_void_NN(swash_invlist);
2638 retval = newRV_noinc(swash_invlist);
87367d5f 2639 }
36eb48b4
KW
2640 }
2641
2c1f00b9
YO
2642 CORE_SWASH_INIT_RETURN(retval);
2643#undef CORE_SWASH_INIT_RETURN
a0ed51b3
LW
2644}
2645
035d37be
JH
2646
2647/* This API is wrong for special case conversions since we may need to
2648 * return several Unicode characters for a single Unicode character
2649 * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
2650 * the lower-level routine, and it is similarly broken for returning
38684baa
KW
2651 * multiple values. --jhi
2652 * For those, you should use to_utf8_case() instead */
b0e3252e 2653/* Now SWASHGET is recasted into S_swatch_get in this file. */
680c470c
ST
2654
2655/* Note:
2656 * Returns the value of property/mapping C<swash> for the first character
2657 * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
4a4088c4 2658 * assumed to be in well-formed UTF-8. If C<do_utf8> is false, the string C<ptr>
3d0f8846 2659 * is assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
af2af982
KW
2660 *
2661 * A "swash" is a hash which contains initially the keys/values set up by
2662 * SWASHNEW. The purpose is to be able to completely represent a Unicode
2663 * property for all possible code points. Things are stored in a compact form
2664 * (see utf8_heavy.pl) so that calculation is required to find the actual
2665 * property value for a given code point. As code points are looked up, new
2666 * key/value pairs are added to the hash, so that the calculation doesn't have
2667 * to ever be re-done. Further, each calculation is done, not just for the
2668 * desired one, but for a whole block of code points adjacent to that one.
2669 * For binary properties on ASCII machines, the block is usually for 64 code
2670 * points, starting with a code point evenly divisible by 64. Thus if the
2671 * property value for code point 257 is requested, the code goes out and
2672 * calculates the property values for all 64 code points between 256 and 319,
2673 * and stores these as a single 64-bit long bit vector, called a "swatch",
2674 * under the key for code point 256. The key is the UTF-8 encoding for code
2675 * point 256, minus the final byte. Thus, if the length of the UTF-8 encoding
2676 * for a code point is 13 bytes, the key will be 12 bytes long. If the value
2677 * for code point 258 is then requested, this code realizes that it would be
2678 * stored under the key for 256, and would find that value and extract the
2679 * relevant bit, offset from 256.
2680 *
2681 * Non-binary properties are stored in as many bits as necessary to represent
2682 * their values (32 currently, though the code is more general than that), not
2683 * as single bits, but the principal is the same: the value for each key is a
2684 * vector that encompasses the property values for all code points whose UTF-8
2685 * representations are represented by the key. That is, for all code points
2686 * whose UTF-8 representations are length N bytes, and the key is the first N-1
2687 * bytes of that.
680c470c 2688 */
a0ed51b3 2689UV
680c470c 2690Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
a0ed51b3 2691{
ef8f7699 2692 HV *const hv = MUTABLE_HV(SvRV(swash));
3568d838
JH
2693 U32 klen;
2694 U32 off;
9b56a019 2695 STRLEN slen = 0;
7d85a32c 2696 STRLEN needents;
cfd0369c 2697 const U8 *tmps = NULL;
979f2922 2698 SV *swatch;
08fb1ac5 2699 const U8 c = *ptr;
3568d838 2700
7918f24d
NC
2701 PERL_ARGS_ASSERT_SWASH_FETCH;
2702
87367d5f
KW
2703 /* If it really isn't a hash, it isn't really swash; must be an inversion
2704 * list */
2705 if (SvTYPE(hv) != SVt_PVHV) {
2706 return _invlist_contains_cp((SV*)hv,
2707 (do_utf8)
2708 ? valid_utf8_to_uvchr(ptr, NULL)
2709 : c);
2710 }
2711
08fb1ac5
KW
2712 /* We store the values in a "swatch" which is a vec() value in a swash
2713 * hash. Code points 0-255 are a single vec() stored with key length
2714 * (klen) 0. All other code points have a UTF-8 representation
2715 * 0xAA..0xYY,0xZZ. A vec() is constructed containing all of them which
2716 * share 0xAA..0xYY, which is the key in the hash to that vec. So the key
2717 * length for them is the length of the encoded char - 1. ptr[klen] is the
2718 * final byte in the sequence representing the character */
2719 if (!do_utf8 || UTF8_IS_INVARIANT(c)) {
2720 klen = 0;
2721 needents = 256;
2722 off = c;
3568d838 2723 }
08fb1ac5
KW
2724 else if (UTF8_IS_DOWNGRADEABLE_START(c)) {
2725 klen = 0;
2726 needents = 256;
a62b247b 2727 off = EIGHT_BIT_UTF8_TO_NATIVE(c, *(ptr + 1));
979f2922
ST
2728 }
2729 else {
08fb1ac5
KW
2730 klen = UTF8SKIP(ptr) - 1;
2731
2732 /* Each vec() stores 2**UTF_ACCUMULATION_SHIFT values. The offset into
2733 * the vec is the final byte in the sequence. (In EBCDIC this is
2734 * converted to I8 to get consecutive values.) To help you visualize
2735 * all this:
2736 * Straight 1047 After final byte
2737 * UTF-8 UTF-EBCDIC I8 transform
2738 * U+0400: \xD0\x80 \xB8\x41\x41 \xB8\x41\xA0
2739 * U+0401: \xD0\x81 \xB8\x41\x42 \xB8\x41\xA1
2740 * ...
2741 * U+0409: \xD0\x89 \xB8\x41\x4A \xB8\x41\xA9
2742 * U+040A: \xD0\x8A \xB8\x41\x51 \xB8\x41\xAA
2743 * ...
2744 * U+0412: \xD0\x92 \xB8\x41\x59 \xB8\x41\xB2
2745 * U+0413: \xD0\x93 \xB8\x41\x62 \xB8\x41\xB3
2746 * ...
2747 * U+041B: \xD0\x9B \xB8\x41\x6A \xB8\x41\xBB
2748 * U+041C: \xD0\x9C \xB8\x41\x70 \xB8\x41\xBC
2749 * ...
2750 * U+041F: \xD0\x9F \xB8\x41\x73 \xB8\x41\xBF
2751 * U+0420: \xD0\xA0 \xB8\x42\x41 \xB8\x42\x41
2752 *
2753 * (There are no discontinuities in the elided (...) entries.)
2754 * The UTF-8 key for these 33 code points is '\xD0' (which also is the
2755 * key for the next 31, up through U+043F, whose UTF-8 final byte is
2756 * \xBF). Thus in UTF-8, each key is for a vec() for 64 code points.
2757 * The final UTF-8 byte, which ranges between \x80 and \xBF, is an
2758 * index into the vec() swatch (after subtracting 0x80, which we
2759 * actually do with an '&').
2760 * In UTF-EBCDIC, each key is for a 32 code point vec(). The first 32
2761 * code points above have key '\xB8\x41'. The final UTF-EBCDIC byte has
2762 * dicontinuities which go away by transforming it into I8, and we
2763 * effectively subtract 0xA0 to get the index. */
979f2922 2764 needents = (1 << UTF_ACCUMULATION_SHIFT);
bc3632a8 2765 off = NATIVE_UTF8_TO_I8(ptr[klen]) & UTF_CONTINUATION_MASK;
979f2922 2766 }
7d85a32c 2767
a0ed51b3 2768 /*
4a4088c4 2769 * This single-entry cache saves about 1/3 of the UTF-8 overhead in test
a0ed51b3
LW
2770 * suite. (That is, only 7-8% overall over just a hash cache. Still,
2771 * it's nothing to sniff at.) Pity we usually come through at least
2772 * two function calls to get here...
2773 *
2774 * NB: this code assumes that swatches are never modified, once generated!
2775 */
2776
3568d838 2777 if (hv == PL_last_swash_hv &&
a0ed51b3 2778 klen == PL_last_swash_klen &&
27da23d5 2779 (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
a0ed51b3
LW
2780 {
2781 tmps = PL_last_swash_tmps;
2782 slen = PL_last_swash_slen;
2783 }
2784 else {
2785 /* Try our second-level swatch cache, kept in a hash. */
e1ec3a88 2786 SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
a0ed51b3 2787
b0e3252e 2788 /* If not cached, generate it via swatch_get */
979f2922 2789 if (!svp || !SvPOK(*svp)
08fb1ac5
KW
2790 || !(tmps = (const U8*)SvPV_const(*svp, slen)))
2791 {
2792 if (klen) {
2793 const UV code_point = valid_utf8_to_uvchr(ptr, NULL);
2794 swatch = swatch_get(swash,
2795 code_point & ~((UV)needents - 1),
2796 needents);
2797 }
2798 else { /* For the first 256 code points, the swatch has a key of
2799 length 0 */
2800 swatch = swatch_get(swash, 0, needents);
2801 }
979f2922 2802
923e4eb5 2803 if (IN_PERL_COMPILETIME)
623e6609 2804 CopHINTS_set(PL_curcop, PL_hints);
a0ed51b3 2805
979f2922 2806 svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
a0ed51b3 2807
979f2922
ST
2808 if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2809 || (slen << 3) < needents)
5637ef5b
NC
2810 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch, "
2811 "svp=%p, tmps=%p, slen=%"UVuf", needents=%"UVuf,
2812 svp, tmps, (UV)slen, (UV)needents);
a0ed51b3
LW
2813 }
2814
2815 PL_last_swash_hv = hv;
16d8f38a 2816 assert(klen <= sizeof(PL_last_swash_key));
eac04b2e 2817 PL_last_swash_klen = (U8)klen;
cfd0369c
NC
2818 /* FIXME change interpvar.h? */
2819 PL_last_swash_tmps = (U8 *) tmps;
a0ed51b3
LW
2820 PL_last_swash_slen = slen;
2821 if (klen)
2822 Copy(ptr, PL_last_swash_key, klen, U8);
2823 }
2824
9faf8d75 2825 switch ((int)((slen << 3) / needents)) {
a0ed51b3 2826 case 1:
e7aca353 2827 return ((UV) tmps[off >> 3] & (1 << (off & 7))) != 0;
a0ed51b3 2828 case 8:
e7aca353 2829 return ((UV) tmps[off]);
a0ed51b3
LW
2830 case 16:
2831 off <<= 1;
e7aca353
JH
2832 return
2833 ((UV) tmps[off ] << 8) +
2834 ((UV) tmps[off + 1]);
a0ed51b3
LW
2835 case 32:
2836 off <<= 2;
e7aca353
JH
2837 return
2838 ((UV) tmps[off ] << 24) +
2839 ((UV) tmps[off + 1] << 16) +
2840 ((UV) tmps[off + 2] << 8) +
2841 ((UV) tmps[off + 3]);
a0ed51b3 2842 }
5637ef5b
NC
2843 Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
2844 "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);
670f1322 2845 NORETURN_FUNCTION_END;
a0ed51b3 2846}
2b9d42f0 2847
319009ee
KW
2848/* Read a single line of the main body of the swash input text. These are of
2849 * the form:
2850 * 0053 0056 0073
2851 * where each number is hex. The first two numbers form the minimum and
2852 * maximum of a range, and the third is the value associated with the range.
2853 * Not all swashes should have a third number
2854 *
2855 * On input: l points to the beginning of the line to be examined; it points
2856 * to somewhere in the string of the whole input text, and is
2857 * terminated by a \n or the null string terminator.
2858 * lend points to the null terminator of that string
2859 * wants_value is non-zero if the swash expects a third number
2860 * typestr is the name of the swash's mapping, like 'ToLower'
2861 * On output: *min, *max, and *val are set to the values read from the line.
2862 * returns a pointer just beyond the line examined. If there was no
2863 * valid min number on the line, returns lend+1
2864 */
2865
2866STATIC U8*
2867S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2868 const bool wants_value, const U8* const typestr)
2869{
2870 const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
2871 STRLEN numlen; /* Length of the number */
02470786
KW
2872 I32 flags = PERL_SCAN_SILENT_ILLDIGIT
2873 | PERL_SCAN_DISALLOW_PREFIX
2874 | PERL_SCAN_SILENT_NON_PORTABLE;
319009ee
KW
2875
2876 /* nl points to the next \n in the scan */
2877 U8* const nl = (U8*)memchr(l, '\n', lend - l);
2878
95543e92
KW
2879 PERL_ARGS_ASSERT_SWASH_SCAN_LIST_LINE;
2880
319009ee
KW
2881 /* Get the first number on the line: the range minimum */
2882 numlen = lend - l;
2883 *min = grok_hex((char *)l, &numlen, &flags, NULL);
c88850db 2884 *max = *min; /* So can never return without setting max */
319009ee
KW
2885 if (numlen) /* If found a hex number, position past it */
2886 l += numlen;
2887 else if (nl) { /* Else, go handle next line, if any */
2888 return nl + 1; /* 1 is length of "\n" */
2889 }
2890 else { /* Else, no next line */
2891 return lend + 1; /* to LIST's end at which \n is not found */
2892 }
2893
2894 /* The max range value follows, separated by a BLANK */
2895 if (isBLANK(*l)) {
2896 ++l;
02470786
KW
2897 flags = PERL_SCAN_SILENT_ILLDIGIT
2898 | PERL_SCAN_DISALLOW_PREFIX
2899 | PERL_SCAN_SILENT_NON_PORTABLE;
319009ee
KW
2900 numlen = lend - l;
2901 *max = grok_hex((char *)l, &numlen, &flags, NULL);
2902 if (numlen)
2903 l += numlen;
2904 else /* If no value here, it is a single element range */
2905 *max = *min;
2906
2907 /* Non-binary tables have a third entry: what the first element of the
24303724 2908 * range maps to. The map for those currently read here is in hex */
319009ee
KW
2909 if (wants_value) {
2910 if (isBLANK(*l)) {
2911 ++l;
f2a7d0fc
KW
2912 flags = PERL_SCAN_SILENT_ILLDIGIT
2913 | PERL_SCAN_DISALLOW_PREFIX
2914 | PERL_SCAN_SILENT_NON_PORTABLE;
2915 numlen = lend - l;
2916 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2917 if (numlen)
2918 l += numlen;
2919 else
2920 *val = 0;
319009ee
KW
2921 }
2922 else {
2923 *val = 0;
2924 if (typeto) {
dcbac5bb 2925 /* diag_listed_as: To%s: illegal mapping '%s' */
319009ee
KW
2926 Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2927 typestr, l);
2928 }
2929 }
2930 }
2931 else
2932 *val = 0; /* bits == 1, then any val should be ignored */
2933 }
2934 else { /* Nothing following range min, should be single element with no
2935 mapping expected */
319009ee
KW
2936 if (wants_value) {
2937 *val = 0;
2938 if (typeto) {
dcbac5bb 2939 /* diag_listed_as: To%s: illegal mapping '%s' */
319009ee
KW
2940 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2941 }
2942 }
2943 else
2944 *val = 0; /* bits == 1, then val should be ignored */
2945 }
2946
2947 /* Position to next line if any, or EOF */
2948 if (nl)
2949 l = nl + 1;
2950 else
2951 l = lend;
2952
2953 return l;
2954}
2955
979f2922
ST
2956/* Note:
2957 * Returns a swatch (a bit vector string) for a code point sequence
2958 * that starts from the value C<start> and comprises the number C<span>.
2959 * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2960 * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2961 */
2962STATIC SV*
b0e3252e 2963S_swatch_get(pTHX_ SV* swash, UV start, UV span)
979f2922
ST
2964{
2965 SV *swatch;
77f9f126 2966 U8 *l, *lend, *x, *xend, *s, *send;
979f2922 2967 STRLEN lcur, xcur, scur;
ef8f7699 2968 HV *const hv = MUTABLE_HV(SvRV(swash));
5c9f4bd2 2969 SV** const invlistsvp = hv_fetchs(hv, "V", FALSE);
36eb48b4 2970
88d45d28
KW
2971 SV** listsvp = NULL; /* The string containing the main body of the table */
2972 SV** extssvp = NULL;
2973 SV** invert_it_svp = NULL;
2974 U8* typestr = NULL;
786861f5
KW
2975 STRLEN bits;
2976 STRLEN octets; /* if bits == 1, then octets == 0 */
2977 UV none;
2978 UV end = start + span;
972dd592 2979
36eb48b4 2980 if (invlistsvp == NULL) {
786861f5
KW
2981 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2982 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2983 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2984 extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2985 listsvp = hv_fetchs(hv, "LIST", FALSE);
2986 invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
2987
2988 bits = SvUV(*bitssvp);
2989 none = SvUV(*nonesvp);
2990 typestr = (U8*)SvPV_nolen(*typesvp);
2991 }
36eb48b4
KW
2992 else {
2993 bits = 1;
2994 none = 0;
2995 }
786861f5 2996 octets = bits >> 3; /* if bits == 1, then octets == 0 */
979f2922 2997
b0e3252e 2998 PERL_ARGS_ASSERT_SWATCH_GET;
7918f24d 2999
979f2922 3000 if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
b0e3252e 3001 Perl_croak(aTHX_ "panic: swatch_get doesn't expect bits %"UVuf,
660a4616 3002 (UV)bits);
979f2922
ST
3003 }
3004
84ea5ef6
KW
3005 /* If overflowed, use the max possible */
3006 if (end < start) {
3007 end = UV_MAX;
3008 span = end - start;
3009 }
3010
979f2922 3011 /* create and initialize $swatch */
979f2922 3012 scur = octets ? (span * octets) : (span + 7) / 8;
e524fe40
NC
3013 swatch = newSV(scur);
3014 SvPOK_on(swatch);
979f2922
ST
3015 s = (U8*)SvPVX(swatch);
3016 if (octets && none) {
0bd48802 3017 const U8* const e = s + scur;
979f2922
ST
3018 while (s < e) {
3019 if (bits == 8)
3020 *s++ = (U8)(none & 0xff);
3021 else if (bits == 16) {
3022 *s++ = (U8)((none >> 8) & 0xff);
3023 *s++ = (U8)( none & 0xff);
3024 }
3025 else if (bits == 32) {
3026 *s++ = (U8)((none >> 24) & 0xff);
3027 *s++ = (U8)((none >> 16) & 0xff);
3028 *s++ = (U8)((none >> 8) & 0xff);
3029 *s++ = (U8)( none & 0xff);
3030 }
3031 }
3032 *s = '\0';
3033 }
3034 else {
3035 (void)memzero((U8*)s, scur + 1);
3036 }
3037 SvCUR_set(swatch, scur);
3038 s = (U8*)SvPVX(swatch);
3039
36eb48b4
KW
3040 if (invlistsvp) { /* If has an inversion list set up use that */
3041 _invlist_populate_swatch(*invlistsvp, start, end, s);
3042 return swatch;
3043 }
3044
3045 /* read $swash->{LIST} */
979f2922
ST
3046 l = (U8*)SvPV(*listsvp, lcur);
3047 lend = l + lcur;
3048 while (l < lend) {
8ed25d53 3049 UV min, max, val, upper;
95543e92
KW
3050 l = swash_scan_list_line(l, lend, &min, &max, &val,
3051 cBOOL(octets), typestr);
319009ee 3052 if (l > lend) {
979f2922
ST
3053 break;
3054 }
3055
972dd592 3056 /* If looking for something beyond this range, go try the next one */
979f2922
ST
3057 if (max < start)
3058 continue;
3059
8ed25d53
KW
3060 /* <end> is generally 1 beyond where we want to set things, but at the
3061 * platform's infinity, where we can't go any higher, we want to
3062 * include the code point at <end> */
3063 upper = (max < end)
3064 ? max
3065 : (max != UV_MAX || end != UV_MAX)
3066 ? end - 1
3067 : end;
3068
979f2922 3069 if (octets) {
35da51f7 3070 UV key;
979f2922
ST
3071 if (min < start) {
3072 if (!none || val < none) {
3073 val += start - min;
3074 }
3075 min = start;
3076 }
8ed25d53 3077 for (key = min; key <= upper; key++) {
979f2922 3078 STRLEN offset;
979f2922
ST
3079 /* offset must be non-negative (start <= min <= key < end) */
3080 offset = octets * (key - start);
3081 if (bits == 8)
3082 s[offset] = (U8)(val & 0xff);
3083 else if (bits == 16) {
3084 s[offset ] = (U8)((val >> 8) & 0xff);
3085 s[offset + 1] = (U8)( val & 0xff);
3086 }
3087 else if (bits == 32) {
3088 s[offset ] = (U8)((val >> 24) & 0xff);
3089 s[offset + 1] = (U8)((val >> 16) & 0xff);
3090 s[offset + 2] = (U8)((val >> 8) & 0xff);
3091 s[offset + 3] = (U8)( val & 0xff);
3092 }
3093
3094 if (!none || val < none)
3095 ++val;
3096 }
3097 }
711a919c 3098 else { /* bits == 1, then val should be ignored */
35da51f7 3099 UV key;
979f2922
ST
3100 if (min < start)
3101 min = start;
6cb05c12 3102
8ed25d53 3103 for (key = min; key <= upper; key++) {
0bd48802 3104 const STRLEN offset = (STRLEN)(key - start);
979f2922
ST
3105 s[offset >> 3] |= 1 << (offset & 7);
3106 }
3107 }
3108 } /* while */
979f2922 3109
9479a769 3110 /* Invert if the data says it should be. Assumes that bits == 1 */
77f9f126 3111 if (invert_it_svp && SvUV(*invert_it_svp)) {
0bda3001
KW
3112
3113 /* Unicode properties should come with all bits above PERL_UNICODE_MAX
3114 * be 0, and their inversion should also be 0, as we don't succeed any
3115 * Unicode property matches for non-Unicode code points */
3116 if (start <= PERL_UNICODE_MAX) {
3117
3118 /* The code below assumes that we never cross the
3119 * Unicode/above-Unicode boundary in a range, as otherwise we would
3120 * have to figure out where to stop flipping the bits. Since this
3121 * boundary is divisible by a large power of 2, and swatches comes
3122 * in small powers of 2, this should be a valid assumption */
3123 assert(start + span - 1 <= PERL_UNICODE_MAX);
3124
507a8485
KW
3125 send = s + scur;
3126 while (s < send) {
3127 *s = ~(*s);
3128 s++;
3129 }
0bda3001 3130 }
77f9f126
KW
3131 }
3132
d73c39c5
KW
3133 /* read $swash->{EXTRAS}
3134 * This code also copied to swash_to_invlist() below */
979f2922
ST
3135 x = (U8*)SvPV(*extssvp, xcur);
3136 xend = x + xcur;
3137 while (x < xend) {
3138 STRLEN namelen;
3139 U8 *namestr;
3140 SV** othersvp;
3141 HV* otherhv;
3142 STRLEN otherbits;
3143 SV **otherbitssvp, *other;
711a919c 3144 U8 *s, *o, *nl;
979f2922
ST
3145 STRLEN slen, olen;
3146
35da51f7 3147 const U8 opc = *x++;
979f2922
ST
3148 if (opc == '\n')
3149 continue;
3150
3151 nl = (U8*)memchr(x, '\n', xend - x);
3152
3153 if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
3154 if (nl) {
3155 x = nl + 1; /* 1 is length of "\n" */
3156 continue;
3157 }
3158 else {
3159 x = xend; /* to EXTRAS' end at which \n is not found */
3160 break;
3161 }
3162 }
3163
3164 namestr = x;
3165 if (nl) {
3166 namelen = nl - namestr;
3167 x = nl + 1;
3168 }
3169 else {
3170 namelen = xend - namestr;
3171 x = xend;
3172 }
3173
3174 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
ef8f7699 3175 otherhv = MUTABLE_HV(SvRV(*othersvp));
017a3ce5 3176 otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
979f2922
ST
3177 otherbits = (STRLEN)SvUV(*otherbitssvp);
3178 if (bits < otherbits)
5637ef5b
NC
3179 Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch, "
3180 "bits=%"UVuf", otherbits=%"UVuf, (UV)bits, (UV)otherbits);
979f2922
ST
3181
3182 /* The "other" swatch must be destroyed after. */
b0e3252e 3183 other = swatch_get(*othersvp, start, span);
979f2922
ST
3184 o = (U8*)SvPV(other, olen);
3185
3186 if (!olen)
b0e3252e 3187 Perl_croak(aTHX_ "panic: swatch_get got improper swatch");
979f2922
ST
3188
3189 s = (U8*)SvPV(swatch, slen);
3190 if (bits == 1 && otherbits == 1) {
3191 if (slen != olen)
5637ef5b
NC
3192 Perl_croak(aTHX_ "panic: swatch_get found swatch length "
3193 "mismatch, slen=%"UVuf", olen=%"UVuf,
3194 (UV)slen, (UV)olen);
979f2922
ST
3195
3196 switch (opc) {
3197 case '+':
3198 while (slen--)
3199 *s++ |= *o++;
3200 break;
3201 case '!':
3202 while (slen--)
3203 *s++ |= ~*o++;
3204 break;
3205 case '-':
3206 while (slen--)
3207 *s++ &= ~*o++;
3208 break;
3209 case '&':
3210 while (slen--)
3211 *s++ &= *o++;
3212 break;
3213 default:
3214 break;
3215 }
3216 }
711a919c 3217 else {
979f2922
ST
3218 STRLEN otheroctets = otherbits >> 3;
3219 STRLEN offset = 0;
35da51f7 3220 U8* const send = s + slen;
979f2922
ST
3221
3222 while (s < send) {
3223 UV otherval = 0;
3224
3225 if (otherbits == 1) {
3226 otherval = (o[offset >> 3] >> (offset & 7)) & 1;
3227 ++offset;
3228 }
3229 else {
3230 STRLEN vlen = otheroctets;
3231 otherval = *o++;
3232 while (--vlen) {
3233 otherval <<= 8;
3234 otherval |= *o++;
3235 }
3236 }
3237
711a919c 3238 if (opc == '+' && otherval)
6f207bd3 3239 NOOP; /* replace with otherval */
979f2922
ST
3240 else if (opc == '!' && !otherval)
3241 otherval = 1;
3242 else if (opc == '-' && otherval)
3243 otherval = 0;
3244 else if (opc == '&' && !otherval)
3245 otherval = 0;
3246 else {
711a919c 3247 s += octets; /* no replacement */
979f2922
ST
3248 continue;
3249 }
3250
3251 if (bits == 8)
3252 *s++ = (U8)( otherval & 0xff);
3253 else if (bits == 16) {
3254 *s++ = (U8)((otherval >> 8) & 0xff);
3255 *s++ = (U8)( otherval & 0xff);
3256 }
3257 else if (bits == 32) {
3258 *s++ = (U8)((otherval >> 24) & 0xff);
3259 *s++ = (U8)((otherval >> 16) & 0xff);
3260 *s++ = (U8)((otherval >> 8) & 0xff);
3261 *s++ = (U8)( otherval & 0xff);
3262 }
3263 }
3264 }
3265 sv_free(other); /* through with it! */
3266 } /* while */
3267 return swatch;
3268}
3269
064c021d 3270HV*
4c2e1131 3271Perl__swash_inversion_hash(pTHX_ SV* const swash)
064c021d
KW
3272{
3273
79a2a0e8 3274 /* Subject to change or removal. For use only in regcomp.c and regexec.c
5662e334
KW
3275 * Can't be used on a property that is subject to user override, as it
3276 * relies on the value of SPECIALS in the swash which would be set by
3277 * utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
3278 * for overridden properties
064c021d
KW
3279 *
3280 * Returns a hash which is the inversion and closure of a swash mapping.
3281 * For example, consider the input lines:
3282 * 004B 006B
3283 * 004C 006C
3284 * 212A 006B
3285 *
4a4088c4 3286 * The returned hash would have two keys, the UTF-8 for 006B and the UTF-8 for
064c021d 3287 * 006C. The value for each key is an array. For 006C, the array would
4a4088c4
KW
3288 * have two elements, the UTF-8 for itself, and for 004C. For 006B, there
3289 * would be three elements in its array, the UTF-8 for 006B, 004B and 212A.
064c021d 3290 *
538e84ed
KW
3291 * Note that there are no elements in the hash for 004B, 004C, 212A. The
3292 * keys are only code points that are folded-to, so it isn't a full closure.
3293 *
064c021d
KW
3294 * Essentially, for any code point, it gives all the code points that map to
3295 * it, or the list of 'froms' for that point.
3296 *
5662e334
KW
3297 * Currently it ignores any additions or deletions from other swashes,
3298 * looking at just the main body of the swash, and if there are SPECIALS
3299 * in the swash, at that hash
3300 *
3301 * The specials hash can be extra code points, and most likely consists of
3302 * maps from single code points to multiple ones (each expressed as a string
4a4088c4 3303 * of UTF-8 characters). This function currently returns only 1-1 mappings.
5662e334
KW
3304 * However consider this possible input in the specials hash:
3305 * "\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074
3306 * "\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074
3307 *
3308 * Both FB05 and FB06 map to the same multi-char sequence, which we don't
3309 * currently handle. But it also means that FB05 and FB06 are equivalent in
3310 * a 1-1 mapping which we should handle, and this relationship may not be in
3311 * the main table. Therefore this function examines all the multi-char
74894415
KW
3312 * sequences and adds the 1-1 mappings that come out of that.
3313 *
3314 * XXX This function was originally intended to be multipurpose, but its
3315 * only use is quite likely to remain for constructing the inversion of
3316 * the CaseFolding (//i) property. If it were more general purpose for
3317 * regex patterns, it would have to do the FB05/FB06 game for simple folds,
3318 * because certain folds are prohibited under /iaa and /il. As an example,
3319 * in Unicode 3.0.1 both U+0130 and U+0131 fold to 'i', and hence are both
3320 * equivalent under /i. But under /iaa and /il, the folds to 'i' are
3321 * prohibited, so we would not figure out that they fold to each other.
3322 * Code could be written to automatically figure this out, similar to the
3323 * code that does this for multi-character folds, but this is the only case
3324 * where something like this is ever likely to happen, as all the single
3325 * char folds to The 0-255 range are now quite settled. Instead there is a
3326 * little special code that is compiled only for this Unicode version. This
3327 * is smaller and didn't require much coding time to do. But this makes
3328 * this routine strongly tied to being used just for CaseFolding. If ever
3329 * it should be generalized, this would have to be fixed */
064c021d
KW
3330
3331 U8 *l, *lend;
3332 STRLEN lcur;
3333 HV *const hv = MUTABLE_HV(SvRV(swash));
3334
923b6d4e
KW
3335 /* The string containing the main body of the table. This will have its
3336 * assertion fail if the swash has been converted to its inversion list */
064c021d
KW
3337 SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
3338
3339 SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3340 SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3341 SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
3342 /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
3343 const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
3344 const STRLEN bits = SvUV(*bitssvp);
3345 const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
3346 const UV none = SvUV(*nonesvp);
5662e334 3347 SV **specials_p = hv_fetchs(hv, "SPECIALS", 0);
064c021d
KW
3348
3349 HV* ret = newHV();
3350
3351 PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
3352
3353 /* Must have at least 8 bits to get the mappings */
3354 if (bits != 8 && bits != 16 && bits != 32) {
3355 Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
3356 (UV)bits);
3357 }
3358
5662e334
KW
3359 if (specials_p) { /* It might be "special" (sometimes, but not always, a
3360 mapping to more than one character */
3361
3362 /* Construct an inverse mapping hash for the specials */
3363 HV * const specials_hv = MUTABLE_HV(SvRV(*specials_p));
3364 HV * specials_inverse = newHV();
3365 char *char_from; /* the lhs of the map */
3366 I32 from_len; /* its byte length */
3367 char *char_to; /* the rhs of the map */
3368 I32 to_len; /* its byte length */
3369 SV *sv_to; /* and in a sv */
3370 AV* from_list; /* list of things that map to each 'to' */
3371
3372 hv_iterinit(specials_hv);
3373
4a4088c4
KW
3374 /* The keys are the characters (in UTF-8) that map to the corresponding
3375 * UTF-8 string value. Iterate through the list creating the inverse
5662e334
KW
3376 * list. */
3377 while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
3378 SV** listp;
3379 if (! SvPOK(sv_to)) {
5637ef5b
NC
3380 Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() "
3381 "unexpectedly is not a string, flags=%lu",
3382 (unsigned long)SvFLAGS(sv_to));
5662e334 3383 }
4b88fb76 3384 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", valid_utf8_to_uvchr((U8*) char_from, 0), valid_utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
5662e334
KW
3385
3386 /* Each key in the inverse list is a mapped-to value, and the key's
4a4088c4 3387 * hash value is a list of the strings (each in UTF-8) that map to
5662e334
KW
3388 * it. Those strings are all one character long */
3389 if ((listp = hv_fetch(specials_inverse,
3390 SvPVX(sv_to),
3391 SvCUR(sv_to), 0)))
3392 {
3393 from_list = (AV*) *listp;
3394 }
3395 else { /* No entry yet for it: create one */
3396 from_list = newAV();
3397 if (! hv_store(specials_inverse,
3398 SvPVX(sv_to),
3399 SvCUR(sv_to),
3400 (SV*) from_list, 0))
3401 {
3402 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3403 }
3404 }
3405
3406 /* Here have the list associated with this 'to' (perhaps newly
3407 * created and empty). Just add to it. Note that we ASSUME that
3408 * the input is guaranteed to not have duplications, so we don't
3409 * check for that. Duplications just slow down execution time. */
3410 av_push(from_list, newSVpvn_utf8(char_from, from_len, TRUE));
3411 }
3412
3413 /* Here, 'specials_inverse' contains the inverse mapping. Go through
3414 * it looking for cases like the FB05/FB06 examples above. There would
3415 * be an entry in the hash like
3416 * 'st' => [ FB05, FB06 ]
3417 * In this example we will create two lists that get stored in the
3418 * returned hash, 'ret':
3419 * FB05 => [ FB05, FB06 ]
3420 * FB06 => [ FB05, FB06 ]
3421 *
3422 * Note that there is nothing to do if the array only has one element.
3423 * (In the normal 1-1 case handled below, we don't have to worry about
3424 * two lists, as everything gets tied to the single list that is
3425 * generated for the single character 'to'. But here, we are omitting
3426 * that list, ('st' in the example), so must have multiple lists.) */
3427 while ((from_list = (AV *) hv_iternextsv(specials_inverse,
3428 &char_to, &to_len)))
3429 {
b9f2b683 3430 if (av_tindex(from_list) > 0) {
c70927a6 3431 SSize_t i;
5662e334
KW
3432
3433 /* We iterate over all combinations of i,j to place each code
3434 * point on each list */
b9f2b683 3435 for (i = 0; i <= av_tindex(from_list); i++) {
c70927a6 3436 SSize_t j;
5662e334
KW
3437 AV* i_list = newAV();
3438 SV** entryp = av_fetch(from_list, i, FALSE);
3439 if (entryp == NULL) {
3440 Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3441 }
3442 if (hv_fetch(ret, SvPVX(*entryp), SvCUR(*entryp), FALSE)) {
3443 Perl_croak(aTHX_ "panic: unexpected entry for %s", SvPVX(*entryp));
3444 }
3445 if (! hv_store(ret, SvPVX(*entryp), SvCUR(*entryp),
3446 (SV*) i_list, FALSE))
3447 {
3448 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3449 }
3450
538e84ed 3451 /* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
b9f2b683 3452 for (j = 0; j <= av_tindex(from_list); j++) {
5662e334
KW
3453 entryp = av_fetch(from_list, j, FALSE);
3454 if (entryp == NULL) {
3455 Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3456 }
3457
3458 /* When i==j this adds itself to the list */
4b88fb76
KW
3459 av_push(i_list, newSVuv(utf8_to_uvchr_buf(
3460 (U8*) SvPVX(*entryp),
3461 (U8*) SvPVX(*entryp) + SvCUR(*entryp),
3462 0)));
4637d003 3463 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
5662e334
KW
3464 }
3465 }
3466 }
3467 }
3468 SvREFCNT_dec(specials_inverse); /* done with it */
3469 } /* End of specials */
3470
064c021d 3471 /* read $swash->{LIST} */
74894415
KW
3472
3473#if UNICODE_MAJOR_VERSION == 3 \
3474 && UNICODE_DOT_VERSION == 0 \
3475 && UNICODE_DOT_DOT_VERSION == 1
3476
3477 /* For this version only U+130 and U+131 are equivalent under qr//i. Add a
3478 * rule so that things work under /iaa and /il */
3479
3480 SV * mod_listsv = sv_mortalcopy(*listsvp);
3481 sv_catpv(mod_listsv, "130\t130\t131\n");
3482 l = (U8*)SvPV(mod_listsv, lcur);
3483
3484#else
3485
064c021d 3486 l = (U8*)SvPV(*listsvp, lcur);
74894415
KW
3487
3488#endif
3489
064c021d
KW
3490 lend = l + lcur;
3491
3492 /* Go through each input line */
3493 while (l < lend) {
3494 UV min, max, val;
3495 UV inverse;
95543e92
KW
3496 l = swash_scan_list_line(l, lend, &min, &max, &val,
3497 cBOOL(octets), typestr);
064c021d
KW
3498 if (l > lend) {
3499 break;
3500 }
3501
3502 /* Each element in the range is to be inverted */
3503 for (inverse = min; inverse <= max; inverse++) {
3504 AV* list;
064c021d
KW
3505 SV** listp;
3506 IV i;
3507 bool found_key = FALSE;
5662e334 3508 bool found_inverse = FALSE;
064c021d
KW
3509
3510 /* The key is the inverse mapping */
3511 char key[UTF8_MAXBYTES+1];
c80e42f3 3512 char* key_end = (char *) uvchr_to_utf8((U8*) key, val);
064c021d
KW
3513 STRLEN key_len = key_end - key;
3514
064c021d
KW
3515 /* Get the list for the map */
3516 if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
3517 list = (AV*) *listp;
3518 }
3519 else { /* No entry yet for it: create one */
3520 list = newAV();
3521 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
3522 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3523 }
3524 }
3525
5662e334
KW
3526 /* Look through list to see if this inverse mapping already is
3527 * listed, or if there is a mapping to itself already */
b9f2b683 3528 for (i = 0; i <= av_tindex(list); i++) {
064c021d
KW
3529 SV** entryp = av_fetch(list, i, FALSE);
3530 SV* entry;
414db8a1 3531 UV uv;
064c021d
KW
3532 if (entryp == NULL) {
3533 Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3534 }
3535 entry = *entryp;
414db8a1
DM
3536 uv = SvUV(entry);
3537 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, uv));*/
3538 if (uv == val) {
064c021d 3539 found_key = TRUE;
5662e334 3540 }
414db8a1 3541 if (uv == inverse) {
5662e334
KW
3542 found_inverse = TRUE;
3543 }
3544
3545 /* No need to continue searching if found everything we are
3546 * looking for */
3547 if (found_key && found_inverse) {
064c021d
KW
3548 break;
3549 }
3550 }
56ca34ca
KW
3551
3552 /* Make sure there is a mapping to itself on the list */
064c021d 3553 if (! found_key) {
d397ff6a 3554 av_push(list, newSVuv(val));
4637d003 3555 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, val, val));*/
064c021d
KW
3556 }
3557
3558
3559 /* Simply add the value to the list */
5662e334
KW
3560 if (! found_inverse) {
3561 av_push(list, newSVuv(inverse));
4637d003 3562 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %"UVXf" to list for %"UVXf"\n", __FILE__, __LINE__, inverse, val));*/
5662e334 3563 }
064c021d 3564
b0e3252e 3565 /* swatch_get() increments the value of val for each element in the
064c021d
KW
3566 * range. That makes more compact tables possible. You can
3567 * express the capitalization, for example, of all consecutive
3568 * letters with a single line: 0061\t007A\t0041 This maps 0061 to
3569 * 0041, 0062 to 0042, etc. I (khw) have never understood 'none',
bd3f2f94 3570 * and it's not documented; it appears to be used only in
b0e3252e 3571 * implementing tr//; I copied the semantics from swatch_get(), just
bd3f2f94 3572 * in case */
064c021d
KW
3573 if (!none || val < none) {
3574 ++val;
3575 }
3576 }
3577 }
3578
3579 return ret;
3580}
3581
a25abddc 3582SV*
d764b54e
KW
3583Perl__swash_to_invlist(pTHX_ SV* const swash)
3584{
3585
ed92f1b3
KW
3586 /* Subject to change or removal. For use only in one place in regcomp.c.
3587 * Ownership is given to one reference count in the returned SV* */
d764b54e
KW
3588
3589 U8 *l, *lend;
3590 char *loc;
3591 STRLEN lcur;
3592 HV *const hv = MUTABLE_HV(SvRV(swash));
3593 UV elements = 0; /* Number of elements in the inversion list */
b443038a 3594 U8 empty[] = "";
923b6d4e
KW
3595 SV** listsvp;
3596 SV** typesvp;
3597 SV** bitssvp;
3598 SV** extssvp;
3599 SV** invert_it_svp;
d764b54e 3600
923b6d4e
KW
3601 U8* typestr;
3602 STRLEN bits;
3603 STRLEN octets; /* if bits == 1, then octets == 0 */
d73c39c5
KW
3604 U8 *x, *xend;
3605 STRLEN xcur;
d764b54e 3606
a25abddc 3607 SV* invlist;
d764b54e 3608
b81740c0
KW
3609 PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
3610
923b6d4e
KW
3611 /* If not a hash, it must be the swash's inversion list instead */
3612 if (SvTYPE(hv) != SVt_PVHV) {
ed92f1b3 3613 return SvREFCNT_inc_simple_NN((SV*) hv);
923b6d4e
KW
3614 }
3615
3616 /* The string containing the main body of the table */
3617 listsvp = hv_fetchs(hv, "LIST", FALSE);
3618 typesvp = hv_fetchs(hv, "TYPE", FALSE);
3619 bitssvp = hv_fetchs(hv, "BITS", FALSE);
3620 extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
3621 invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
3622
3623 typestr = (U8*)SvPV_nolen(*typesvp);
3624 bits = SvUV(*bitssvp);
3625 octets = bits >> 3; /* if bits == 1, then octets == 0 */
3626
d764b54e 3627 /* read $swash->{LIST} */
b443038a
KW
3628 if (SvPOK(*listsvp)) {
3629 l = (U8*)SvPV(*listsvp, lcur);
3630 }