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