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