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