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