This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/t/utf8_setup.pl: Add #define equivalent
[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) */
e9f2c446
KW
1082 U8 temp_char_buf[UTF8_MAXBYTES + 1]; /* Used to avoid a Newx in this
1083 routine; see [perl #130921] */
2b5e7bc2 1084 UV uv_so_far = 0; /* (Initialized to silence compilers' wrong warning) */
7918f24d 1085
f9380377
KW
1086 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR;
1087
1088 if (errors) {
1089 *errors = 0;
1090 }
1091 else {
1092 errors = &discard_errors;
1093 }
a0dbb045 1094
eb83ed87
KW
1095 /* The order of malformation tests here is important. We should consume as
1096 * few bytes as possible in order to not skip any valid character. This is
1097 * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
1098 * http://unicode.org/reports/tr36 for more discussion as to why. For
1099 * example, once we've done a UTF8SKIP, we can tell the expected number of
1100 * bytes, and could fail right off the bat if the input parameters indicate
1101 * that there are too few available. But it could be that just that first
1102 * byte is garbled, and the intended character occupies fewer bytes. If we
1103 * blindly assumed that the first byte is correct, and skipped based on
1104 * that number, we could skip over a valid input character. So instead, we
1105 * always examine the sequence byte-by-byte.
1106 *
1107 * We also should not consume too few bytes, otherwise someone could inject
1108 * things. For example, an input could be deliberately designed to
1109 * overflow, and if this code bailed out immediately upon discovering that,
e2660c54 1110 * returning to the caller C<*retlen> pointing to the very next byte (one
eb83ed87
KW
1111 * which is actually part of of the overflowing sequence), that could look
1112 * legitimate to the caller, which could discard the initial partial
2b5e7bc2
KW
1113 * sequence and process the rest, inappropriately.
1114 *
1115 * Some possible input sequences are malformed in more than one way. This
1116 * function goes to lengths to try to find all of them. This is necessary
1117 * for correctness, as the inputs may allow one malformation but not
1118 * another, and if we abandon searching for others after finding the
1119 * allowed one, we could allow in something that shouldn't have been.
1120 */
eb83ed87 1121
b5b9af04 1122 if (UNLIKELY(curlen == 0)) {
2b5e7bc2
KW
1123 possible_problems |= UTF8_GOT_EMPTY;
1124 curlen = 0;
5a48568d 1125 uv = UNICODE_REPLACEMENT;
2b5e7bc2 1126 goto ready_to_handle_errors;
0c443dc2
JH
1127 }
1128
eb83ed87
KW
1129 expectlen = UTF8SKIP(s);
1130
1131 /* A well-formed UTF-8 character, as the vast majority of calls to this
1132 * function will be for, has this expected length. For efficiency, set
1133 * things up here to return it. It will be overriden only in those rare
1134 * cases where a malformation is found */
1135 if (retlen) {
1136 *retlen = expectlen;
1137 }
1138
1139 /* An invariant is trivially well-formed */
1d72bdf6 1140 if (UTF8_IS_INVARIANT(uv)) {
de69f3af 1141 return uv;
a0ed51b3 1142 }
67e989fb 1143
eb83ed87 1144 /* A continuation character can't start a valid sequence */
b5b9af04 1145 if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
2b5e7bc2
KW
1146 possible_problems |= UTF8_GOT_CONTINUATION;
1147 curlen = 1;
1148 uv = UNICODE_REPLACEMENT;
1149 goto ready_to_handle_errors;
ba210ebe 1150 }
9041c2e3 1151
dcd27b3c 1152 /* Here is not a continuation byte, nor an invariant. The only thing left
ddb65933
KW
1153 * is a start byte (possibly for an overlong). (We can't use UTF8_IS_START
1154 * because it excludes start bytes like \xC0 that always lead to
1155 * overlongs.) */
dcd27b3c 1156
534752c1
KW
1157 /* Convert to I8 on EBCDIC (no-op on ASCII), then remove the leading bits
1158 * that indicate the number of bytes in the character's whole UTF-8
1159 * sequence, leaving just the bits that are part of the value. */
1160 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
ba210ebe 1161
e308b348
KW
1162 /* Setup the loop end point, making sure to not look past the end of the
1163 * input string, and flag it as too short if the size isn't big enough. */
1164 send = (U8*) s0;
1165 if (UNLIKELY(curlen < expectlen)) {
1166 possible_problems |= UTF8_GOT_SHORT;
1167 avail_len = curlen;
1168 send += curlen;
1169 }
1170 else {
1171 send += expectlen;
1172 }
1173 adjusted_send = send;
1174
eb83ed87 1175 /* Now, loop through the remaining bytes in the character's sequence,
e308b348 1176 * accumulating each into the working value as we go. */
eb83ed87 1177 for (s = s0 + 1; s < send; s++) {
b5b9af04 1178 if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
8850bf83 1179 uv = UTF8_ACCUMULATE(uv, *s);
2b5e7bc2
KW
1180 continue;
1181 }
1182
1183 /* Here, found a non-continuation before processing all expected bytes.
1184 * This byte indicates the beginning of a new character, so quit, even
1185 * if allowing this malformation. */
2b5e7bc2 1186 possible_problems |= UTF8_GOT_NON_CONTINUATION;
e308b348 1187 break;
eb83ed87
KW
1188 } /* End of loop through the character's bytes */
1189
1190 /* Save how many bytes were actually in the character */
1191 curlen = s - s0;
1192
2b5e7bc2
KW
1193 /* Note that there are two types of too-short malformation. One is when
1194 * there is actual wrong data before the normal termination of the
1195 * sequence. The other is that the sequence wasn't complete before the end
1196 * of the data we are allowed to look at, based on the input 'curlen'.
1197 * This means that we were passed data for a partial character, but it is
1198 * valid as far as we saw. The other is definitely invalid. This
1199 * distinction could be important to a caller, so the two types are kept
15b010f0
KW
1200 * separate.
1201 *
1202 * A convenience macro that matches either of the too-short conditions. */
1203# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
1204
1205 if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
1206 uv_so_far = uv;
1207 uv = UNICODE_REPLACEMENT;
1208 }
2b5e7bc2
KW
1209
1210 /* Check for overflow */
1211 if (UNLIKELY(does_utf8_overflow(s0, send))) {
1212 possible_problems |= UTF8_GOT_OVERFLOW;
1213 uv = UNICODE_REPLACEMENT;
eb83ed87 1214 }
eb83ed87 1215
2b5e7bc2
KW
1216 /* Check for overlong. If no problems so far, 'uv' is the correct code
1217 * point value. Simply see if it is expressible in fewer bytes. Otherwise
1218 * we must look at the UTF-8 byte sequence itself to see if it is for an
1219 * overlong */
1220 if ( ( LIKELY(! possible_problems)
1221 && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv)))
1222 || ( UNLIKELY( possible_problems)
1223 && ( UNLIKELY(! UTF8_IS_START(*s0))
1224 || ( curlen > 1
1225 && UNLIKELY(is_utf8_overlong_given_start_byte_ok(s0,
1226 send - s0))))))
2f8f112e 1227 {
2b5e7bc2
KW
1228 possible_problems |= UTF8_GOT_LONG;
1229
2b5e7bc2
KW
1230 if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
1231 UV min_uv = uv_so_far;
1232 STRLEN i;
1233
1234 /* Here, the input is both overlong and is missing some trailing
1235 * bytes. There is no single code point it could be for, but there
1236 * may be enough information present to determine if what we have
1237 * so far is for an unallowed code point, such as for a surrogate.
1238 * The code below has the intelligence to determine this, but just
1239 * for non-overlong UTF-8 sequences. What we do here is calculate
1240 * the smallest code point the input could represent if there were
1241 * no too short malformation. Then we compute and save the UTF-8
1242 * for that, which is what the code below looks at instead of the
1243 * raw input. It turns out that the smallest such code point is
1244 * all we need. */
1245 for (i = curlen; i < expectlen; i++) {
1246 min_uv = UTF8_ACCUMULATE(min_uv,
1247 I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
1248 }
1249
e9f2c446 1250 adjusted_s0 = temp_char_buf;
2b5e7bc2
KW
1251 adjusted_send = uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
1252 }
eb83ed87
KW
1253 }
1254
2b5e7bc2
KW
1255 /* Now check that the input isn't for a problematic code point not allowed
1256 * by the input parameters. */
1257 /* isn't problematic if < this */
1258 if ( ( ( LIKELY(! possible_problems) && uv >= UNICODE_SURROGATE_FIRST)
1259 || ( UNLIKELY(possible_problems)
d60baaa7
KW
1260
1261 /* if overflow, we know without looking further
1262 * precisely which of the problematic types it is,
1263 * and we deal with those in the overflow handling
1264 * code */
1265 && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW))
2b5e7bc2 1266 && isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0)))
760c7c2f
KW
1267 && ((flags & ( UTF8_DISALLOW_NONCHAR
1268 |UTF8_DISALLOW_SURROGATE
1269 |UTF8_DISALLOW_SUPER
1270 |UTF8_DISALLOW_ABOVE_31_BIT
1271 |UTF8_WARN_NONCHAR
1272 |UTF8_WARN_SURROGATE
1273 |UTF8_WARN_SUPER
1274 |UTF8_WARN_ABOVE_31_BIT))
2b5e7bc2
KW
1275 /* In case of a malformation, 'uv' is not valid, and has
1276 * been changed to something in the Unicode range.
1277 * Currently we don't output a deprecation message if there
1278 * is already a malformation, so we don't have to special
1279 * case the test immediately below */
760c7c2f
KW
1280 || ( UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
1281 && ckWARN_d(WARN_DEPRECATED))))
eb83ed87 1282 {
2b5e7bc2
KW
1283 /* If there were no malformations, or the only malformation is an
1284 * overlong, 'uv' is valid */
1285 if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) {
1286 if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
1287 possible_problems |= UTF8_GOT_SURROGATE;
1288 }
1289 else if (UNLIKELY(uv > PERL_UNICODE_MAX)) {
1290 possible_problems |= UTF8_GOT_SUPER;
1291 }
1292 else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) {
1293 possible_problems |= UTF8_GOT_NONCHAR;
1294 }
1295 }
1296 else { /* Otherwise, need to look at the source UTF-8, possibly
1297 adjusted to be non-overlong */
1298
1299 if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0)
1300 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
ea5ced44 1301 {
2b5e7bc2
KW
1302 possible_problems |= UTF8_GOT_SUPER;
1303 }
1304 else if (curlen > 1) {
1305 if (UNLIKELY(IS_UTF8_2_BYTE_SUPER(
1306 NATIVE_UTF8_TO_I8(*adjusted_s0),
1307 NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
ea5ced44 1308 {
2b5e7bc2 1309 possible_problems |= UTF8_GOT_SUPER;
ea5ced44 1310 }
2b5e7bc2
KW
1311 else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(
1312 NATIVE_UTF8_TO_I8(*adjusted_s0),
1313 NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
1314 {
1315 possible_problems |= UTF8_GOT_SURROGATE;
ea5ced44
KW
1316 }
1317 }
c0236afe 1318
2b5e7bc2
KW
1319 /* We need a complete well-formed UTF-8 character to discern
1320 * non-characters, so can't look for them here */
1321 }
1322 }
949cf498 1323
2b5e7bc2
KW
1324 ready_to_handle_errors:
1325
1326 /* At this point:
1327 * curlen contains the number of bytes in the sequence that
1328 * this call should advance the input by.
e308b348
KW
1329 * avail_len gives the available number of bytes passed in, but
1330 * only if this is less than the expected number of
1331 * bytes, based on the code point's start byte.
2b5e7bc2
KW
1332 * possible_problems' is 0 if there weren't any problems; otherwise a bit
1333 * is set in it for each potential problem found.
1334 * uv contains the code point the input sequence
1335 * represents; or if there is a problem that prevents
1336 * a well-defined value from being computed, it is
1337 * some subsitute value, typically the REPLACEMENT
1338 * CHARACTER.
1339 * s0 points to the first byte of the character
1340 * send points to just after where that (potentially
1341 * partial) character ends
1342 * adjusted_s0 normally is the same as s0, but in case of an
1343 * overlong for which the UTF-8 matters below, it is
1344 * the first byte of the shortest form representation
1345 * of the input.
1346 * adjusted_send normally is the same as 'send', but if adjusted_s0
1347 * is set to something other than s0, this points one
1348 * beyond its end
1349 */
eb83ed87 1350
2b5e7bc2
KW
1351 if (UNLIKELY(possible_problems)) {
1352 bool disallowed = FALSE;
1353 const U32 orig_problems = possible_problems;
1354
1355 while (possible_problems) { /* Handle each possible problem */
1356 UV pack_warn = 0;
1357 char * message = NULL;
1358
1359 /* Each 'if' clause handles one problem. They are ordered so that
1360 * the first ones' messages will be displayed before the later
1361 * ones; this is kinda in decreasing severity order */
1362 if (possible_problems & UTF8_GOT_OVERFLOW) {
1363
1364 /* Overflow means also got a super and above 31 bits, but we
1365 * handle all three cases here */
1366 possible_problems
1367 &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER|UTF8_GOT_ABOVE_31_BIT);
f9380377
KW
1368 *errors |= UTF8_GOT_OVERFLOW;
1369
1370 /* But the API says we flag all errors found */
1371 if (flags & (UTF8_WARN_SUPER|UTF8_DISALLOW_SUPER)) {
1372 *errors |= UTF8_GOT_SUPER;
1373 }
ddb65933
KW
1374 if (flags
1375 & (UTF8_WARN_ABOVE_31_BIT|UTF8_DISALLOW_ABOVE_31_BIT))
1376 {
f9380377
KW
1377 *errors |= UTF8_GOT_ABOVE_31_BIT;
1378 }
2b5e7bc2 1379
d60baaa7
KW
1380 /* Disallow if any of the three categories say to */
1381 if ( ! (flags & UTF8_ALLOW_OVERFLOW)
1382 || (flags & ( UTF8_DISALLOW_SUPER
1383 |UTF8_DISALLOW_ABOVE_31_BIT)))
1384 {
1385 disallowed = TRUE;
1386 }
1387
1388
1389 /* Likewise, warn if any say to, plus if deprecation warnings
1390 * are on, because this code point is above IV_MAX */
1391 if ( ckWARN_d(WARN_DEPRECATED)
1392 || ! (flags & UTF8_ALLOW_OVERFLOW)
1393 || (flags & (UTF8_WARN_SUPER|UTF8_WARN_ABOVE_31_BIT)))
1394 {
2b5e7bc2 1395
ddb65933
KW
1396 /* The warnings code explicitly says it doesn't handle the
1397 * case of packWARN2 and two categories which have
1398 * parent-child relationship. Even if it works now to
1399 * raise the warning if either is enabled, it wouldn't
1400 * necessarily do so in the future. We output (only) the
1401 * most dire warning*/
1402 if (! (flags & UTF8_CHECK_ONLY)) {
1403 if (ckWARN_d(WARN_UTF8)) {
1404 pack_warn = packWARN(WARN_UTF8);
1405 }
1406 else if (ckWARN_d(WARN_NON_UNICODE)) {
1407 pack_warn = packWARN(WARN_NON_UNICODE);
1408 }
1409 if (pack_warn) {
1410 message = Perl_form(aTHX_ "%s: %s (overflows)",
1411 malformed_text,
7e2f38b2 1412 _byte_dump_string(s0, send - s0, 0));
ddb65933 1413 }
2b5e7bc2
KW
1414 }
1415 }
1416 }
1417 else if (possible_problems & UTF8_GOT_EMPTY) {
1418 possible_problems &= ~UTF8_GOT_EMPTY;
f9380377 1419 *errors |= UTF8_GOT_EMPTY;
2b5e7bc2
KW
1420
1421 if (! (flags & UTF8_ALLOW_EMPTY)) {
d1f8d421
KW
1422
1423 /* This so-called malformation is now treated as a bug in
1424 * the caller. If you have nothing to decode, skip calling
1425 * this function */
1426 assert(0);
1427
2b5e7bc2
KW
1428 disallowed = TRUE;
1429 if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
1430 pack_warn = packWARN(WARN_UTF8);
1431 message = Perl_form(aTHX_ "%s (empty string)",
1432 malformed_text);
1433 }
1434 }
1435 }
1436 else if (possible_problems & UTF8_GOT_CONTINUATION) {
1437 possible_problems &= ~UTF8_GOT_CONTINUATION;
f9380377 1438 *errors |= UTF8_GOT_CONTINUATION;
2b5e7bc2
KW
1439
1440 if (! (flags & UTF8_ALLOW_CONTINUATION)) {
1441 disallowed = TRUE;
1442 if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
1443 pack_warn = packWARN(WARN_UTF8);
1444 message = Perl_form(aTHX_
1445 "%s: %s (unexpected continuation byte 0x%02x,"
1446 " with no preceding start byte)",
1447 malformed_text,
7e2f38b2 1448 _byte_dump_string(s0, 1, 0), *s0);
2b5e7bc2
KW
1449 }
1450 }
1451 }
2b5e7bc2
KW
1452 else if (possible_problems & UTF8_GOT_SHORT) {
1453 possible_problems &= ~UTF8_GOT_SHORT;
f9380377 1454 *errors |= UTF8_GOT_SHORT;
2b5e7bc2
KW
1455
1456 if (! (flags & UTF8_ALLOW_SHORT)) {
1457 disallowed = TRUE;
1458 if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
1459 pack_warn = packWARN(WARN_UTF8);
1460 message = Perl_form(aTHX_
9a6c9c81 1461 "%s: %s (too short; %d byte%s available, need %d)",
2b5e7bc2 1462 malformed_text,
7e2f38b2 1463 _byte_dump_string(s0, send - s0, 0),
e308b348
KW
1464 (int)avail_len,
1465 avail_len == 1 ? "" : "s",
2b5e7bc2
KW
1466 (int)expectlen);
1467 }
1468 }
ba210ebe 1469
2b5e7bc2 1470 }
e308b348
KW
1471 else if (possible_problems & UTF8_GOT_NON_CONTINUATION) {
1472 possible_problems &= ~UTF8_GOT_NON_CONTINUATION;
1473 *errors |= UTF8_GOT_NON_CONTINUATION;
1474
1475 if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) {
1476 disallowed = TRUE;
1477 if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
99a765e9
KW
1478
1479 /* If we don't know for sure that the input length is
1480 * valid, avoid as much as possible reading past the
1481 * end of the buffer */
1482 int printlen = (flags & _UTF8_NO_CONFIDENCE_IN_CURLEN)
1483 ? s - s0
1484 : send - s0;
e308b348
KW
1485 pack_warn = packWARN(WARN_UTF8);
1486 message = Perl_form(aTHX_ "%s",
1487 unexpected_non_continuation_text(s0,
99a765e9 1488 printlen,
e308b348
KW
1489 s - s0,
1490 (int) expectlen));
1491 }
1492 }
1493 }
2b5e7bc2
KW
1494 else if (possible_problems & UTF8_GOT_LONG) {
1495 possible_problems &= ~UTF8_GOT_LONG;
f9380377 1496 *errors |= UTF8_GOT_LONG;
2b5e7bc2 1497
94953955
KW
1498 if (flags & UTF8_ALLOW_LONG) {
1499
1500 /* We don't allow the actual overlong value, unless the
1501 * special extra bit is also set */
1502 if (! (flags & ( UTF8_ALLOW_LONG_AND_ITS_VALUE
1503 & ~UTF8_ALLOW_LONG)))
1504 {
1505 uv = UNICODE_REPLACEMENT;
1506 }
1507 }
1508 else {
2b5e7bc2
KW
1509 disallowed = TRUE;
1510
1511 if (ckWARN_d(WARN_UTF8) && ! (flags & UTF8_CHECK_ONLY)) {
1512 pack_warn = packWARN(WARN_UTF8);
1513
1514 /* These error types cause 'uv' to be something that
1515 * isn't what was intended, so can't use it in the
1516 * message. The other error types either can't
1517 * generate an overlong, or else the 'uv' is valid */
1518 if (orig_problems &
1519 (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
1520 {
1521 message = Perl_form(aTHX_
1522 "%s: %s (any UTF-8 sequence that starts"
1523 " with \"%s\" is overlong which can and"
1524 " should be represented with a"
1525 " different, shorter sequence)",
1526 malformed_text,
7e2f38b2
KW
1527 _byte_dump_string(s0, send - s0, 0),
1528 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
1529 }
1530 else {
1531 U8 tmpbuf[UTF8_MAXBYTES+1];
1532 const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf,
1533 uv, 0);
1534 message = Perl_form(aTHX_
1535 "%s: %s (overlong; instead use %s to represent"
147e3846 1536 " U+%0*" UVXf ")",
2b5e7bc2 1537 malformed_text,
7e2f38b2
KW
1538 _byte_dump_string(s0, send - s0, 0),
1539 _byte_dump_string(tmpbuf, e - tmpbuf, 0),
2b5e7bc2
KW
1540 ((uv < 256) ? 2 : 4), /* Field width of 2 for
1541 small code points */
1542 uv);
1543 }
1544 }
1545 }
1546 }
1547 else if (possible_problems & UTF8_GOT_SURROGATE) {
1548 possible_problems &= ~UTF8_GOT_SURROGATE;
1549
f9380377
KW
1550 if (flags & UTF8_WARN_SURROGATE) {
1551 *errors |= UTF8_GOT_SURROGATE;
1552
1553 if ( ! (flags & UTF8_CHECK_ONLY)
1554 && ckWARN_d(WARN_SURROGATE))
1555 {
2b5e7bc2
KW
1556 pack_warn = packWARN(WARN_SURROGATE);
1557
1558 /* These are the only errors that can occur with a
1559 * surrogate when the 'uv' isn't valid */
1560 if (orig_problems & UTF8_GOT_TOO_SHORT) {
1561 message = Perl_form(aTHX_
1562 "UTF-16 surrogate (any UTF-8 sequence that"
1563 " starts with \"%s\" is for a surrogate)",
7e2f38b2 1564 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
1565 }
1566 else {
1567 message = Perl_form(aTHX_
147e3846 1568 "UTF-16 surrogate U+%04" UVXf, uv);
2b5e7bc2 1569 }
f9380377 1570 }
2b5e7bc2 1571 }
ba210ebe 1572
2b5e7bc2
KW
1573 if (flags & UTF8_DISALLOW_SURROGATE) {
1574 disallowed = TRUE;
f9380377 1575 *errors |= UTF8_GOT_SURROGATE;
2b5e7bc2
KW
1576 }
1577 }
1578 else if (possible_problems & UTF8_GOT_SUPER) {
1579 possible_problems &= ~UTF8_GOT_SUPER;
949cf498 1580
f9380377
KW
1581 if (flags & UTF8_WARN_SUPER) {
1582 *errors |= UTF8_GOT_SUPER;
1583
1584 if ( ! (flags & UTF8_CHECK_ONLY)
1585 && ckWARN_d(WARN_NON_UNICODE))
1586 {
2b5e7bc2
KW
1587 pack_warn = packWARN(WARN_NON_UNICODE);
1588
1589 if (orig_problems & UTF8_GOT_TOO_SHORT) {
1590 message = Perl_form(aTHX_
1591 "Any UTF-8 sequence that starts with"
1592 " \"%s\" is for a non-Unicode code point,"
1593 " may not be portable",
7e2f38b2 1594 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
1595 }
1596 else {
1597 message = Perl_form(aTHX_
147e3846 1598 "Code point 0x%04" UVXf " is not"
2b5e7bc2
KW
1599 " Unicode, may not be portable",
1600 uv);
1601 }
f9380377 1602 }
2b5e7bc2 1603 }
ba210ebe 1604
2b5e7bc2
KW
1605 /* The maximum code point ever specified by a standard was
1606 * 2**31 - 1. Anything larger than that is a Perl extension
1607 * that very well may not be understood by other applications
1608 * (including earlier perl versions on EBCDIC platforms). We
1609 * test for these after the regular SUPER ones, and before
1610 * possibly bailing out, so that the slightly more dire warning
1611 * will override the regular one. */
1612 if ( (flags & (UTF8_WARN_ABOVE_31_BIT
1613 |UTF8_WARN_SUPER
1614 |UTF8_DISALLOW_ABOVE_31_BIT))
1615 && ( ( UNLIKELY(orig_problems & UTF8_GOT_TOO_SHORT)
1616 && UNLIKELY(is_utf8_cp_above_31_bits(
1617 adjusted_s0,
1618 adjusted_send)))
1619 || ( LIKELY(! (orig_problems & UTF8_GOT_TOO_SHORT))
1620 && UNLIKELY(UNICODE_IS_ABOVE_31_BIT(uv)))))
1621 {
1622 if ( ! (flags & UTF8_CHECK_ONLY)
1623 && (flags & (UTF8_WARN_ABOVE_31_BIT|UTF8_WARN_SUPER))
1624 && ckWARN_d(WARN_UTF8))
1625 {
1626 pack_warn = packWARN(WARN_UTF8);
1627
1628 if (orig_problems & UTF8_GOT_TOO_SHORT) {
1629 message = Perl_form(aTHX_
1630 "Any UTF-8 sequence that starts with"
1631 " \"%s\" is for a non-Unicode code"
1632 " point, and is not portable",
7e2f38b2 1633 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
1634 }
1635 else {
1636 message = Perl_form(aTHX_
147e3846 1637 "Code point 0x%" UVXf " is not Unicode,"
2b5e7bc2
KW
1638 " and not portable",
1639 uv);
1640 }
1641 }
1642
ddb65933
KW
1643 if (flags & ( UTF8_WARN_ABOVE_31_BIT
1644 |UTF8_DISALLOW_ABOVE_31_BIT))
1645 {
f9380377
KW
1646 *errors |= UTF8_GOT_ABOVE_31_BIT;
1647
1648 if (flags & UTF8_DISALLOW_ABOVE_31_BIT) {
1649 disallowed = TRUE;
1650 }
2b5e7bc2
KW
1651 }
1652 }
eb83ed87 1653
2b5e7bc2 1654 if (flags & UTF8_DISALLOW_SUPER) {
f9380377 1655 *errors |= UTF8_GOT_SUPER;
2b5e7bc2
KW
1656 disallowed = TRUE;
1657 }
eb83ed87 1658
2b5e7bc2
KW
1659 /* The deprecated warning overrides any non-deprecated one. If
1660 * there are other problems, a deprecation message is not
1661 * really helpful, so don't bother to raise it in that case.
1662 * This also keeps the code from having to handle the case
1663 * where 'uv' is not valid. */
1664 if ( ! (orig_problems
1665 & (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
1666 && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
1667 && ckWARN_d(WARN_DEPRECATED))
1668 {
1669 message = Perl_form(aTHX_ cp_above_legal_max,
1670 uv, MAX_NON_DEPRECATED_CP);
1671 pack_warn = packWARN(WARN_DEPRECATED);
1672 }
1673 }
1674 else if (possible_problems & UTF8_GOT_NONCHAR) {
1675 possible_problems &= ~UTF8_GOT_NONCHAR;
ba210ebe 1676
f9380377
KW
1677 if (flags & UTF8_WARN_NONCHAR) {
1678 *errors |= UTF8_GOT_NONCHAR;
1679
1680 if ( ! (flags & UTF8_CHECK_ONLY)
1681 && ckWARN_d(WARN_NONCHAR))
1682 {
2b5e7bc2
KW
1683 /* The code above should have guaranteed that we don't
1684 * get here with errors other than overlong */
1685 assert (! (orig_problems
1686 & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR)));
1687
1688 pack_warn = packWARN(WARN_NONCHAR);
1689 message = Perl_form(aTHX_ "Unicode non-character"
147e3846 1690 " U+%04" UVXf " is not recommended"
2b5e7bc2 1691 " for open interchange", uv);
f9380377 1692 }
2b5e7bc2 1693 }
5b311467 1694
2b5e7bc2
KW
1695 if (flags & UTF8_DISALLOW_NONCHAR) {
1696 disallowed = TRUE;
f9380377 1697 *errors |= UTF8_GOT_NONCHAR;
2b5e7bc2
KW
1698 }
1699 } /* End of looking through the possible flags */
1700
1701 /* Display the message (if any) for the problem being handled in
1702 * this iteration of the loop */
1703 if (message) {
1704 if (PL_op)
1705 Perl_warner(aTHX_ pack_warn, "%s in %s", message,
1706 OP_DESC(PL_op));
1707 else
1708 Perl_warner(aTHX_ pack_warn, "%s", message);
1709 }
ddb65933 1710 } /* End of 'while (possible_problems)' */
a0dbb045 1711
2b5e7bc2
KW
1712 /* Since there was a possible problem, the returned length may need to
1713 * be changed from the one stored at the beginning of this function.
1714 * Instead of trying to figure out if that's needed, just do it. */
1715 if (retlen) {
1716 *retlen = curlen;
1717 }
a0dbb045 1718
2b5e7bc2
KW
1719 if (disallowed) {
1720 if (flags & UTF8_CHECK_ONLY && retlen) {
1721 *retlen = ((STRLEN) -1);
1722 }
1723 return 0;
1724 }
eb83ed87 1725 }
ba210ebe 1726
2b5e7bc2 1727 return UNI_TO_NATIVE(uv);
a0ed51b3
LW
1728}
1729
8e84507e 1730/*
ec5f19d0
KW
1731=for apidoc utf8_to_uvchr_buf
1732
1733Returns the native code point of the first character in the string C<s> which
1734is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
524080c4 1735C<*retlen> will be set to the length, in bytes, of that character.
ec5f19d0 1736
524080c4
KW
1737If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
1738enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
796b6530 1739C<NULL>) to -1. If those warnings are off, the computed value, if well-defined
173db420 1740(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
796b6530 1741C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
173db420 1742the next possible position in C<s> that could begin a non-malformed character.
de69f3af 1743See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
173db420 1744returned.
ec5f19d0 1745
760c7c2f
KW
1746Code points above the platform's C<IV_MAX> will raise a deprecation warning,
1747unless those are turned off.
1748
ec5f19d0 1749=cut
52be2536
KW
1750
1751Also implemented as a macro in utf8.h
1752
ec5f19d0
KW
1753*/
1754
1755
1756UV
1757Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1758{
7f974d7e
KW
1759 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
1760
ec5f19d0
KW
1761 assert(s < send);
1762
1763 return utf8n_to_uvchr(s, send - s, retlen,
ddb65933 1764 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
ec5f19d0
KW
1765}
1766
52be2536
KW
1767/* This is marked as deprecated
1768 *
ec5f19d0
KW
1769=for apidoc utf8_to_uvuni_buf
1770
de69f3af
KW
1771Only in very rare circumstances should code need to be dealing in Unicode
1772(as opposed to native) code points. In those few cases, use
1773C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>> instead.
4f83cdcd
KW
1774
1775Returns the Unicode (not-native) code point of the first character in the
1776string C<s> which
ec5f19d0
KW
1777is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
1778C<retlen> will be set to the length, in bytes, of that character.
1779
524080c4
KW
1780If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
1781enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
1782NULL) to -1. If those warnings are off, the computed value if well-defined (or
1783the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
1784is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
1785next possible position in C<s> that could begin a non-malformed character.
de69f3af 1786See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
ec5f19d0 1787
760c7c2f
KW
1788Code points above the platform's C<IV_MAX> will raise a deprecation warning,
1789unless those are turned off.
1790
ec5f19d0
KW
1791=cut
1792*/
1793
1794UV
1795Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1796{
1797 PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
1798
1799 assert(send > s);
1800
5962d97e
KW
1801 /* Call the low level routine, asking for checks */
1802 return NATIVE_TO_UNI(utf8_to_uvchr_buf(s, send, retlen));
ec5f19d0
KW
1803}
1804
b76347f2 1805/*
87cea99e 1806=for apidoc utf8_length
b76347f2
JH
1807
1808Return the length of the UTF-8 char encoded string C<s> in characters.
02eb7b47
JH
1809Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
1810up past C<e>, croaks.
b76347f2
JH
1811
1812=cut
1813*/
1814
1815STRLEN
35a4481c 1816Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2
JH
1817{
1818 STRLEN len = 0;
1819
7918f24d
NC
1820 PERL_ARGS_ASSERT_UTF8_LENGTH;
1821
8850bf83
JH
1822 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
1823 * the bitops (especially ~) can create illegal UTF-8.
1824 * In other words: in Perl UTF-8 is not just for Unicode. */
1825
a3b680e6
AL
1826 if (e < s)
1827 goto warn_and_return;
b76347f2 1828 while (s < e) {
4cbf4130 1829 s += UTF8SKIP(s);
8e91ec7f
AV
1830 len++;
1831 }
1832
1833 if (e != s) {
1834 len--;
1835 warn_and_return:
9b387841
NC
1836 if (PL_op)
1837 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1838 "%s in %s", unees, OP_DESC(PL_op));
1839 else
61a12c31 1840 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
b76347f2
JH
1841 }
1842
1843 return len;
1844}
1845
b06226ff 1846/*
fed3ba5d
NC
1847=for apidoc bytes_cmp_utf8
1848
a1433954 1849Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
72d33970
FC
1850sequence of characters (stored as UTF-8)
1851in C<u>, C<ulen>. Returns 0 if they are
fed3ba5d
NC
1852equal, -1 or -2 if the first string is less than the second string, +1 or +2
1853if the first string is greater than the second string.
1854
1855-1 or +1 is returned if the shorter string was identical to the start of the
72d33970
FC
1856longer string. -2 or +2 is returned if
1857there was a difference between characters
fed3ba5d
NC
1858within the strings.
1859
1860=cut
1861*/
1862
1863int
1864Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
1865{
1866 const U8 *const bend = b + blen;
1867 const U8 *const uend = u + ulen;
1868
1869 PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
fed3ba5d
NC
1870
1871 while (b < bend && u < uend) {
1872 U8 c = *u++;
1873 if (!UTF8_IS_INVARIANT(c)) {
1874 if (UTF8_IS_DOWNGRADEABLE_START(c)) {
1875 if (u < uend) {
1876 U8 c1 = *u++;
1877 if (UTF8_IS_CONTINUATION(c1)) {
a62b247b 1878 c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
fed3ba5d 1879 } else {
2b5e7bc2 1880 /* diag_listed_as: Malformed UTF-8 character%s */
fed3ba5d 1881 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
806547a7 1882 "%s %s%s",
7cf8d05d 1883 unexpected_non_continuation_text(u - 1, 2, 1, 2),
806547a7
KW
1884 PL_op ? " in " : "",
1885 PL_op ? OP_DESC(PL_op) : "");
fed3ba5d
NC
1886 return -2;
1887 }
1888 } else {
1889 if (PL_op)
1890 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
1891 "%s in %s", unees, OP_DESC(PL_op));
1892 else
61a12c31 1893 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
fed3ba5d
NC
1894 return -2; /* Really want to return undef :-) */
1895 }
1896 } else {
1897 return -2;
1898 }
1899 }
1900 if (*b != c) {
1901 return *b < c ? -2 : +2;
1902 }
1903 ++b;
1904 }
1905
1906 if (b == bend && u == uend)
1907 return 0;
1908
1909 return b < bend ? +1 : -1;
1910}
1911
1912/*
87cea99e 1913=for apidoc utf8_to_bytes
6940069f 1914
2bbc8d55 1915Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954
KW
1916Unlike L</bytes_to_utf8>, this over-writes the original string, and
1917updates C<len> to contain the new length.
67e989fb 1918Returns zero on failure, setting C<len> to -1.
6940069f 1919
a1433954 1920If you need a copy of the string, see L</bytes_from_utf8>.
95be277c 1921
6940069f
GS
1922=cut
1923*/
1924
1925U8 *
37607a96 1926Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
6940069f 1927{
d4c19fe8
AL
1928 U8 * const save = s;
1929 U8 * const send = s + *len;
6940069f 1930 U8 *d;
246fae53 1931
7918f24d 1932 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
81611534 1933 PERL_UNUSED_CONTEXT;
7918f24d 1934
1e54db1a 1935 /* ensure valid UTF-8 and chars < 256 before updating string */
d4c19fe8 1936 while (s < send) {
d59937ca
KW
1937 if (! UTF8_IS_INVARIANT(*s)) {
1938 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
1939 *len = ((STRLEN) -1);
1940 return 0;
1941 }
1942 s++;
dcad2880 1943 }
d59937ca 1944 s++;
246fae53 1945 }
dcad2880
JH
1946
1947 d = s = save;
6940069f 1948 while (s < send) {
80e0b38f
KW
1949 U8 c = *s++;
1950 if (! UTF8_IS_INVARIANT(c)) {
1951 /* Then it is two-byte encoded */
a62b247b 1952 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
80e0b38f
KW
1953 s++;
1954 }
1955 *d++ = c;
6940069f
GS
1956 }
1957 *d = '\0';
246fae53 1958 *len = d - save;
6940069f
GS
1959 return save;
1960}
1961
1962/*
87cea99e 1963=for apidoc bytes_from_utf8
f9a63242 1964
2bbc8d55 1965Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
a1433954 1966Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
ef9edfd0
JH
1967the newly-created string, and updates C<len> to contain the new
1968length. Returns the original string if no conversion occurs, C<len>
72d33970 1969is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
2bbc8d55 19700 if C<s> is converted or consisted entirely of characters that are invariant
4a4088c4 1971in UTF-8 (i.e., US-ASCII on non-EBCDIC machines).
f9a63242 1972
37607a96
PK
1973=cut
1974*/
f9a63242
JH
1975
1976U8 *
e1ec3a88 1977Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
f9a63242 1978{
f9a63242 1979 U8 *d;
e1ec3a88
AL
1980 const U8 *start = s;
1981 const U8 *send;
f9a63242
JH
1982 I32 count = 0;
1983
7918f24d 1984 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
96a5add6 1985 PERL_UNUSED_CONTEXT;
f9a63242 1986 if (!*is_utf8)
73d840c0 1987 return (U8 *)start;
f9a63242 1988
1e54db1a 1989 /* ensure valid UTF-8 and chars < 256 before converting string */
f9a63242 1990 for (send = s + *len; s < send;) {
d59937ca
KW
1991 if (! UTF8_IS_INVARIANT(*s)) {
1992 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
73d840c0 1993 return (U8 *)start;
d59937ca
KW
1994 }
1995 count++;
1996 s++;
db42d148 1997 }
d59937ca 1998 s++;
f9a63242
JH
1999 }
2000
35da51f7 2001 *is_utf8 = FALSE;
f9a63242 2002
212542aa 2003 Newx(d, (*len) - count + 1, U8);
ef9edfd0 2004 s = start; start = d;
f9a63242
JH
2005 while (s < send) {
2006 U8 c = *s++;
1a91c45d 2007 if (! UTF8_IS_INVARIANT(c)) {
c4d5f83a 2008 /* Then it is two-byte encoded */
a62b247b 2009 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
1a91c45d 2010 s++;
c4d5f83a
NIS
2011 }
2012 *d++ = c;
f9a63242
JH
2013 }
2014 *d = '\0';
2015 *len = d - start;
73d840c0 2016 return (U8 *)start;
f9a63242
JH
2017}
2018
2019/*
87cea99e 2020=for apidoc bytes_to_utf8
6940069f 2021
ff97e5cf
KW
2022Converts a string C<s> of length C<len> bytes from the native encoding into
2023UTF-8.
6662521e 2024Returns a pointer to the newly-created string, and sets C<len> to
ff97e5cf 2025reflect the new length in bytes.
6940069f 2026
75200dff 2027A C<NUL> character will be written after the end of the string.
2bbc8d55
SP
2028
2029If you want to convert to UTF-8 from encodings other than
2030the native (Latin1 or EBCDIC),
a1433954 2031see L</sv_recode_to_utf8>().
c9ada85f 2032
497711e7 2033=cut
6940069f
GS
2034*/
2035
c682ebef
FC
2036/* This logic is duplicated in sv_catpvn_flags, so any bug fixes will
2037 likewise need duplication. */
2038
6940069f 2039U8*
35a4481c 2040Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
6940069f 2041{
35a4481c 2042 const U8 * const send = s + (*len);
6940069f
GS
2043 U8 *d;
2044 U8 *dst;
7918f24d
NC
2045
2046 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
96a5add6 2047 PERL_UNUSED_CONTEXT;
6940069f 2048
212542aa 2049 Newx(d, (*len) * 2 + 1, U8);
6940069f
GS
2050 dst = d;
2051
2052 while (s < send) {
55d09dc8
KW
2053 append_utf8_from_native_byte(*s, &d);
2054 s++;
6940069f
GS
2055 }
2056 *d = '\0';
6662521e 2057 *len = d-dst;
6940069f
GS
2058 return dst;
2059}
2060
a0ed51b3 2061/*
dea0fc0b 2062 * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
a0ed51b3
LW
2063 *
2064 * Destination must be pre-extended to 3/2 source. Do not use in-place.
2065 * We optimize for native, for obvious reasons. */
2066
2067U8*
dea0fc0b 2068Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 2069{
dea0fc0b
JH
2070 U8* pend;
2071 U8* dstart = d;
2072
7918f24d
NC
2073 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
2074
dea0fc0b 2075 if (bytelen & 1)
147e3846 2076 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %" UVuf, (UV)bytelen);
dea0fc0b
JH
2077
2078 pend = p + bytelen;
2079
a0ed51b3 2080 while (p < pend) {
dea0fc0b
JH
2081 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
2082 p += 2;
2d1545e5 2083 if (OFFUNI_IS_INVARIANT(uv)) {
56d37426 2084 *d++ = LATIN1_TO_NATIVE((U8) uv);
a0ed51b3
LW
2085 continue;
2086 }
56d37426
KW
2087 if (uv <= MAX_UTF8_TWO_BYTE) {
2088 *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv));
2089 *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv));
a0ed51b3
LW
2090 continue;
2091 }
46956fad
KW
2092#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
2093#define LAST_HIGH_SURROGATE 0xDBFF
2094#define FIRST_LOW_SURROGATE 0xDC00
2095#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
e23c50db
KW
2096
2097 /* This assumes that most uses will be in the first Unicode plane, not
2098 * needing surrogates */
2099 if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST
2100 && uv <= UNICODE_SURROGATE_LAST))
2101 {
2102 if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) {
2103 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
2104 }
2105 else {
01ea242b 2106 UV low = (p[0] << 8) + p[1];
e23c50db
KW
2107 if ( UNLIKELY(low < FIRST_LOW_SURROGATE)
2108 || UNLIKELY(low > LAST_LOW_SURROGATE))
2109 {
01ea242b 2110 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
e23c50db
KW
2111 }
2112 p += 2;
46956fad
KW
2113 uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
2114 + (low - FIRST_LOW_SURROGATE) + 0x10000;
01ea242b 2115 }
a0ed51b3 2116 }
56d37426
KW
2117#ifdef EBCDIC
2118 d = uvoffuni_to_utf8_flags(d, uv, 0);
2119#else
a0ed51b3 2120 if (uv < 0x10000) {
eb160463
GS
2121 *d++ = (U8)(( uv >> 12) | 0xe0);
2122 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
2123 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
2124 continue;
2125 }
2126 else {
eb160463
GS
2127 *d++ = (U8)(( uv >> 18) | 0xf0);
2128 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
2129 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
2130 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
2131 continue;
2132 }
56d37426 2133#endif
a0ed51b3 2134 }
dea0fc0b 2135 *newlen = d - dstart;
a0ed51b3
LW
2136 return d;
2137}
2138
2139/* Note: this one is slightly destructive of the source. */
2140
2141U8*
dea0fc0b 2142Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
2143{
2144 U8* s = (U8*)p;
d4c19fe8 2145 U8* const send = s + bytelen;
7918f24d
NC
2146
2147 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
2148
e0ea5e2d 2149 if (bytelen & 1)
147e3846 2150 Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %" UVuf,
e0ea5e2d
NC
2151 (UV)bytelen);
2152
a0ed51b3 2153 while (s < send) {
d4c19fe8 2154 const U8 tmp = s[0];
a0ed51b3
LW
2155 s[0] = s[1];
2156 s[1] = tmp;
2157 s += 2;
2158 }
dea0fc0b 2159 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
2160}
2161
922e8cb4
KW
2162bool
2163Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
2164{
2165 U8 tmpbuf[UTF8_MAXBYTES+1];
2166 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2167 return _is_utf8_FOO_with_len(classnum, tmpbuf, tmpbuf + sizeof(tmpbuf));
922e8cb4
KW
2168}
2169
f9ae8fb6
JD
2170/* Internal function so we can deprecate the external one, and call
2171 this one from other deprecated functions in this file */
2172
f2645549
KW
2173bool
2174Perl__is_utf8_idstart(pTHX_ const U8 *p)
61b19385 2175{
f2645549 2176 PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
61b19385
KW
2177
2178 if (*p == '_')
2179 return TRUE;
f25ce844 2180 return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
61b19385
KW
2181}
2182
5092f92a 2183bool
eba68aa0
KW
2184Perl__is_uni_perl_idcont(pTHX_ UV c)
2185{
2186 U8 tmpbuf[UTF8_MAXBYTES+1];
2187 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2188 return _is_utf8_perl_idcont_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
eba68aa0
KW
2189}
2190
2191bool
f91dcd13
KW
2192Perl__is_uni_perl_idstart(pTHX_ UV c)
2193{
2194 U8 tmpbuf[UTF8_MAXBYTES+1];
2195 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2196 return _is_utf8_perl_idstart_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
f91dcd13
KW
2197}
2198
3a4c58c9
KW
2199UV
2200Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
2201{
2202 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 2203 * those, converting the result to UTF-8. The only difference between upper
3a4c58c9
KW
2204 * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
2205 * either "SS" or "Ss". Which one to use is passed into the routine in
2206 * 'S_or_s' to avoid a test */
2207
2208 UV converted = toUPPER_LATIN1_MOD(c);
2209
2210 PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
2211
2212 assert(S_or_s == 'S' || S_or_s == 's');
2213
6f2d5cbc 2214 if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for
f4cd282c 2215 characters in this range */
3a4c58c9
KW
2216 *p = (U8) converted;
2217 *lenp = 1;
2218 return converted;
2219 }
2220
2221 /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
2222 * which it maps to one of them, so as to only have to have one check for
2223 * it in the main case */
2224 if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
2225 switch (c) {
2226 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
2227 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
2228 break;
2229 case MICRO_SIGN:
2230 converted = GREEK_CAPITAL_LETTER_MU;
2231 break;
79e064b9
KW
2232#if UNICODE_MAJOR_VERSION > 2 \
2233 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
2234 && UNICODE_DOT_DOT_VERSION >= 8)
3a4c58c9
KW
2235 case LATIN_SMALL_LETTER_SHARP_S:
2236 *(p)++ = 'S';
2237 *p = S_or_s;
2238 *lenp = 2;
2239 return 'S';
79e064b9 2240#endif
3a4c58c9
KW
2241 default:
2242 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
e5964223 2243 NOT_REACHED; /* NOTREACHED */
3a4c58c9
KW
2244 }
2245 }
2246
2247 *(p)++ = UTF8_TWO_BYTE_HI(converted);
2248 *p = UTF8_TWO_BYTE_LO(converted);
2249 *lenp = 2;
2250
2251 return converted;
2252}
2253
50bda2c3
KW
2254/* Call the function to convert a UTF-8 encoded character to the specified case.
2255 * Note that there may be more than one character in the result.
2256 * INP is a pointer to the first byte of the input character
2257 * OUTP will be set to the first byte of the string of changed characters. It
2258 * needs to have space for UTF8_MAXBYTES_CASE+1 bytes
2259 * LENP will be set to the length in bytes of the string of changed characters
2260 *
2261 * The functions return the ordinal of the first character in the string of OUTP */
b9992569
KW
2262#define CALL_UPPER_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_toupper, "ToUc", "")
2263#define CALL_TITLE_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_totitle, "ToTc", "")
2264#define CALL_LOWER_CASE(uv, s, d, lenp) _to_utf8_case(uv, s, d, lenp, &PL_utf8_tolower, "ToLc", "")
50bda2c3 2265
b9992569
KW
2266/* This additionally has the input parameter 'specials', which if non-zero will
2267 * cause this to use the specials hash for folding (meaning get full case
50bda2c3 2268 * folding); otherwise, when zero, this implies a simple case fold */
b9992569 2269#define CALL_FOLD_CASE(uv, s, d, lenp, specials) _to_utf8_case(uv, s, d, lenp, &PL_utf8_tofold, "ToCf", (specials) ? "" : NULL)
c3fd2246 2270
84afefe6
JH
2271UV
2272Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 2273{
a1433954
KW
2274 /* Convert the Unicode character whose ordinal is <c> to its uppercase
2275 * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
2276 * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
c3fd2246
KW
2277 * the changed version may be longer than the original character.
2278 *
2279 * The ordinal of the first character of the changed version is returned
2280 * (but note, as explained above, that there may be more.) */
2281
7918f24d
NC
2282 PERL_ARGS_ASSERT_TO_UNI_UPPER;
2283
3a4c58c9
KW
2284 if (c < 256) {
2285 return _to_upper_title_latin1((U8) c, p, lenp, 'S');
2286 }
2287
0ebc6274 2288 uvchr_to_utf8(p, c);
b9992569 2289 return CALL_UPPER_CASE(c, p, p, lenp);
a0ed51b3
LW
2290}
2291
84afefe6
JH
2292UV
2293Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 2294{
7918f24d
NC
2295 PERL_ARGS_ASSERT_TO_UNI_TITLE;
2296
3a4c58c9
KW
2297 if (c < 256) {
2298 return _to_upper_title_latin1((U8) c, p, lenp, 's');
2299 }
2300
0ebc6274 2301 uvchr_to_utf8(p, c);
b9992569 2302 return CALL_TITLE_CASE(c, p, p, lenp);
a0ed51b3
LW
2303}
2304
afc16117 2305STATIC U8
eaf412bf 2306S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp, const char dummy)
afc16117
KW
2307{
2308 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 2309 * those, converting the result to UTF-8. Since the result is always just
a1433954 2310 * one character, we allow <p> to be NULL */
afc16117
KW
2311
2312 U8 converted = toLOWER_LATIN1(c);
2313
eaf412bf
KW
2314 PERL_UNUSED_ARG(dummy);
2315
afc16117 2316 if (p != NULL) {
6f2d5cbc 2317 if (NATIVE_BYTE_IS_INVARIANT(converted)) {
afc16117
KW
2318 *p = converted;
2319 *lenp = 1;
2320 }
2321 else {
430c9760
KW
2322 /* Result is known to always be < 256, so can use the EIGHT_BIT
2323 * macros */
2324 *p = UTF8_EIGHT_BIT_HI(converted);
2325 *(p+1) = UTF8_EIGHT_BIT_LO(converted);
afc16117
KW
2326 *lenp = 2;
2327 }
2328 }
2329 return converted;
2330}
2331
84afefe6
JH
2332UV
2333Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 2334{
7918f24d
NC
2335 PERL_ARGS_ASSERT_TO_UNI_LOWER;
2336
afc16117 2337 if (c < 256) {
eaf412bf 2338 return to_lower_latin1((U8) c, p, lenp, 0 /* 0 is a dummy arg */ );
bca00c02
KW
2339 }
2340
afc16117 2341 uvchr_to_utf8(p, c);
b9992569 2342 return CALL_LOWER_CASE(c, p, p, lenp);
a0ed51b3
LW
2343}
2344
84afefe6 2345UV
51910141 2346Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const unsigned int flags)
a1dde8de 2347{
51910141 2348 /* Corresponds to to_lower_latin1(); <flags> bits meanings:
1ca267a5 2349 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
51910141 2350 * FOLD_FLAGS_FULL iff full folding is to be used;
1ca267a5
KW
2351 *
2352 * Not to be used for locale folds
51910141 2353 */
f673fad4 2354
a1dde8de
KW
2355 UV converted;
2356
2357 PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
81611534 2358 PERL_UNUSED_CONTEXT;
a1dde8de 2359
1ca267a5
KW
2360 assert (! (flags & FOLD_FLAGS_LOCALE));
2361
659a7c2d 2362 if (UNLIKELY(c == MICRO_SIGN)) {
a1dde8de
KW
2363 converted = GREEK_SMALL_LETTER_MU;
2364 }
9b63e895
KW
2365#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
2366 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
2367 || UNICODE_DOT_DOT_VERSION > 0)
659a7c2d
KW
2368 else if ( (flags & FOLD_FLAGS_FULL)
2369 && UNLIKELY(c == LATIN_SMALL_LETTER_SHARP_S))
2370 {
1ca267a5
KW
2371 /* If can't cross 127/128 boundary, can't return "ss"; instead return
2372 * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}")
2373 * under those circumstances. */
2374 if (flags & FOLD_FLAGS_NOMIX_ASCII) {
2375 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
2376 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
2377 p, *lenp, U8);
2378 return LATIN_SMALL_LETTER_LONG_S;
2379 }
2380 else {
4f489194
KW
2381 *(p)++ = 's';
2382 *p = 's';
2383 *lenp = 2;
2384 return 's';
1ca267a5 2385 }
a1dde8de 2386 }
9b63e895 2387#endif
a1dde8de
KW
2388 else { /* In this range the fold of all other characters is their lower
2389 case */
2390 converted = toLOWER_LATIN1(c);
2391 }
2392
6f2d5cbc 2393 if (UVCHR_IS_INVARIANT(converted)) {
a1dde8de
KW
2394 *p = (U8) converted;
2395 *lenp = 1;
2396 }
2397 else {
2398 *(p)++ = UTF8_TWO_BYTE_HI(converted);
2399 *p = UTF8_TWO_BYTE_LO(converted);
2400 *lenp = 2;
2401 }
2402
2403 return converted;
2404}
2405
2406UV
31f05a37 2407Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
84afefe6 2408{
4b593389 2409
a0270393
KW
2410 /* Not currently externally documented, and subject to change
2411 * <flags> bits meanings:
2412 * FOLD_FLAGS_FULL iff full folding is to be used;
31f05a37
KW
2413 * FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
2414 * locale are to be used.
a0270393
KW
2415 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
2416 */
4b593389 2417
36bb2ab6 2418 PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
7918f24d 2419
780fcc9f
KW
2420 if (flags & FOLD_FLAGS_LOCALE) {
2421 /* Treat a UTF-8 locale as not being in locale at all */
2422 if (IN_UTF8_CTYPE_LOCALE) {
2423 flags &= ~FOLD_FLAGS_LOCALE;
2424 }
2425 else {
2426 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
e7b7ac46 2427 goto needs_full_generality;
780fcc9f 2428 }
31f05a37
KW
2429 }
2430
a1dde8de 2431 if (c < 256) {
e7b7ac46 2432 return _to_fold_latin1((U8) c, p, lenp,
31f05a37 2433 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
a1dde8de
KW
2434 }
2435
2f306ab9 2436 /* Here, above 255. If no special needs, just use the macro */
a0270393
KW
2437 if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
2438 uvchr_to_utf8(p, c);
b9992569 2439 return CALL_FOLD_CASE(c, p, p, lenp, flags & FOLD_FLAGS_FULL);
a0270393 2440 }
567b353c 2441 else { /* Otherwise, _toFOLD_utf8_flags has the intelligence to deal with
a0270393
KW
2442 the special flags. */
2443 U8 utf8_c[UTF8_MAXBYTES + 1];
e7b7ac46
KW
2444
2445 needs_full_generality:
a0270393 2446 uvchr_to_utf8(utf8_c, c);
a1a5ec35 2447 return _toFOLD_utf8_flags(utf8_c, utf8_c + sizeof(utf8_c), p, lenp, flags);
a0270393 2448 }
84afefe6
JH
2449}
2450
26483009 2451PERL_STATIC_INLINE bool
5141f98e 2452S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
f25ce844 2453 const char *const swashname, SV* const invlist)
bde6a22d 2454{
ea317ccb
KW
2455 /* returns a boolean giving whether or not the UTF8-encoded character that
2456 * starts at <p> is in the swash indicated by <swashname>. <swash>
2457 * contains a pointer to where the swash indicated by <swashname>
2458 * is to be stored; which this routine will do, so that future calls will
f25ce844
KW
2459 * look at <*swash> and only generate a swash if it is not null. <invlist>
2460 * is NULL or an inversion list that defines the swash. If not null, it
2461 * saves time during initialization of the swash.
ea317ccb
KW
2462 *
2463 * Note that it is assumed that the buffer length of <p> is enough to
2464 * contain all the bytes that comprise the character. Thus, <*p> should
2465 * have been checked before this call for mal-formedness enough to assure
2466 * that. */
2467
7918f24d
NC
2468 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
2469
492a624f 2470 /* The API should have included a length for the UTF-8 character in <p>,
28123549 2471 * but it doesn't. We therefore assume that p has been validated at least
492a624f
KW
2472 * as far as there being enough bytes available in it to accommodate the
2473 * character without reading beyond the end, and pass that number on to the
2474 * validating routine */
6302f837 2475 if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
86ae6e94 2476 _force_out_malformed_utf8_message(p, p + UTF8SKIP(p),
99a765e9 2477 _UTF8_NO_CONFIDENCE_IN_CURLEN,
86ae6e94
KW
2478 1 /* Die */ );
2479 NOT_REACHED; /* NOTREACHED */
28123549 2480 }
86ae6e94 2481
87367d5f
KW
2482 if (!*swash) {
2483 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
f25ce844
KW
2484 *swash = _core_swash_init("utf8",
2485
2486 /* Only use the name if there is no inversion
2487 * list; otherwise will go out to disk */
2488 (invlist) ? "" : swashname,
2489
2490 &PL_sv_undef, 1, 0, invlist, &flags);
87367d5f 2491 }
28123549 2492
bde6a22d
NC
2493 return swash_fetch(*swash, p, TRUE) != 0;
2494}
2495
da8c1a98
KW
2496PERL_STATIC_INLINE bool
2497S_is_utf8_common_with_len(pTHX_ const U8 *const p, const U8 * const e, SV **swash,
2498 const char *const swashname, SV* const invlist)
2499{
2500 /* returns a boolean giving whether or not the UTF8-encoded character that
2501 * starts at <p>, and extending no further than <e - 1> is in the swash
2502 * indicated by <swashname>. <swash> contains a pointer to where the swash
2503 * indicated by <swashname> is to be stored; which this routine will do, so
2504 * that future calls will look at <*swash> and only generate a swash if it
2505 * is not null. <invlist> is NULL or an inversion list that defines the
2506 * swash. If not null, it saves time during initialization of the swash.
2507 */
2508
2509 PERL_ARGS_ASSERT_IS_UTF8_COMMON_WITH_LEN;
2510
2511 if (! isUTF8_CHAR(p, e)) {
2512 _force_out_malformed_utf8_message(p, e, 0, 1);
2513 NOT_REACHED; /* NOTREACHED */
2514 }
2515
2516 if (!*swash) {
2517 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2518 *swash = _core_swash_init("utf8",
2519
2520 /* Only use the name if there is no inversion
2521 * list; otherwise will go out to disk */
2522 (invlist) ? "" : swashname,
2523
2524 &PL_sv_undef, 1, 0, invlist, &flags);
2525 }
2526
2527 return swash_fetch(*swash, p, TRUE) != 0;
2528}
2529
34aeb2e9
KW
2530STATIC void
2531S_warn_on_first_deprecated_use(pTHX_ const char * const name,
2532 const char * const alternative,
2533 const bool use_locale,
2534 const char * const file,
2535 const unsigned line)
2536{
2537 const char * key;
2538
2539 PERL_ARGS_ASSERT_WARN_ON_FIRST_DEPRECATED_USE;
2540
2541 if (ckWARN_d(WARN_DEPRECATED)) {
2542
2543 key = Perl_form(aTHX_ "%s;%d;%s;%d", name, use_locale, file, line);
2544 if (! hv_fetch(PL_seen_deprecated_macro, key, strlen(key), 0)) {
2545 if (! PL_seen_deprecated_macro) {
2546 PL_seen_deprecated_macro = newHV();
2547 }
2548 if (! hv_store(PL_seen_deprecated_macro, key,
2549 strlen(key), &PL_sv_undef, 0))
2550 {
2551 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2552 }
2553
c44e9413 2554 if (instr(file, "mathoms.c")) {
607313a1
KW
2555 Perl_warner(aTHX_ WARN_DEPRECATED,
2556 "In %s, line %d, starting in Perl v5.30, %s()"
2557 " will be removed. Avoid this message by"
2558 " converting to use %s().\n",
2559 file, line, name, alternative);
2560 }
2561 else {
34aeb2e9
KW
2562 Perl_warner(aTHX_ WARN_DEPRECATED,
2563 "In %s, line %d, starting in Perl v5.30, %s() will"
2564 " require an additional parameter. Avoid this"
2565 " message by converting to use %s().\n",
2566 file, line, name, alternative);
607313a1 2567 }
34aeb2e9
KW
2568 }
2569 }
2570}
2571
bde6a22d 2572bool
34aeb2e9
KW
2573Perl__is_utf8_FOO(pTHX_ U8 classnum,
2574 const U8 *p,
2575 const char * const name,
2576 const char * const alternative,
2577 const bool use_utf8,
2578 const bool use_locale,
2579 const char * const file,
2580 const unsigned line)
922e8cb4 2581{
922e8cb4
KW
2582 PERL_ARGS_ASSERT__IS_UTF8_FOO;
2583
34aeb2e9
KW
2584 warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
2585
2586 if (use_utf8 && UTF8_IS_ABOVE_LATIN1(*p)) {
34aeb2e9
KW
2587
2588 switch (classnum) {
2589 case _CC_WORDCHAR:
2590 case _CC_DIGIT:
2591 case _CC_ALPHA:
2592 case _CC_LOWER:
2593 case _CC_UPPER:
2594 case _CC_PUNCT:
2595 case _CC_PRINT:
2596 case _CC_ALPHANUMERIC:
2597 case _CC_GRAPH:
2598 case _CC_CASED:
2599
2600 return is_utf8_common(p,
2601 &PL_utf8_swash_ptrs[classnum],
2602 swash_property_names[classnum],
2603 PL_XPosix_ptrs[classnum]);
2604
2605 case _CC_SPACE:
2606 return is_XPERLSPACE_high(p);
2607 case _CC_BLANK:
2608 return is_HORIZWS_high(p);
2609 case _CC_XDIGIT:
2610 return is_XDIGIT_high(p);
2611 case _CC_CNTRL:
2612 return 0;
2613 case _CC_ASCII:
2614 return 0;
2615 case _CC_VERTSPACE:
2616 return is_VERTWS_high(p);
2617 case _CC_IDFIRST:
2618 if (! PL_utf8_perl_idstart) {
22f0498f
KW
2619 PL_utf8_perl_idstart
2620 = _new_invlist_C_array(_Perl_IDStart_invlist);
34aeb2e9 2621 }
22f0498f
KW
2622 return is_utf8_common(p, &PL_utf8_perl_idstart,
2623 "_Perl_IDStart", NULL);
34aeb2e9
KW
2624 case _CC_IDCONT:
2625 if (! PL_utf8_perl_idcont) {
22f0498f
KW
2626 PL_utf8_perl_idcont
2627 = _new_invlist_C_array(_Perl_IDCont_invlist);
34aeb2e9 2628 }
22f0498f
KW
2629 return is_utf8_common(p, &PL_utf8_perl_idcont,
2630 "_Perl_IDCont", NULL);
34aeb2e9
KW
2631 }
2632 }
2633
2634 /* idcont is the same as wordchar below 256 */
2635 if (classnum == _CC_IDCONT) {
2636 classnum = _CC_WORDCHAR;
2637 }
2638 else if (classnum == _CC_IDFIRST) {
2639 if (*p == '_') {
2640 return TRUE;
2641 }
2642 classnum = _CC_ALPHA;
2643 }
2644
2645 if (! use_locale) {
2646 if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
2647 return _generic_isCC(*p, classnum);
2648 }
922e8cb4 2649
34aeb2e9
KW
2650 return _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )), classnum);
2651 }
2652 else {
2653 if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
2654 return isFOO_lc(classnum, *p);
2655 }
2656
2657 return isFOO_lc(classnum, EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )));
2658 }
2659
2660 NOT_REACHED; /* NOTREACHED */
922e8cb4
KW
2661}
2662
2663bool
da8c1a98
KW
2664Perl__is_utf8_FOO_with_len(pTHX_ const U8 classnum, const U8 *p,
2665 const U8 * const e)
2666{
2667 PERL_ARGS_ASSERT__IS_UTF8_FOO_WITH_LEN;
2668
2669 assert(classnum < _FIRST_NON_SWASH_CC);
2670
2671 return is_utf8_common_with_len(p,
2672 e,
2673 &PL_utf8_swash_ptrs[classnum],
2674 swash_property_names[classnum],
2675 PL_XPosix_ptrs[classnum]);
2676}
2677
2678bool
da8c1a98
KW
2679Perl__is_utf8_perl_idstart_with_len(pTHX_ const U8 *p, const U8 * const e)
2680{
2681 SV* invlist = NULL;
2682
2683 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART_WITH_LEN;
2684
2685 if (! PL_utf8_perl_idstart) {
2686 invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
2687 }
2688 return is_utf8_common_with_len(p, e, &PL_utf8_perl_idstart,
2689 "_Perl_IDStart", invlist);
2690}
2691
2692bool
f2645549 2693Perl__is_utf8_xidstart(pTHX_ const U8 *p)
c11ff943 2694{
f2645549 2695 PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
c11ff943
KW
2696
2697 if (*p == '_')
2698 return TRUE;
f25ce844 2699 return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
c11ff943
KW
2700}
2701
2702bool
da8c1a98
KW
2703Perl__is_utf8_perl_idcont_with_len(pTHX_ const U8 *p, const U8 * const e)
2704{
2705 SV* invlist = NULL;
2706
2707 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT_WITH_LEN;
2708
2709 if (! PL_utf8_perl_idcont) {
2710 invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
2711 }
2712 return is_utf8_common_with_len(p, e, &PL_utf8_perl_idcont,
2713 "_Perl_IDCont", invlist);
2714}
2715
2716bool
f2645549 2717Perl__is_utf8_idcont(pTHX_ const U8 *p)
82686b01 2718{
f2645549 2719 PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
7918f24d 2720
f25ce844 2721 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
a0ed51b3
LW
2722}
2723
2724bool
f2645549 2725Perl__is_utf8_xidcont(pTHX_ const U8 *p)
c11ff943 2726{
f2645549 2727 PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
c11ff943 2728
f25ce844 2729 return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
c11ff943
KW
2730}
2731
2732bool
7dbf68d2
KW
2733Perl__is_utf8_mark(pTHX_ const U8 *p)
2734{
7dbf68d2
KW
2735 PERL_ARGS_ASSERT__IS_UTF8_MARK;
2736
f25ce844 2737 return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
7dbf68d2
KW
2738}
2739
6b5c0936 2740/*
87cea99e 2741=for apidoc to_utf8_case
6b5c0936 2742
a239b1e2
KW
2743Instead use the appropriate one of L</toUPPER_utf8_safe>,
2744L</toTITLE_utf8_safe>,
2745L</toLOWER_utf8_safe>,
2746or L</toFOLD_utf8_safe>.
9da1e7cb 2747
45de9c41
KW
2748This function will be removed in Perl v5.28.
2749
6fae5207 2750C<p> contains the pointer to the UTF-8 string encoding
a1433954
KW
2751the character that is being converted. This routine assumes that the character
2752at C<p> is well-formed.
6b5c0936 2753
6fae5207
KW
2754C<ustrp> is a pointer to the character buffer to put the
2755conversion result to. C<lenp> is a pointer to the length
6b5c0936
JH
2756of the result.
2757
6fae5207 2758C<swashp> is a pointer to the swash to use.
6b5c0936 2759
a1433954 2760Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
796b6530 2761and loaded by C<SWASHNEW>, using F<lib/utf8_heavy.pl>. C<special> (usually,
0134edef 2762but not always, a multicharacter mapping), is tried first.
6b5c0936 2763
4a8240a3
KW
2764C<special> is a string, normally C<NULL> or C<"">. C<NULL> means to not use
2765any special mappings; C<""> means to use the special mappings. Values other
2766than these two are treated as the name of the hash containing the special
2767mappings, like C<"utf8::ToSpecLower">.
6b5c0936 2768
796b6530
KW
2769C<normal> is a string like C<"ToLower"> which means the swash
2770C<%utf8::ToLower>.
0134edef 2771
760c7c2f
KW
2772Code points above the platform's C<IV_MAX> will raise a deprecation warning,
2773unless those are turned off.
2774
0134edef 2775=cut */
6b5c0936 2776
2104c8d9 2777UV
9a957fbc
AL
2778Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
2779 SV **swashp, const char *normal, const char *special)
a0ed51b3 2780{
45de9c41
KW
2781 STRLEN len_cp;
2782 UV cp;
2783 const U8 * e = p + UTF8SKIP(p);
2784
b9992569
KW
2785 PERL_ARGS_ASSERT_TO_UTF8_CASE;
2786
45de9c41
KW
2787 cp = utf8n_to_uvchr(p, e - p, &len_cp, UTF8_CHECK_ONLY);
2788 if (len_cp == (STRLEN) -1) {
2789 _force_out_malformed_utf8_message(p, e,
2790 _UTF8_NO_CONFIDENCE_IN_CURLEN, 1 /* Die */ );
2791 }
2792
2793 return _to_utf8_case(cp, p, ustrp, lenp, swashp, normal, special);
b9992569
KW
2794}
2795
2796 /* change namve uv1 to 'from' */
6a4a25f4 2797STATIC UV
b9992569
KW
2798S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
2799 SV **swashp, const char *normal, const char *special)
2800{
0134edef 2801 STRLEN len = 0;
7918f24d 2802
b9992569 2803 PERL_ARGS_ASSERT__TO_UTF8_CASE;
7918f24d 2804
36eaa811
KW
2805 /* For code points that don't change case, we already know that the output
2806 * of this function is the unchanged input, so we can skip doing look-ups
2807 * for them. Unfortunately the case-changing code points are scattered
2808 * around. But there are some long consecutive ranges where there are no
2809 * case changing code points. By adding tests, we can eliminate the lookup
2810 * for all the ones in such ranges. This is currently done here only for
2811 * just a few cases where the scripts are in common use in modern commerce
2812 * (and scripts adjacent to those which can be included without additional
2813 * tests). */
2814
2815 if (uv1 >= 0x0590) {
2816 /* This keeps from needing further processing the code points most
2817 * likely to be used in the following non-cased scripts: Hebrew,
2818 * Arabic, Syriac, Thaana, NKo, Samaritan, Mandaic, Devanagari,
2819 * Bengali, Gurmukhi, Gujarati, Oriya, Tamil, Telugu, Kannada,
2820 * Malayalam, Sinhala, Thai, Lao, Tibetan, Myanmar */
2821 if (uv1 < 0x10A0) {
2822 goto cases_to_self;
2823 }
2824
2825 /* The following largish code point ranges also don't have case
2826 * changes, but khw didn't think they warranted extra tests to speed
2827 * them up (which would slightly slow down everything else above them):
2828 * 1100..139F Hangul Jamo, Ethiopic
2829 * 1400..1CFF Unified Canadian Aboriginal Syllabics, Ogham, Runic,
2830 * Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Mongolian,
2831 * Limbu, Tai Le, New Tai Lue, Buginese, Tai Tham,
2832 * Combining Diacritical Marks Extended, Balinese,
2833 * Sundanese, Batak, Lepcha, Ol Chiki
2834 * 2000..206F General Punctuation
2835 */
2836
2837 if (uv1 >= 0x2D30) {
2838
2839 /* This keeps the from needing further processing the code points
2840 * most likely to be used in the following non-cased major scripts:
2841 * CJK, Katakana, Hiragana, plus some less-likely scripts.
2842 *
2843 * (0x2D30 above might have to be changed to 2F00 in the unlikely
2844 * event that Unicode eventually allocates the unused block as of
2845 * v8.0 2FE0..2FEF to code points that are cased. khw has verified
2846 * that the test suite will start having failures to alert you
2847 * should that happen) */
2848 if (uv1 < 0xA640) {
2849 goto cases_to_self;
2850 }
2851
2852 if (uv1 >= 0xAC00) {
2853 if (UNLIKELY(UNICODE_IS_SURROGATE(uv1))) {
5af9bc97
KW
2854 if (ckWARN_d(WARN_SURROGATE)) {
2855 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2856 Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
147e3846 2857 "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04" UVXf, desc, uv1);
5af9bc97
KW
2858 }
2859 goto cases_to_self;
2860 }
36eaa811
KW
2861
2862 /* AC00..FAFF Catches Hangul syllables and private use, plus
2863 * some others */
2864 if (uv1 < 0xFB00) {
2865 goto cases_to_self;
2866
2867 }
2868
5af9bc97
KW
2869 if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
2870 if ( UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)
2871 && ckWARN_d(WARN_DEPRECATED))
2872 {
2873 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2874 cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP);
2875 }
2876 if (ckWARN_d(WARN_NON_UNICODE)) {
2877 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2878 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
147e3846 2879 "Operation \"%s\" returns its argument for non-Unicode code point 0x%04" UVXf, desc, uv1);
5af9bc97
KW
2880 }
2881 goto cases_to_self;
2882 }
3bfc1e70
KW
2883#ifdef HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C
2884 if (UNLIKELY(uv1
2885 > HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C))
2886 {
2887
2888 /* As of this writing, this means we avoid swash creation
2889 * for anything beyond low Plane 1 */
2890 goto cases_to_self;
2891 }
2892#endif
36eaa811
KW
2893 }
2894 }
9ae3ac1a 2895
36eaa811
KW
2896 /* Note that non-characters are perfectly legal, so no warning should
2897 * be given. There are so few of them, that it isn't worth the extra
2898 * tests to avoid swash creation */
9ae3ac1a
KW
2899 }
2900
0134edef 2901 if (!*swashp) /* load on-demand */
5ab9d2ef 2902 *swashp = _core_swash_init("utf8", normal, &PL_sv_undef, 4, 0, NULL, NULL);
0134edef 2903
a6f87d8c 2904 if (special) {
0134edef 2905 /* It might be "special" (sometimes, but not always,
2a37f04d 2906 * a multicharacter mapping) */
4a8240a3 2907 HV *hv = NULL;
b08cf34e
JH
2908 SV **svp;
2909
4a8240a3
KW
2910 /* If passed in the specials name, use that; otherwise use any
2911 * given in the swash */
2912 if (*special != '\0') {
2913 hv = get_hv(special, 0);
2914 }
2915 else {
2916 svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0);
2917 if (svp) {
2918 hv = MUTABLE_HV(SvRV(*svp));
2919 }
2920 }
2921
176fe009 2922 if (hv
5f560d8a 2923 && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
176fe009
KW
2924 && (*svp))
2925 {
cfd0369c 2926 const char *s;
47654450 2927
cfd0369c 2928 s = SvPV_const(*svp, len);
47654450 2929 if (len == 1)
f4cd282c 2930 /* EIGHTBIT */
c80e42f3 2931 len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp;
2a37f04d 2932 else {
d2dcd0fb 2933 Copy(s, ustrp, len, U8);
29e98929 2934 }
983ffd37 2935 }
0134edef
JH
2936 }
2937
2938 if (!len && *swashp) {
4a4088c4 2939 const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
d4c19fe8 2940
0134edef
JH
2941 if (uv2) {
2942 /* It was "normal" (a single character mapping). */
f4cd282c 2943 len = uvchr_to_utf8(ustrp, uv2) - ustrp;
2a37f04d
JH
2944 }
2945 }
1feea2c7 2946
cbe07460
KW
2947 if (len) {
2948 if (lenp) {
2949 *lenp = len;
2950 }
2951 return valid_utf8_to_uvchr(ustrp, 0);
2952 }
2953
2954 /* Here, there was no mapping defined, which means that the code point maps
2955 * to itself. Return the inputs */
e24dfe9c 2956 cases_to_self:
bfdf22ec 2957 len = UTF8SKIP(p);
ca9fab46
KW
2958 if (p != ustrp) { /* Don't copy onto itself */
2959 Copy(p, ustrp, len, U8);
2960 }
0134edef 2961
2a37f04d
JH
2962 if (lenp)
2963 *lenp = len;
2964
f4cd282c 2965 return uv1;
cbe07460 2966
a0ed51b3
LW
2967}
2968
051a06d4 2969STATIC UV
357aadde 2970S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
051a06d4 2971{
4a4088c4 2972 /* This is called when changing the case of a UTF-8-encoded character above
31f05a37
KW
2973 * the Latin1 range, and the operation is in a non-UTF-8 locale. If the
2974 * result contains a character that crosses the 255/256 boundary, disallow
2975 * the change, and return the original code point. See L<perlfunc/lc> for
2976 * why;
051a06d4 2977 *
a1433954
KW
2978 * p points to the original string whose case was changed; assumed
2979 * by this routine to be well-formed
051a06d4
KW
2980 * result the code point of the first character in the changed-case string
2981 * ustrp points to the changed-case string (<result> represents its first char)
2982 * lenp points to the length of <ustrp> */
2983
2984 UV original; /* To store the first code point of <p> */
2985
2986 PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
2987
a4f12ed7 2988 assert(UTF8_IS_ABOVE_LATIN1(*p));
051a06d4
KW
2989
2990 /* We know immediately if the first character in the string crosses the
2991 * boundary, so can skip */
2992 if (result > 255) {
2993
2994 /* Look at every character in the result; if any cross the
2995 * boundary, the whole thing is disallowed */
2996 U8* s = ustrp + UTF8SKIP(ustrp);
2997 U8* e = ustrp + *lenp;
2998 while (s < e) {
a4f12ed7 2999 if (! UTF8_IS_ABOVE_LATIN1(*s)) {
051a06d4
KW
3000 goto bad_crossing;
3001 }
3002 s += UTF8SKIP(s);
3003 }
3004
613abc6d
KW
3005 /* Here, no characters crossed, result is ok as-is, but we warn. */
3006 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p));
051a06d4
KW
3007 return result;
3008 }
3009
7b52d656 3010 bad_crossing:
051a06d4
KW
3011
3012 /* Failed, have to return the original */
4b88fb76 3013 original = valid_utf8_to_uvchr(p, lenp);
ab0b796c
KW
3014
3015 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3016 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
147e3846
KW
3017 "Can't do %s(\"\\x{%" UVXf "}\") on non-UTF-8 locale; "
3018 "resolved to \"\\x{%" UVXf "}\".",
357aadde 3019 OP_DESC(PL_op),
ab0b796c
KW
3020 original,
3021 original);
051a06d4
KW
3022 Copy(p, ustrp, *lenp, char);
3023 return original;
3024}
3025
607313a1
KW
3026STATIC U32
3027S_check_and_deprecate(pTHX_ const U8 *p,
3028 const U8 **e,
3029 const unsigned int type, /* See below */
3030 const bool use_locale, /* Is this a 'LC_'
3031 macro call? */
3032 const char * const file,
3033 const unsigned line)
3034{
3035 /* This is a temporary function to deprecate the unsafe calls to the case
3036 * changing macros and functions. It keeps all the special stuff in just
3037 * one place.
3038 *
3039 * It updates *e with the pointer to the end of the input string. If using
3040 * the old-style macros, *e is NULL on input, and so this function assumes
3041 * the input string is long enough to hold the entire UTF-8 sequence, and
3042 * sets *e accordingly, but it then returns a flag to pass the
3043 * utf8n_to_uvchr(), to tell it that this size is a guess, and to avoid
3044 * using the full length if possible.
3045 *
3046 * It also does the assert that *e > p when *e is not NULL. This should be
3047 * migrated to the callers when this function gets deleted.
3048 *
3049 * The 'type' parameter is used for the caller to specify which case
3050 * changing function this is called from: */
3051
3052# define DEPRECATE_TO_UPPER 0
3053# define DEPRECATE_TO_TITLE 1
3054# define DEPRECATE_TO_LOWER 2
3055# define DEPRECATE_TO_FOLD 3
3056
3057 U32 utf8n_flags = 0;
3058 const char * name;
3059 const char * alternative;
3060
3061 PERL_ARGS_ASSERT_CHECK_AND_DEPRECATE;
3062
3063 if (*e == NULL) {
3064 utf8n_flags = _UTF8_NO_CONFIDENCE_IN_CURLEN;
3065 *e = p + UTF8SKIP(p);
3066
3067 /* For mathoms.c calls, we use the function name we know is stored
c44e9413 3068 * there. It could be part of a larger path */
607313a1 3069 if (type == DEPRECATE_TO_UPPER) {
c44e9413 3070 name = instr(file, "mathoms.c")
607313a1
KW
3071 ? "to_utf8_upper"
3072 : "toUPPER_utf8";
3073 alternative = "toUPPER_utf8_safe";
3074 }
3075 else if (type == DEPRECATE_TO_TITLE) {
c44e9413 3076 name = instr(file, "mathoms.c")
607313a1
KW
3077 ? "to_utf8_title"
3078 : "toTITLE_utf8";
3079 alternative = "toTITLE_utf8_safe";
3080 }
3081 else if (type == DEPRECATE_TO_LOWER) {
c44e9413 3082 name = instr(file, "mathoms.c")
607313a1
KW
3083 ? "to_utf8_lower"
3084 : "toLOWER_utf8";
3085 alternative = "toLOWER_utf8_safe";
3086 }
3087 else if (type == DEPRECATE_TO_FOLD) {
c44e9413 3088 name = instr(file, "mathoms.c")
607313a1
KW
3089 ? "to_utf8_fold"
3090 : "toFOLD_utf8";
3091 alternative = "toFOLD_utf8_safe";
3092 }
3093 else Perl_croak(aTHX_ "panic: Unexpected case change type");
3094
3095 warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
3096 }
3097 else {
3098 assert (p < *e);
3099 }
3100
3101 return utf8n_flags;
3102}
3103
eaf412bf
KW
3104/* The process for changing the case is essentially the same for the four case
3105 * change types, except there are complications for folding. Otherwise the
3106 * difference is only which case to change to. To make sure that they all do
3107 * the same thing, the bodies of the functions are extracted out into the
3108 * following two macros. The functions are written with the same variable
3109 * names, and these are known and used inside these macros. It would be
3110 * better, of course, to have inline functions to do it, but since different
3111 * macros are called, depending on which case is being changed to, this is not
3112 * feasible in C (to khw's knowledge). Two macros are created so that the fold
3113 * function can start with the common start macro, then finish with its special
3114 * handling; while the other three cases can just use the common end macro.
3115 *
3116 * The algorithm is to use the proper (passed in) macro or function to change
3117 * the case for code points that are below 256. The macro is used if using
3118 * locale rules for the case change; the function if not. If the code point is
3119 * above 255, it is computed from the input UTF-8, and another macro is called
3120 * to do the conversion. If necessary, the output is converted to UTF-8. If
3121 * using a locale, we have to check that the change did not cross the 255/256
3122 * boundary, see check_locale_boundary_crossing() for further details.
3123 *
3124 * The macros are split with the correct case change for the below-256 case
3125 * stored into 'result', and in the middle of an else clause for the above-255
3126 * case. At that point in the 'else', 'result' is not the final result, but is
3127 * the input code point calculated from the UTF-8. The fold code needs to
3128 * realize all this and take it from there.
3129 *
3130 * If you read the two macros as sequential, it's easier to understand what's
3131 * going on. */
3132#define CASE_CHANGE_BODY_START(locale_flags, LC_L1_change_macro, L1_func, \
3133 L1_func_extra_param) \
a239b1e2 3134 \
eaf412bf
KW
3135 if (flags & (locale_flags)) { \
3136 /* Treat a UTF-8 locale as not being in locale at all */ \
3137 if (IN_UTF8_CTYPE_LOCALE) { \
3138 flags &= ~(locale_flags); \
3139 } \
3140 else { \
3141 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
3142 } \
3143 } \
3144 \
3145 if (UTF8_IS_INVARIANT(*p)) { \
3146 if (flags & (locale_flags)) { \
3147 result = LC_L1_change_macro(*p); \
3148 } \
3149 else { \
3150 return L1_func(*p, ustrp, lenp, L1_func_extra_param); \
3151 } \
3152 } \
a239b1e2 3153 else if UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e) { \
eaf412bf
KW
3154 if (flags & (locale_flags)) { \
3155 result = LC_L1_change_macro(EIGHT_BIT_UTF8_TO_NATIVE(*p, \
3156 *(p+1))); \
3157 } \
3158 else { \
3159 return L1_func(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)), \
3160 ustrp, lenp, L1_func_extra_param); \
3161 } \
3162 } \
fa8ab374
KW
3163 else { /* malformed UTF-8 or ord above 255 */ \
3164 STRLEN len_result; \
fa8ab374
KW
3165 result = utf8n_to_uvchr(p, e - p, &len_result, UTF8_CHECK_ONLY); \
3166 if (len_result == (STRLEN) -1) { \
607313a1
KW
3167 _force_out_malformed_utf8_message(p, e, utf8n_flags, \
3168 1 /* Die */ ); \
fa8ab374 3169 }
eaf412bf
KW
3170
3171#define CASE_CHANGE_BODY_END(locale_flags, change_macro) \
3172 result = change_macro(result, p, ustrp, lenp); \
3173 \
3174 if (flags & (locale_flags)) { \
3175 result = check_locale_boundary_crossing(p, result, ustrp, lenp); \
3176 } \
3177 return result; \
3178 } \
3179 \
3180 /* Here, used locale rules. Convert back to UTF-8 */ \
3181 if (UTF8_IS_INVARIANT(result)) { \
3182 *ustrp = (U8) result; \
3183 *lenp = 1; \
3184 } \
3185 else { \
3186 *ustrp = UTF8_EIGHT_BIT_HI((U8) result); \
3187 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); \
3188 *lenp = 2; \
3189 } \
3190 \
3191 return result;
3192
d3e79532 3193/*
87cea99e 3194=for apidoc to_utf8_upper
d3e79532 3195
a239b1e2 3196Instead use L</toUPPER_utf8_safe>.
a1433954 3197
d3e79532
JH
3198=cut */
3199
051a06d4 3200/* Not currently externally documented, and subject to change:
31f05a37
KW
3201 * <flags> is set iff iff the rules from the current underlying locale are to
3202 * be used. */
051a06d4 3203
2104c8d9 3204UV
607313a1
KW
3205Perl__to_utf8_upper_flags(pTHX_ const U8 *p,
3206 const U8 *e,
3207 U8* ustrp,
3208 STRLEN *lenp,
3209 bool flags,
3210 const char * const file,
3211 const int line)
a0ed51b3 3212{
051a06d4 3213 UV result;
607313a1
KW
3214 const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_UPPER,
3215 cBOOL(flags), file, line);
051a06d4
KW
3216
3217 PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
7918f24d 3218
eaf412bf
KW
3219 /* ~0 makes anything non-zero in 'flags' mean we are using locale rules */
3220 /* 2nd char of uc(U+DF) is 'S' */
3221 CASE_CHANGE_BODY_START(~0, toUPPER_LC, _to_upper_title_latin1, 'S');
3222 CASE_CHANGE_BODY_END (~0, CALL_UPPER_CASE);
983ffd37 3223}
a0ed51b3 3224
d3e79532 3225/*
87cea99e 3226=for apidoc to_utf8_title
d3e79532 3227
a239b1e2 3228Instead use L</toTITLE_utf8_safe>.
a1433954 3229
d3e79532
JH
3230=cut */
3231
051a06d4 3232/* Not currently externally documented, and subject to change:
31f05a37
KW
3233 * <flags> is set iff the rules from the current underlying locale are to be
3234 * used. Since titlecase is not defined in POSIX, for other than a
3235 * UTF-8 locale, uppercase is used instead for code points < 256.
445bf929 3236 */
051a06d4 3237
983ffd37 3238UV
607313a1
KW
3239Perl__to_utf8_title_flags(pTHX_ const U8 *p,
3240 const U8 *e,
3241 U8* ustrp,
3242 STRLEN *lenp,
3243 bool flags,
3244 const char * const file,
3245 const int line)
983ffd37 3246{
051a06d4 3247 UV result;
607313a1
KW
3248 const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_TITLE,
3249 cBOOL(flags), file, line);
051a06d4
KW
3250
3251 PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
7918f24d 3252
eaf412bf
KW
3253 /* 2nd char of ucfirst(U+DF) is 's' */
3254 CASE_CHANGE_BODY_START(~0, toUPPER_LC, _to_upper_title_latin1, 's');
3255 CASE_CHANGE_BODY_END (~0, CALL_TITLE_CASE);
a0ed51b3
LW
3256}
3257
d3e79532 3258/*
87cea99e 3259=for apidoc to_utf8_lower
d3e79532 3260
a239b1e2 3261Instead use L</toLOWER_utf8_safe>.
a1433954 3262
d3e79532
JH
3263=cut */
3264
051a06d4 3265/* Not currently externally documented, and subject to change:
31f05a37
KW
3266 * <flags> is set iff iff the rules from the current underlying locale are to
3267 * be used.
3268 */
051a06d4 3269
2104c8d9 3270UV
607313a1
KW
3271Perl__to_utf8_lower_flags(pTHX_ const U8 *p,
3272 const U8 *e,
3273 U8* ustrp,
3274 STRLEN *lenp,
3275 bool flags,
3276 const char * const file,
3277 const int line)
a0ed51b3 3278{
051a06d4 3279 UV result;
607313a1
KW
3280 const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_LOWER,
3281 cBOOL(flags), file, line);
051a06d4 3282
051a06d4 3283 PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
7918f24d 3284
eaf412bf
KW
3285 CASE_CHANGE_BODY_START(~0, toLOWER_LC, to_lower_latin1, 0 /* 0 is dummy */)
3286 CASE_CHANGE_BODY_END (~0, CALL_LOWER_CASE)
b4e400f9
JH
3287}
3288
d3e79532 3289/*
87cea99e 3290=for apidoc to_utf8_fold
d3e79532 3291
a239b1e2 3292Instead use L</toFOLD_utf8_safe>.
a1433954 3293
d3e79532
JH
3294=cut */
3295
051a06d4
KW
3296/* Not currently externally documented, and subject to change,
3297 * in <flags>
31f05a37
KW
3298 * bit FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
3299 * locale are to be used.
051a06d4
KW
3300 * bit FOLD_FLAGS_FULL is set iff full case folds are to be used;
3301 * otherwise simple folds
a0270393
KW
3302 * bit FOLD_FLAGS_NOMIX_ASCII is set iff folds of non-ASCII to ASCII are
3303 * prohibited
445bf929 3304 */
36bb2ab6 3305
b4e400f9 3306UV
607313a1
KW
3307Perl__to_utf8_fold_flags(pTHX_ const U8 *p,
3308 const U8 *e,
3309 U8* ustrp,
3310 STRLEN *lenp,
3311 U8 flags,
3312 const char * const file,
3313 const int line)
b4e400f9 3314{
051a06d4 3315 UV result;
607313a1
KW
3316 const U32 utf8n_flags = check_and_deprecate(p, &e, DEPRECATE_TO_FOLD,
3317 cBOOL(flags), file, line);
051a06d4 3318
36bb2ab6 3319 PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
7918f24d 3320
a0270393
KW
3321 /* These are mutually exclusive */
3322 assert (! ((flags & FOLD_FLAGS_LOCALE) && (flags & FOLD_FLAGS_NOMIX_ASCII)));
3323
50ba90ff
KW
3324 assert(p != ustrp); /* Otherwise overwrites */
3325
eaf412bf
KW
3326 CASE_CHANGE_BODY_START(FOLD_FLAGS_LOCALE, toFOLD_LC, _to_fold_latin1,
3327 ((flags) & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)));
31f05a37 3328
eaf412bf 3329 result = CALL_FOLD_CASE(result, p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
a1dde8de 3330
1ca267a5
KW
3331 if (flags & FOLD_FLAGS_LOCALE) {
3332
76f2ffcd 3333# define LONG_S_T LATIN_SMALL_LIGATURE_LONG_S_T_UTF8
0766489e
KW
3334 const unsigned int long_s_t_len = sizeof(LONG_S_T) - 1;
3335
3336# ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8
3337# define CAP_SHARP_S LATIN_CAPITAL_LETTER_SHARP_S_UTF8
76f2ffcd
KW
3338
3339 const unsigned int cap_sharp_s_len = sizeof(CAP_SHARP_S) - 1;
76f2ffcd 3340
538e84ed
KW
3341 /* Special case these two characters, as what normally gets
3342 * returned under locale doesn't work */
76f2ffcd
KW
3343 if (UTF8SKIP(p) == cap_sharp_s_len
3344 && memEQ((char *) p, CAP_SHARP_S, cap_sharp_s_len))
1ca267a5 3345 {
ab0b796c
KW
3346 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3347 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3348 "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
3349 "resolved to \"\\x{17F}\\x{17F}\".");
1ca267a5
KW
3350 goto return_long_s;
3351 }
0766489e
KW
3352 else
3353#endif
3354 if (UTF8SKIP(p) == long_s_t_len
76f2ffcd 3355 && memEQ((char *) p, LONG_S_T, long_s_t_len))
9fc2026f 3356 {
ab0b796c
KW
3357 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3358 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3359 "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
3360 "resolved to \"\\x{FB06}\".");
9fc2026f
KW
3361 goto return_ligature_st;
3362 }
74894415
KW
3363
3364#if UNICODE_MAJOR_VERSION == 3 \
3365 && UNICODE_DOT_VERSION == 0 \
3366 && UNICODE_DOT_DOT_VERSION == 1
3367# define DOTTED_I LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE_UTF8
3368
3369 /* And special case this on this Unicode version only, for the same
3370 * reaons the other two are special cased. They would cross the
3371 * 255/256 boundary which is forbidden under /l, and so the code
3372 * wouldn't catch that they are equivalent (which they are only in
3373 * this release) */
3374 else if (UTF8SKIP(p) == sizeof(DOTTED_I) - 1
3375 && memEQ((char *) p, DOTTED_I, sizeof(DOTTED_I) - 1))
3376 {
3377 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3378 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
3379 "Can't do fc(\"\\x{0130}\") on non-UTF-8 locale; "
3380 "resolved to \"\\x{0131}\".");
3381 goto return_dotless_i;
3382 }
3383#endif
3384
357aadde 3385 return check_locale_boundary_crossing(p, result, ustrp, lenp);
051a06d4 3386 }
a0270393
KW
3387 else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
3388 return result;
3389 }
3390 else {
4a4088c4 3391 /* This is called when changing the case of a UTF-8-encoded
9fc2026f
KW
3392 * character above the ASCII range, and the result should not
3393 * contain an ASCII character. */
a0270393
KW
3394
3395 UV original; /* To store the first code point of <p> */
3396
3397 /* Look at every character in the result; if any cross the
3398 * boundary, the whole thing is disallowed */
3399 U8* s = ustrp;
3400 U8* e = ustrp + *lenp;
3401 while (s < e) {
3402 if (isASCII(*s)) {
3403 /* Crossed, have to return the original */
3404 original = valid_utf8_to_uvchr(p, lenp);
1ca267a5 3405
9fc2026f 3406 /* But in these instances, there is an alternative we can
1ca267a5 3407 * return that is valid */
0766489e
KW
3408 if (original == LATIN_SMALL_LETTER_SHARP_S
3409#ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
3410 || original == LATIN_CAPITAL_LETTER_SHARP_S
3411#endif
3412 ) {
1ca267a5
KW
3413 goto return_long_s;
3414 }
9fc2026f
KW
3415 else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) {
3416 goto return_ligature_st;
3417 }
74894415
KW
3418#if UNICODE_MAJOR_VERSION == 3 \
3419 && UNICODE_DOT_VERSION == 0 \
3420 && UNICODE_DOT_DOT_VERSION == 1
3421
3422 else if (original == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
3423 goto return_dotless_i;
3424 }
3425#endif
a0270393
KW
3426 Copy(p, ustrp, *lenp, char);
3427 return original;
3428 }
3429 s += UTF8SKIP(s);
3430 }
051a06d4 3431
a0270393
KW
3432 /* Here, no characters crossed, result is ok as-is */
3433 return result;
3434 }
051a06d4
KW
3435 }
3436
4a4088c4 3437 /* Here, used locale rules. Convert back to UTF-8 */
051a06d4
KW
3438 if (UTF8_IS_INVARIANT(result)) {
3439 *ustrp = (U8) result;
3440 *lenp = 1;
3441 }
3442 else {
62cb07ea
KW
3443 *ustrp = UTF8_EIGHT_BIT_HI((U8) result);
3444 *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result);
051a06d4
KW
3445 *lenp = 2;
3446 }
3447
051a06d4 3448 return result;
1ca267a5
KW
3449
3450 return_long_s:
3451 /* Certain folds to 'ss' are prohibited by the options, but they do allow
3452 * folds to a string of two of these characters. By returning this
3453 * instead, then, e.g.,
3454 * fc("\x{1E9E}") eq fc("\x{17F}\x{17F}")
3455 * works. */
3456
3457 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
3458 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
3459 ustrp, *lenp, U8);
3460 return LATIN_SMALL_LETTER_LONG_S;
9fc2026f
KW
3461
3462 return_ligature_st:
3463 /* Two folds to 'st' are prohibited by the options; instead we pick one and
3464 * have the other one fold to it */
3465
3466 *lenp = sizeof(LATIN_SMALL_LIGATURE_ST_UTF8) - 1;
3467 Copy(LATIN_SMALL_LIGATURE_ST_UTF8, ustrp, *lenp, U8);
3468 return LATIN_SMALL_LIGATURE_ST;
74894415
KW
3469
3470#if UNICODE_MAJOR_VERSION == 3 \
3471 && UNICODE_DOT_VERSION == 0 \
3472 && UNICODE_DOT_DOT_VERSION == 1
3473
3474 return_dotless_i:
3475 *lenp = sizeof(LATIN_SMALL_LETTER_DOTLESS_I_UTF8) - 1;
3476 Copy(LATIN_SMALL_LETTER_DOTLESS_I_UTF8, ustrp, *lenp, U8);
3477 return LATIN_SMALL_LETTER_DOTLESS_I;
3478
3479#endif
3480
a0ed51b3
LW
3481}
3482
711a919c 3483/* Note:
f90a9a02 3484 * Returns a "swash" which is a hash described in utf8.c:Perl_swash_fetch().
711a919c
ST
3485 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
3486 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
3487 */
c4a5db0c 3488
a0ed51b3 3489SV*
7fc63493 3490Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
a0ed51b3 3491{
c4a5db0c
KW
3492 PERL_ARGS_ASSERT_SWASH_INIT;
3493
3494 /* Returns a copy of a swash initiated by the called function. This is the
3495 * public interface, and returning a copy prevents others from doing
3496 * mischief on the original */
3497
5d3d13d1 3498 return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, NULL, NULL));
c4a5db0c
KW
3499}
3500
3501SV*
5d3d13d1 3502Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
c4a5db0c 3503{
2c1f00b9
YO
3504
3505 /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
3506 * use the following define */
3507
3508#define CORE_SWASH_INIT_RETURN(x) \
3509 PL_curpm= old_PL_curpm; \
3510 return x
3511
c4a5db0c 3512 /* Initialize and return a swash, creating it if necessary. It does this
87367d5f
KW
3513 * by calling utf8_heavy.pl in the general case. The returned value may be
3514 * the swash's inversion list instead if the input parameters allow it.
3515 * Which is returned should be immaterial to callers, as the only
923b6d4e
KW
3516 * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
3517 * and swash_to_invlist() handle both these transparently.
c4a5db0c
KW
3518 *
3519 * This interface should only be used by functions that won't destroy or
3520 * adversely change the swash, as doing so affects all other uses of the
3521 * swash in the program; the general public should use 'Perl_swash_init'
3522 * instead.
3523 *
3524 * pkg is the name of the package that <name> should be in.
3525 * name is the name of the swash to find. Typically it is a Unicode
3526 * property name, including user-defined ones
3527 * listsv is a string to initialize the swash with. It must be of the form
3528 * documented as the subroutine return value in
3529 * L<perlunicode/User-Defined Character Properties>
3530 * minbits is the number of bits required to represent each data element.
3531 * It is '1' for binary properties.
3532 * none I (khw) do not understand this one, but it is used only in tr///.
9a53f6cf 3533 * invlist is an inversion list to initialize the swash with (or NULL)
83199d38
KW
3534 * flags_p if non-NULL is the address of various input and output flag bits
3535 * to the routine, as follows: ('I' means is input to the routine;
3536 * 'O' means output from the routine. Only flags marked O are
3537 * meaningful on return.)
3538 * _CORE_SWASH_INIT_USER_DEFINED_PROPERTY indicates if the swash
3539 * came from a user-defined property. (I O)
5d3d13d1
KW
3540 * _CORE_SWASH_INIT_RETURN_IF_UNDEF indicates that instead of croaking
3541 * when the swash cannot be located, to simply return NULL. (I)
87367d5f
KW
3542 * _CORE_SWASH_INIT_ACCEPT_INVLIST indicates that the caller will accept a
3543 * return of an inversion list instead of a swash hash if this routine
3544 * thinks that would result in faster execution of swash_fetch() later
3545 * on. (I)
9a53f6cf
KW
3546 *
3547 * Thus there are three possible inputs to find the swash: <name>,
3548 * <listsv>, and <invlist>. At least one must be specified. The result
3549 * will be the union of the specified ones, although <listsv>'s various
aabbdbda
KW
3550 * actions can intersect, etc. what <name> gives. To avoid going out to
3551 * disk at all, <invlist> should specify completely what the swash should
3552 * have, and <listsv> should be &PL_sv_undef and <name> should be "".
9a53f6cf
KW
3553 *
3554 * <invlist> is only valid for binary properties */
c4a5db0c 3555
2c1f00b9
YO
3556 PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
3557
c4a5db0c 3558 SV* retval = &PL_sv_undef;
83199d38 3559 HV* swash_hv = NULL;
87367d5f
KW
3560 const int invlist_swash_boundary =
3561 (flags_p && *flags_p & _CORE_SWASH_INIT_ACCEPT_INVLIST)
3562 ? 512 /* Based on some benchmarking, but not extensive, see commit
3563 message */
3564 : -1; /* Never return just an inversion list */
9a53f6cf
KW
3565
3566 assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
3567 assert(! invlist || minbits == 1);
3568
2c1f00b9
YO
3569 PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
3570 that triggered the swash init and the swash init perl logic itself.
3571 See perl #122747 */
3572
9a53f6cf
KW
3573 /* If data was passed in to go out to utf8_heavy to find the swash of, do
3574 * so */
3575 if (listsv != &PL_sv_undef || strNE(name, "")) {
69794297
KW
3576 dSP;
3577 const size_t pkg_len = strlen(pkg);
3578 const size_t name_len = strlen(name);
3579 HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
3580 SV* errsv_save;
3581 GV *method;
3582
3583 PERL_ARGS_ASSERT__CORE_SWASH_INIT;
3584
3585 PUSHSTACKi(PERLSI_MAGIC);
ce3b816e 3586 ENTER;
69794297 3587 SAVEHINTS();
2782061f 3588 save_re_context();
650f067c
JL
3589 /* We might get here via a subroutine signature which uses a utf8
3590 * parameter name, at which point PL_subname will have been set
3591 * but not yet used. */
3592 save_item(PL_subname);
69794297
KW
3593 if (PL_parser && PL_parser->error_count)
3594 SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
3595 method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
4a4088c4 3596 if (!method) { /* demand load UTF-8 */
69794297 3597 ENTER;
db2c6cb3
FC
3598 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
3599 GvSV(PL_errgv) = NULL;
1a419e6b 3600#ifndef NO_TAINT_SUPPORT
69794297
KW
3601 /* It is assumed that callers of this routine are not passing in
3602 * any user derived data. */
2782061f
DM
3603 /* Need to do this after save_re_context() as it will set
3604 * PL_tainted to 1 while saving $1 etc (see the code after getrx:
3605 * in Perl_magic_get). Even line to create errsv_save can turn on
3606 * PL_tainted. */
284167a5
SM
3607 SAVEBOOL(TAINT_get);
3608 TAINT_NOT;
3609#endif
69794297
KW
3610 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
3611 NULL);
eed484f9 3612 {
db2c6cb3
FC
3613 /* Not ERRSV, as there is no need to vivify a scalar we are
3614 about to discard. */
3615 SV * const errsv = GvSV(PL_errgv);
3616 if (!SvTRUE(errsv)) {
3617 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
3618 SvREFCNT_dec(errsv);
3619 }
eed484f9 3620 }
69794297
KW
3621 LEAVE;
3622 }
3623 SPAGAIN;
3624 PUSHMARK(SP);
3625 EXTEND(SP,5);
3626 mPUSHp(pkg, pkg_len);
3627 mPUSHp(name, name_len);
3628 PUSHs(listsv);
3629 mPUSHi(minbits);
3630 mPUSHi(none);
3631 PUTBACK;
db2c6cb3
FC
3632 if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
3633 GvSV(PL_errgv) = NULL;
69794297
KW
3634 /* If we already have a pointer to the method, no need to use
3635 * call_method() to repeat the lookup. */
c41800a8
KW
3636 if (method
3637 ? call_sv(MUTABLE_SV(method), G_SCALAR)
69794297
KW
3638 : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
3639 {
3640 retval = *PL_stack_sp--;
3641 SvREFCNT_inc(retval);
3642 }
eed484f9 3643 {
db2c6cb3
FC
3644 /* Not ERRSV. See above. */
3645 SV * const errsv = GvSV(PL_errgv);
3646 if (!SvTRUE(errsv)) {
3647 GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
3648 SvREFCNT_dec(errsv);
3649 }
eed484f9 3650 }
ce3b816e 3651 LEAVE;
69794297
KW
3652 POPSTACK;
3653 if (IN_PERL_COMPILETIME) {
3654 CopHINTS_set(PL_curcop, PL_hints);
3655 }
3656 if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
d95e4a00 3657 if (SvPOK(retval)) {
69794297
KW
3658
3659 /* If caller wants to handle missing properties, let them */
5d3d13d1 3660 if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
2c1f00b9 3661 CORE_SWASH_INIT_RETURN(NULL);
69794297
KW
3662 }
3663 Perl_croak(aTHX_
147e3846 3664 "Can't find Unicode property definition \"%" SVf "\"",
69794297 3665 SVfARG(retval));
a25b5927 3666 NOT_REACHED; /* NOTREACHED */
d95e4a00 3667 }
69794297 3668 }
9a53f6cf 3669 } /* End of calling the module to find the swash */
36eb48b4 3670
83199d38
KW
3671 /* If this operation fetched a swash, and we will need it later, get it */
3672 if (retval != &PL_sv_undef
3673 && (minbits == 1 || (flags_p
3674 && ! (*flags_p
3675 & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY))))
3676 {
3677 swash_hv = MUTABLE_HV(SvRV(retval));
3678
3679 /* If we don't already know that there is a user-defined component to
3680 * this swash, and the user has indicated they wish to know if there is
3681 * one (by passing <flags_p>), find out */
3682 if (flags_p && ! (*flags_p & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)) {
3683 SV** user_defined = hv_fetchs(swash_hv, "USER_DEFINED", FALSE);
3684 if (user_defined && SvUV(*user_defined)) {
3685 *flags_p |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
3686 }
3687 }
3688 }
3689
36eb48b4
KW
3690 /* Make sure there is an inversion list for binary properties */
3691 if (minbits == 1) {
3692 SV** swash_invlistsvp = NULL;
3693 SV* swash_invlist = NULL;
9a53f6cf 3694 bool invlist_in_swash_is_valid = FALSE;
02c85471
FC
3695 bool swash_invlist_unclaimed = FALSE; /* whether swash_invlist has
3696 an unclaimed reference count */
36eb48b4 3697
9a53f6cf 3698 /* If this operation fetched a swash, get its already existing
83199d38 3699 * inversion list, or create one for it */
36eb48b4 3700
83199d38 3701 if (swash_hv) {
5c9f4bd2 3702 swash_invlistsvp = hv_fetchs(swash_hv, "V", FALSE);
9a53f6cf
KW
3703 if (swash_invlistsvp) {
3704 swash_invlist = *swash_invlistsvp;
3705 invlist_in_swash_is_valid = TRUE;
3706 }
3707 else {
36eb48b4 3708 swash_invlist = _swash_to_invlist(retval);
02c85471 3709 swash_invlist_unclaimed = TRUE;
9a53f6cf
KW
3710 }
3711 }
3712
3713 /* If an inversion list was passed in, have to include it */
3714 if (invlist) {
3715
3716 /* Any fetched swash will by now have an inversion list in it;
3717 * otherwise <swash_invlist> will be NULL, indicating that we
3718 * didn't fetch a swash */
3719 if (swash_invlist) {
3720
3721 /* Add the passed-in inversion list, which invalidates the one
3722 * already stored in the swash */
3723 invlist_in_swash_is_valid = FALSE;
eee4c920 3724 SvREADONLY_off(swash_invlist); /* Turned on again below */
9a53f6cf
KW
3725 _invlist_union(invlist, swash_invlist, &swash_invlist);
3726 }
3727 else {
3728
87367d5f
KW
3729 /* Here, there is no swash already. Set up a minimal one, if
3730 * we are going to return a swash */
3731 if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
971d486f 3732 swash_hv = newHV();
4aca0fe6 3733 retval = newRV_noinc(MUTABLE_SV(swash_hv));
87367d5f 3734 }
9a53f6cf
KW
3735 swash_invlist = invlist;