This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
locale.c: Rmv unnecessary locale toggle
[perl5.git] / utf8.c
CommitLineData
a0ed51b3
LW
1/* utf8.c
2 *
1129b882 3 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
b94e2f88 4 * by Larry Wall and others
a0ed51b3
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
4ac71550
TC
12 * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
13 * heard of that we don't want to see any closer; and that's the one place
14 * we're trying to get to! And that's just where we can't get, nohow.'
15 *
cdad3b53 16 * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
a0ed51b3
LW
17 *
18 * 'Well do I understand your speech,' he answered in the same language;
19 * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
4ac71550 20 * as is the custom in the West, if you wish to be answered?'
cdad3b53 21 * --Gandalf, addressing Théoden's door wardens
4ac71550
TC
22 *
23 * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
24 *
25 * ...the travellers perceived that the floor was paved with stones of many
26 * hues; branching runes and strange devices intertwined beneath their feet.
4ac71550
TC
27 *
28 * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
a0ed51b3
LW
29 */
30
31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_UTF8_C
a0ed51b3 33#include "perl.h"
b992490d 34#include "invlist_inline.h"
a0ed51b3 35
806547a7 36static const char malformed_text[] = "Malformed UTF-8 character";
27da23d5 37static const char unees[] =
806547a7 38 "Malformed UTF-8 character (unexpected end of string)";
760c7c2f 39static const char cp_above_legal_max[] =
d22ec717
KW
40 "Use of code point 0x%" UVXf " is not allowed; the"
41 " permissible max is 0x%" UVXf;
760c7c2f 42
d22ec717 43#define MAX_EXTERNALLY_LEGAL_CP ((UV) (IV_MAX))
901b21bf 44
48ef279e 45/*
ccfc67b7 46=head1 Unicode Support
7fefc6c1 47These are various utility functions for manipulating UTF8-encoded
72d33970 48strings. For the uninitiated, this is a method of representing arbitrary
61296642 49Unicode characters as a variable number of bytes, in such a way that
56da48f7
DM
50characters in the ASCII range are unmodified, and a zero byte never appears
51within non-zero characters.
166f8a29 52
eaf7a4d2
CS
53=cut
54*/
55
9cbfb8ab
KW
56void
57Perl__force_out_malformed_utf8_message(pTHX_
58 const U8 *const p, /* First byte in UTF-8 sequence */
59 const U8 * const e, /* Final byte in sequence (may include
60 multiple chars */
61 const U32 flags, /* Flags to pass to utf8n_to_uvchr(),
62 usually 0, or some DISALLOW flags */
63 const bool die_here) /* If TRUE, this function does not return */
64{
65 /* This core-only function is to be called when a malformed UTF-8 character
66 * is found, in order to output the detailed information about the
67 * malformation before dieing. The reason it exists is for the occasions
68 * when such a malformation is fatal, but warnings might be turned off, so
69 * that normally they would not be actually output. This ensures that they
70 * do get output. Because a sequence may be malformed in more than one
71 * way, multiple messages may be generated, so we can't make them fatal, as
72 * that would cause the first one to die.
73 *
74 * Instead we pretend -W was passed to perl, then die afterwards. The
75 * flexibility is here to return to the caller so they can finish up and
76 * die themselves */
77 U32 errors;
78
79 PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE;
80
81 ENTER;
c15a80f3 82 SAVEI8(PL_dowarn);
9cbfb8ab
KW
83 SAVESPTR(PL_curcop);
84
85 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
86 if (PL_curcop) {
87 PL_curcop->cop_warnings = pWARN_ALL;
88 }
89
90 (void) utf8n_to_uvchr_error(p, e - p, NULL, flags & ~UTF8_CHECK_ONLY, &errors);
91
92 LEAVE;
93
94 if (! errors) {
95 Perl_croak(aTHX_ "panic: _force_out_malformed_utf8_message should"
96 " be called only when there are errors found");
97 }
98
99 if (die_here) {
100 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
101 }
102}
103
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
214been displayed if all lexcial warnings are enabled will be returned.
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))) {
d22ec717
KW
310 if (UNLIKELY(uv > MAX_EXTERNALLY_LEGAL_CP)) {
311 Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_EXTERNALLY_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) {
4c8cd605 387 *p-- = I8_TO_NATIVE_UTF8((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1d72bdf6
NIS
388 uv >>= UTF_ACCUMULATION_SHIFT;
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
1124 /* How many 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);
806547a7
KW
1140
1141 PERL_ARGS_ASSERT_UNEXPECTED_NON_CONTINUATION_TEXT;
1142
7cf8d05d
KW
1143 /* We don't need to pass this parameter, but since it has already been
1144 * calculated, it's likely faster to pass it; verify under DEBUGGING */
1145 assert(expect_len == UTF8SKIP(s));
1146
1147 return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x,"
1148 " %s after start byte 0x%02x; need %d bytes, got %d)",
1149 malformed_text,
7e2f38b2 1150 _byte_dump_string(s, print_len, 0),
7cf8d05d
KW
1151 *(s + non_cont_byte_pos),
1152 where,
1153 *s,
1154 (int) expect_len,
1155 (int) non_cont_byte_pos);
806547a7
KW
1156}
1157
35f8c9bd
KW
1158/*
1159
de69f3af 1160=for apidoc utf8n_to_uvchr
378516de
KW
1161
1162THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
de69f3af 1163Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
67e989fb 1164
9041c2e3 1165Bottom level UTF-8 decode routine.
de69f3af 1166Returns the native code point value of the first character in the string C<s>,
746afd53
KW
1167which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding, and no longer than
1168C<curlen> bytes; C<*retlen> (if C<retlen> isn't NULL) will be set to
1169the length, in bytes, of that character.
949cf498
KW
1170
1171The value of C<flags> determines the behavior when C<s> does not point to a
2b5e7bc2
KW
1172well-formed UTF-8 character. If C<flags> is 0, encountering a malformation
1173causes zero to be returned and C<*retlen> is set so that (S<C<s> + C<*retlen>>)
1174is the next possible position in C<s> that could begin a non-malformed
1175character. Also, if UTF-8 warnings haven't been lexically disabled, a warning
1176is raised. Some UTF-8 input sequences may contain multiple malformations.
1177This function tries to find every possible one in each call, so multiple
56576a04 1178warnings can be raised for the same sequence.
949cf498
KW
1179
1180Various ALLOW flags can be set in C<flags> to allow (and not warn on)
1181individual types of malformations, such as the sequence being overlong (that
1182is, when there is a shorter sequence that can express the same code point;
1183overlong sequences are expressly forbidden in the UTF-8 standard due to
1184potential security issues). Another malformation example is the first byte of
1185a character not being a legal first byte. See F<utf8.h> for the list of such
94953955
KW
1186flags. Even if allowed, this function generally returns the Unicode
1187REPLACEMENT CHARACTER when it encounters a malformation. There are flags in
1188F<utf8.h> to override this behavior for the overlong malformations, but don't
1189do that except for very specialized purposes.
949cf498 1190
796b6530 1191The C<UTF8_CHECK_ONLY> flag overrides the behavior when a non-allowed (by other
949cf498
KW
1192flags) malformation is found. If this flag is set, the routine assumes that
1193the caller will raise a warning, and this function will silently just set
d088425d
KW
1194C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
1195
75200dff 1196Note that this API requires disambiguation between successful decoding a C<NUL>
796b6530 1197character, and an error return (unless the C<UTF8_CHECK_ONLY> flag is set), as
111fa700
KW
1198in both cases, 0 is returned, and, depending on the malformation, C<retlen> may
1199be set to 1. To disambiguate, upon a zero return, see if the first byte of
1200C<s> is 0 as well. If so, the input was a C<NUL>; if not, the input had an
f9380377 1201error. Or you can use C<L</utf8n_to_uvchr_error>>.
949cf498
KW
1202
1203Certain code points are considered problematic. These are Unicode surrogates,
746afd53 1204Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
949cf498 1205By default these are considered regular code points, but certain situations
ecc1615f
KW
1206warrant special handling for them, which can be specified using the C<flags>
1207parameter. If C<flags> contains C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, all
1208three classes are treated as malformations and handled as such. The flags
1209C<UTF8_DISALLOW_SURROGATE>, C<UTF8_DISALLOW_NONCHAR>, and
1210C<UTF8_DISALLOW_SUPER> (meaning above the legal Unicode maximum) can be set to
1211disallow these categories individually. C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>
1212restricts the allowed inputs to the strict UTF-8 traditionally defined by
1213Unicode. Use C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE> to use the strictness
1214definition given by
1215L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1216The difference between traditional strictness and C9 strictness is that the
1217latter does not forbid non-character code points. (They are still discouraged,
1218however.) For more discussion see L<perlunicode/Noncharacter code points>.
1219
1220The flags C<UTF8_WARN_ILLEGAL_INTERCHANGE>,
1221C<UTF8_WARN_ILLEGAL_C9_INTERCHANGE>, C<UTF8_WARN_SURROGATE>,
796b6530
KW
1222C<UTF8_WARN_NONCHAR>, and C<UTF8_WARN_SUPER> will cause warning messages to be
1223raised for their respective categories, but otherwise the code points are
1224considered valid (not malformations). To get a category to both be treated as
1225a malformation and raise a warning, specify both the WARN and DISALLOW flags.
949cf498 1226(But note that warnings are not raised if lexically disabled nor if
796b6530 1227C<UTF8_CHECK_ONLY> is also specified.)
949cf498 1228
57ff5f59
KW
1229Extremely high code points were never specified in any standard, and require an
1230extension to UTF-8 to express, which Perl does. It is likely that programs
1231written in something other than Perl would not be able to read files that
1232contain these; nor would Perl understand files written by something that uses a
1233different extension. For these reasons, there is a separate set of flags that
1234can warn and/or disallow these extremely high code points, even if other
1235above-Unicode ones are accepted. They are the C<UTF8_WARN_PERL_EXTENDED> and
1236C<UTF8_DISALLOW_PERL_EXTENDED> flags. For more information see
1237L</C<UTF8_GOT_PERL_EXTENDED>>. Of course C<UTF8_DISALLOW_SUPER> will treat all
1238above-Unicode code points, including these, as malformations.
1239(Note that the Unicode standard considers anything above 0x10FFFF to be
1240illegal, but there are standards predating it that allow up to 0x7FFF_FFFF
1241(2**31 -1))
1242
1243A somewhat misleadingly named synonym for C<UTF8_WARN_PERL_EXTENDED> is
1244retained for backward compatibility: C<UTF8_WARN_ABOVE_31_BIT>. Similarly,
1245C<UTF8_DISALLOW_ABOVE_31_BIT> is usable instead of the more accurately named
1246C<UTF8_DISALLOW_PERL_EXTENDED>. The names are misleading because these flags
1247can apply to code points that actually do fit in 31 bits. This happens on
1248EBCDIC platforms, and sometimes when the L<overlong
1249malformation|/C<UTF8_GOT_LONG>> is also present. The new names accurately
1250describe the situation in all cases.
1251
ab8e6d41 1252
949cf498
KW
1253All other code points corresponding to Unicode characters, including private
1254use and those yet to be assigned, are never considered malformed and never
1255warn.
67e989fb 1256
37607a96 1257=cut
f9380377
KW
1258
1259Also implemented as a macro in utf8.h
1260*/
1261
1262UV
1263Perl_utf8n_to_uvchr(pTHX_ const U8 *s,
1264 STRLEN curlen,
1265 STRLEN *retlen,
1266 const U32 flags)
1267{
1268 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
1269
1270 return utf8n_to_uvchr_error(s, curlen, retlen, flags, NULL);
1271}
1272
2b9519f0
KW
1273/* The tables below come from http://bjoern.hoehrmann.de/utf-8/decoder/dfa/,
1274 * which requires this copyright notice */
1275
1276/* Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
1277
1278Permission is hereby granted, free of charge, to any person obtaining a copy of
1279this software and associated documentation files (the "Software"), to deal in
1280the Software without restriction, including without limitation the rights to
1281use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
1282of the Software, and to permit persons to whom the Software is furnished to do
1283so, subject to the following conditions:
1284
1285The above copyright notice and this permission notice shall be included in all
1286copies or substantial portions of the Software.
1287
1288THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
1289IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
1290FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
1291AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
1292LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
1293OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
1294SOFTWARE.
1295
1296*/
1297
1298#if 0
1299static U8 utf8d_C9[] = {
1300 /* The first part of the table maps bytes to character classes that
1301 * to reduce the size of the transition table and create bitmasks. */
1302 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-1F*/
1303 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-3F*/
1304 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-5F*/
1305 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-7F*/
1306 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, /*-9F*/
1307 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, /*-BF*/
1308 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /*-DF*/
1309 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, /*-FF*/
1310
1311 /* The second part is a transition table that maps a combination
1312 * of a state of the automaton and a character class to a state. */
1313 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
1314 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
1315 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
1316 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
1317 12,36,12,12,12,12,12,12,12,12,12,12
1318};
1319
1320#endif
1321
1322#ifndef EBCDIC
1323
1324/* This is a version of the above table customized for Perl that doesn't
1325 * exclude surrogates and accepts start bytes up through F7 (representing
1326 * 2**21 - 1). */
1327static U8 dfa_tab_for_perl[] = {
1328 /* The first part of the table maps bytes to character classes to reduce
1329 * the size of the transition table and create bitmasks. */
1330 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-1F*/
1331 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-3F*/
1332 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-5F*/
1333 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /*-7F*/
1334 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, /*-9F*/
1335 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, /*-BF*/
1336 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /*-DF*/
1337 10,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, 11,4,4,4,4,4,4,4,8,8,8,8,8,8,8,8, /*-FF*/
1338
1339 /* The second part is a transition table that maps a combination
1340 * of a state of the automaton and a character class to a state. */
1341 0,12,24,36,96,12,12,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,/*23*/
1342 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,/*47*/
1343 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,/*71*/
1344 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,/*95*/
1345 12,36,12,12,12,12,12,36,12,36,12,12 /* 96- 107 */
1346
1347 /* The customization was to repurpose the surrogates type '4' to instead be
1348 * for start bytes F1-F7. Types 5 and 6 are now unused, and their entries in
1349 * the transition part of the table are set to 12, so are illegal.
1350 *
1351 * To do higher code points would require expansion and some rearrangement of
1352 * the table. The type '1' entries for continuation bytes 80-8f would have to
1353 * be split into several types, because they aren't treated uniformly for
1354 * higher start bytes, since overlongs for F8 are 80-87; FC: 80-83; and FE:
1355 * 80-81. We start needing to worry about overflow if FE is included.
1356 * Ignoring, FE and FF, we could use type 5 for F9-FB, and 6 for FD (remember
1357 * from the web site that these are used to right shift). FE would
1358 * necessarily be type 7; and FF, type 8. And new states would have to be
1359 * created for F8 and FC (and FE and FF if used), so quite a bit of work would
1360 * be involved.
1361 *
1362 * XXX Better would be to customize the table so that the noncharacters are
1363 * excluded. This again is non trivial, but doing so would simplify the code
1364 * that uses this, and might make it small enough to make it inlinable */
1365};
1366
1367#endif
1368
f9380377
KW
1369/*
1370
1371=for apidoc utf8n_to_uvchr_error
1372
1373THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
1374Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
1375
1376This function is for code that needs to know what the precise malformation(s)
37657a5b
KW
1377are when an error is found. If you also need to know the generated warning
1378messages, use L</utf8n_to_uvchr_msgs>() instead.
f9380377
KW
1379
1380It is like C<L</utf8n_to_uvchr>> but it takes an extra parameter placed after
1381all the others, C<errors>. If this parameter is 0, this function behaves
1382identically to C<L</utf8n_to_uvchr>>. Otherwise, C<errors> should be a pointer
1383to a C<U32> variable, which this function sets to indicate any errors found.
1384Upon return, if C<*errors> is 0, there were no errors found. Otherwise,
1385C<*errors> is the bit-wise C<OR> of the bits described in the list below. Some
1386of these bits will be set if a malformation is found, even if the input
7a65503b 1387C<flags> parameter indicates that the given malformation is allowed; those
f9380377
KW
1388exceptions are noted:
1389
1390=over 4
1391
57ff5f59 1392=item C<UTF8_GOT_PERL_EXTENDED>
f9380377 1393
57ff5f59
KW
1394The input sequence is not standard UTF-8, but a Perl extension. This bit is
1395set only if the input C<flags> parameter contains either the
1396C<UTF8_DISALLOW_PERL_EXTENDED> or the C<UTF8_WARN_PERL_EXTENDED> flags.
1397
1398Code points above 0x7FFF_FFFF (2**31 - 1) were never specified in any standard,
1399and so some extension must be used to express them. Perl uses a natural
1400extension to UTF-8 to represent the ones up to 2**36-1, and invented a further
1401extension to represent even higher ones, so that any code point that fits in a
140264-bit word can be represented. Text using these extensions is not likely to
1403be portable to non-Perl code. We lump both of these extensions together and
1404refer to them as Perl extended UTF-8. There exist other extensions that people
1405have invented, incompatible with Perl's.
1406
1407On EBCDIC platforms starting in Perl v5.24, the Perl extension for representing
1408extremely high code points kicks in at 0x3FFF_FFFF (2**30 -1), which is lower
1409than on ASCII. Prior to that, code points 2**31 and higher were simply
1410unrepresentable, and a different, incompatible method was used to represent
1411code points between 2**30 and 2**31 - 1.
1412
1413On both platforms, ASCII and EBCDIC, C<UTF8_GOT_PERL_EXTENDED> is set if
1414Perl extended UTF-8 is used.
1415
1416In earlier Perls, this bit was named C<UTF8_GOT_ABOVE_31_BIT>, which you still
1417may use for backward compatibility. That name is misleading, as this flag may
1418be set when the code point actually does fit in 31 bits. This happens on
1419EBCDIC platforms, and sometimes when the L<overlong
1420malformation|/C<UTF8_GOT_LONG>> is also present. The new name accurately
1421describes the situation in all cases.
f9380377
KW
1422
1423=item C<UTF8_GOT_CONTINUATION>
1424
1425The input sequence was malformed in that the first byte was a a UTF-8
1426continuation byte.
1427
1428=item C<UTF8_GOT_EMPTY>
1429
1430The input C<curlen> parameter was 0.
1431
1432=item C<UTF8_GOT_LONG>
1433
1434The input sequence was malformed in that there is some other sequence that
1435evaluates to the same code point, but that sequence is shorter than this one.
1436
fecaf136
KW
1437Until Unicode 3.1, it was legal for programs to accept this malformation, but
1438it was discovered that this created security issues.
1439
f9380377
KW
1440=item C<UTF8_GOT_NONCHAR>
1441
1442The code point represented by the input UTF-8 sequence is for a Unicode
1443non-character code point.
1444This bit is set only if the input C<flags> parameter contains either the
1445C<UTF8_DISALLOW_NONCHAR> or the C<UTF8_WARN_NONCHAR> flags.
1446
1447=item C<UTF8_GOT_NON_CONTINUATION>
1448
1449The input sequence was malformed in that a non-continuation type byte was found
1450in a position where only a continuation type one should be.
1451
1452=item C<UTF8_GOT_OVERFLOW>
1453
1454The input sequence was malformed in that it is for a code point that is not
d22ec717 1455representable in the number of bits available in an IV on the current platform.
f9380377
KW
1456
1457=item C<UTF8_GOT_SHORT>
1458
1459The input sequence was malformed in that C<curlen> is smaller than required for
1460a complete sequence. In other words, the input is for a partial character
1461sequence.
1462
1463=item C<UTF8_GOT_SUPER>
1464
1465The input sequence was malformed in that it is for a non-Unicode code point;
1466that is, one above the legal Unicode maximum.
1467This bit is set only if the input C<flags> parameter contains either the
1468C<UTF8_DISALLOW_SUPER> or the C<UTF8_WARN_SUPER> flags.
1469
1470=item C<UTF8_GOT_SURROGATE>
1471
1472The input sequence was malformed in that it is for a -Unicode UTF-16 surrogate
1473code point.
1474This bit is set only if the input C<flags> parameter contains either the
1475C<UTF8_DISALLOW_SURROGATE> or the C<UTF8_WARN_SURROGATE> flags.
1476
1477=back
1478
133551d8
KW
1479To do your own error handling, call this function with the C<UTF8_CHECK_ONLY>
1480flag to suppress any warnings, and then examine the C<*errors> return.
1481
f9380377 1482=cut
37657a5b
KW
1483
1484Also implemented as a macro in utf8.h
37607a96 1485*/
67e989fb 1486
a0ed51b3 1487UV
f9380377 1488Perl_utf8n_to_uvchr_error(pTHX_ const U8 *s,
37657a5b
KW
1489 STRLEN curlen,
1490 STRLEN *retlen,
1491 const U32 flags,
1492 U32 * errors)
1493{
1494 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR;
1495
1496 return utf8n_to_uvchr_msgs(s, curlen, retlen, flags, errors, NULL);
1497}
1498
1499/*
1500
1501=for apidoc utf8n_to_uvchr_msgs
1502
1503THIS FUNCTION SHOULD BE USED IN ONLY VERY SPECIALIZED CIRCUMSTANCES.
1504Most code should use L</utf8_to_uvchr_buf>() rather than call this directly.
1505
1506This function is for code that needs to know what the precise malformation(s)
1507are when an error is found, and wants the corresponding warning and/or error
1508messages to be returned to the caller rather than be displayed. All messages
1509that would have been displayed if all lexcial warnings are enabled will be
1510returned.
1511
1512It is just like C<L</utf8n_to_uvchr_error>> but it takes an extra parameter
1513placed after all the others, C<msgs>. If this parameter is 0, this function
1514behaves identically to C<L</utf8n_to_uvchr_error>>. Otherwise, C<msgs> should
1515be a pointer to an C<AV *> variable, in which this function creates a new AV to
1516contain any appropriate messages. The elements of the array are ordered so
1517that the first message that would have been displayed is in the 0th element,
1518and so on. Each element is a hash with three key-value pairs, as follows:
1519
1520=over 4
1521
1522=item C<text>
1523
1524The text of the message as a C<SVpv>.
1525
1526=item C<warn_categories>
1527
1528The warning category (or categories) packed into a C<SVuv>.
1529
1530=item C<flag>
1531
1532A single flag bit associated with this message, in a C<SVuv>.
1533The bit corresponds to some bit in the C<*errors> return value,
1534such as C<UTF8_GOT_LONG>.
1535
1536=back
1537
1538It's important to note that specifying this parameter as non-null will cause
1539any warnings this function would otherwise generate to be suppressed, and
1540instead be placed in C<*msgs>. The caller can check the lexical warnings state
1541(or not) when choosing what to do with the returned messages.
1542
1543If the flag C<UTF8_CHECK_ONLY> is passed, no warnings are generated, and hence
1544no AV is created.
1545
1546The caller, of course, is responsible for freeing any returned AV.
1547
1548=cut
1549*/
1550
1551UV
1552Perl_utf8n_to_uvchr_msgs(pTHX_ const U8 *s,
1553 STRLEN curlen,
1554 STRLEN *retlen,
1555 const U32 flags,
1556 U32 * errors,
1557 AV ** msgs)
a0ed51b3 1558{
d4c19fe8 1559 const U8 * const s0 = s;
2b9519f0 1560 const U8 * send = s0 + curlen;
2b5e7bc2
KW
1561 U32 possible_problems = 0; /* A bit is set here for each potential problem
1562 found as we go along */
2b672cf5 1563 UV uv = (UV) -1;
2b5e7bc2
KW
1564 STRLEN expectlen = 0; /* How long should this sequence be?
1565 (initialized to silence compilers' wrong
1566 warning) */
e308b348 1567 STRLEN avail_len = 0; /* When input is too short, gives what that is */
f9380377
KW
1568 U32 discard_errors = 0; /* Used to save branches when 'errors' is NULL;
1569 this gets set and discarded */
a0dbb045 1570
2b5e7bc2
KW
1571 /* The below are used only if there is both an overlong malformation and a
1572 * too short one. Otherwise the first two are set to 's0' and 'send', and
1573 * the third not used at all */
1574 U8 * adjusted_s0 = (U8 *) s0;
e9f2c446
KW
1575 U8 temp_char_buf[UTF8_MAXBYTES + 1]; /* Used to avoid a Newx in this
1576 routine; see [perl #130921] */
2b5e7bc2 1577 UV uv_so_far = 0; /* (Initialized to silence compilers' wrong warning) */
7918f24d 1578
2b9519f0
KW
1579 UV state = 0;
1580
37657a5b 1581 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
f9380377
KW
1582
1583 if (errors) {
1584 *errors = 0;
1585 }
1586 else {
1587 errors = &discard_errors;
1588 }
a0dbb045 1589
eb83ed87
KW
1590 /* The order of malformation tests here is important. We should consume as
1591 * few bytes as possible in order to not skip any valid character. This is
1592 * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
1593 * http://unicode.org/reports/tr36 for more discussion as to why. For
1594 * example, once we've done a UTF8SKIP, we can tell the expected number of
1595 * bytes, and could fail right off the bat if the input parameters indicate
1596 * that there are too few available. But it could be that just that first
1597 * byte is garbled, and the intended character occupies fewer bytes. If we
1598 * blindly assumed that the first byte is correct, and skipped based on
1599 * that number, we could skip over a valid input character. So instead, we
1600 * always examine the sequence byte-by-byte.
1601 *
1602 * We also should not consume too few bytes, otherwise someone could inject
1603 * things. For example, an input could be deliberately designed to
1604 * overflow, and if this code bailed out immediately upon discovering that,
e2660c54 1605 * returning to the caller C<*retlen> pointing to the very next byte (one
eb83ed87
KW
1606 * which is actually part of of the overflowing sequence), that could look
1607 * legitimate to the caller, which could discard the initial partial
2b5e7bc2
KW
1608 * sequence and process the rest, inappropriately.
1609 *
1610 * Some possible input sequences are malformed in more than one way. This
1611 * function goes to lengths to try to find all of them. This is necessary
1612 * for correctness, as the inputs may allow one malformation but not
1613 * another, and if we abandon searching for others after finding the
1614 * allowed one, we could allow in something that shouldn't have been.
1615 */
eb83ed87 1616
b5b9af04 1617 if (UNLIKELY(curlen == 0)) {
2b5e7bc2
KW
1618 possible_problems |= UTF8_GOT_EMPTY;
1619 curlen = 0;
5a48568d 1620 uv = UNICODE_REPLACEMENT;
2b5e7bc2 1621 goto ready_to_handle_errors;
0c443dc2
JH
1622 }
1623
eb83ed87
KW
1624 expectlen = UTF8SKIP(s);
1625
1626 /* A well-formed UTF-8 character, as the vast majority of calls to this
1627 * function will be for, has this expected length. For efficiency, set
1628 * things up here to return it. It will be overriden only in those rare
1629 * cases where a malformation is found */
1630 if (retlen) {
1631 *retlen = expectlen;
1632 }
1633
1634 /* An invariant is trivially well-formed */
2b9519f0
KW
1635 if (UTF8_IS_INVARIANT(*s0)) {
1636 return *s0;
a0ed51b3 1637 }
67e989fb 1638
2b9519f0
KW
1639#ifndef EBCDIC
1640
1641 /* Measurements show that this dfa is somewhat faster than the regular code
1642 * below, so use it first, dropping down for the non-normal cases. */
1643
1644# define PERL_UTF8_DECODE_REJECT 12
1645
1646 while (s < send && LIKELY(state != PERL_UTF8_DECODE_REJECT)) {
1647 UV type = dfa_tab_for_perl[*s];
1648
1649 if (state != 0) {
1650 uv = (*s & 0x3fu) | (uv << UTF_ACCUMULATION_SHIFT);
1651 state = dfa_tab_for_perl[256 + state + type];
1652 }
1653 else {
1654 uv = (0xff >> type) & (*s);
1655 state = dfa_tab_for_perl[256 + type];
1656 }
1657
1658 if (state == 0) {
1659
1660 /* If this could be a code point that the flags don't allow (the first
1661 * surrogate is the first such possible one), delve further, but we already
1662 * have calculated 'uv' */
1663 if ( (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1664 |UTF8_WARN_ILLEGAL_INTERCHANGE))
1665 && uv >= UNICODE_SURROGATE_FIRST)
1666 {
1667 curlen = s + 1 - s0;
1668 goto got_uv;
1669 }
1670
1671 return uv;
1672 }
1673
1674 s++;
1675 }
1676
1677 /* Here, is some sort of failure. Use the full mechanism */
1678
1679 uv = *s0;
1680
1681#endif
1682
eb83ed87 1683 /* A continuation character can't start a valid sequence */
b5b9af04 1684 if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) {
2b5e7bc2
KW
1685 possible_problems |= UTF8_GOT_CONTINUATION;
1686 curlen = 1;
1687 uv = UNICODE_REPLACEMENT;
1688 goto ready_to_handle_errors;
ba210ebe 1689 }
9041c2e3 1690
dcd27b3c 1691 /* Here is not a continuation byte, nor an invariant. The only thing left
ddb65933
KW
1692 * is a start byte (possibly for an overlong). (We can't use UTF8_IS_START
1693 * because it excludes start bytes like \xC0 that always lead to
1694 * overlongs.) */
dcd27b3c 1695
534752c1
KW
1696 /* Convert to I8 on EBCDIC (no-op on ASCII), then remove the leading bits
1697 * that indicate the number of bytes in the character's whole UTF-8
1698 * sequence, leaving just the bits that are part of the value. */
1699 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
ba210ebe 1700
e308b348
KW
1701 /* Setup the loop end point, making sure to not look past the end of the
1702 * input string, and flag it as too short if the size isn't big enough. */
e308b348
KW
1703 if (UNLIKELY(curlen < expectlen)) {
1704 possible_problems |= UTF8_GOT_SHORT;
1705 avail_len = curlen;
e308b348
KW
1706 }
1707 else {
2b9519f0 1708 send = (U8*) s0 + expectlen;
e308b348 1709 }
e308b348 1710
eb83ed87 1711 /* Now, loop through the remaining bytes in the character's sequence,
e308b348 1712 * accumulating each into the working value as we go. */
eb83ed87 1713 for (s = s0 + 1; s < send; s++) {
b5b9af04 1714 if (LIKELY(UTF8_IS_CONTINUATION(*s))) {
8850bf83 1715 uv = UTF8_ACCUMULATE(uv, *s);
2b5e7bc2
KW
1716 continue;
1717 }
1718
1719 /* Here, found a non-continuation before processing all expected bytes.
1720 * This byte indicates the beginning of a new character, so quit, even
1721 * if allowing this malformation. */
2b5e7bc2 1722 possible_problems |= UTF8_GOT_NON_CONTINUATION;
e308b348 1723 break;
eb83ed87
KW
1724 } /* End of loop through the character's bytes */
1725
1726 /* Save how many bytes were actually in the character */
1727 curlen = s - s0;
1728
2b5e7bc2
KW
1729 /* Note that there are two types of too-short malformation. One is when
1730 * there is actual wrong data before the normal termination of the
1731 * sequence. The other is that the sequence wasn't complete before the end
1732 * of the data we are allowed to look at, based on the input 'curlen'.
1733 * This means that we were passed data for a partial character, but it is
1734 * valid as far as we saw. The other is definitely invalid. This
1735 * distinction could be important to a caller, so the two types are kept
15b010f0
KW
1736 * separate.
1737 *
1738 * A convenience macro that matches either of the too-short conditions. */
1739# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
1740
1741 if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
1742 uv_so_far = uv;
1743 uv = UNICODE_REPLACEMENT;
1744 }
2b5e7bc2 1745
08e73697
KW
1746 /* Check for overflow. The algorithm requires us to not look past the end
1747 * of the current character, even if partial, so the upper limit is 's' */
e050c007
KW
1748 if (UNLIKELY(0 < does_utf8_overflow(s0, s,
1749 1 /* Do consider overlongs */
1750 )))
1751 {
2b5e7bc2
KW
1752 possible_problems |= UTF8_GOT_OVERFLOW;
1753 uv = UNICODE_REPLACEMENT;
eb83ed87 1754 }
eb83ed87 1755
2b5e7bc2
KW
1756 /* Check for overlong. If no problems so far, 'uv' is the correct code
1757 * point value. Simply see if it is expressible in fewer bytes. Otherwise
1758 * we must look at the UTF-8 byte sequence itself to see if it is for an
1759 * overlong */
1760 if ( ( LIKELY(! possible_problems)
1761 && UNLIKELY(expectlen > (STRLEN) OFFUNISKIP(uv)))
56576a04 1762 || ( UNLIKELY(possible_problems)
2b5e7bc2
KW
1763 && ( UNLIKELY(! UTF8_IS_START(*s0))
1764 || ( curlen > 1
d6be65ae 1765 && UNLIKELY(0 < is_utf8_overlong_given_start_byte_ok(s0,
08e73697 1766 s - s0))))))
2f8f112e 1767 {
2b5e7bc2
KW
1768 possible_problems |= UTF8_GOT_LONG;
1769
abc28b54 1770 if ( UNLIKELY( possible_problems & UTF8_GOT_TOO_SHORT)
56576a04 1771
abc28b54
KW
1772 /* The calculation in the 'true' branch of this 'if'
1773 * below won't work if overflows, and isn't needed
1774 * anyway. Further below we handle all overflow
1775 * cases */
1776 && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW)))
1777 {
2b5e7bc2
KW
1778 UV min_uv = uv_so_far;
1779 STRLEN i;
1780
1781 /* Here, the input is both overlong and is missing some trailing
1782 * bytes. There is no single code point it could be for, but there
1783 * may be enough information present to determine if what we have
1784 * so far is for an unallowed code point, such as for a surrogate.
56576a04
KW
1785 * The code further below has the intelligence to determine this,
1786 * but just for non-overlong UTF-8 sequences. What we do here is
1787 * calculate the smallest code point the input could represent if
1788 * there were no too short malformation. Then we compute and save
1789 * the UTF-8 for that, which is what the code below looks at
1790 * instead of the raw input. It turns out that the smallest such
1791 * code point is all we need. */
2b5e7bc2
KW
1792 for (i = curlen; i < expectlen; i++) {
1793 min_uv = UTF8_ACCUMULATE(min_uv,
1794 I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
1795 }
1796
e9f2c446 1797 adjusted_s0 = temp_char_buf;
57ff5f59 1798 (void) uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
2b5e7bc2 1799 }
eb83ed87
KW
1800 }
1801
2b9519f0
KW
1802 got_uv:
1803
56576a04
KW
1804 /* Here, we have found all the possible problems, except for when the input
1805 * is for a problematic code point not allowed by the input parameters. */
1806
06188866
KW
1807 /* uv is valid for overlongs */
1808 if ( ( ( LIKELY(! (possible_problems & ~UTF8_GOT_LONG))
1809
1810 /* isn't problematic if < this */
1811 && uv >= UNICODE_SURROGATE_FIRST)
2b5e7bc2 1812 || ( UNLIKELY(possible_problems)
d60baaa7
KW
1813
1814 /* if overflow, we know without looking further
1815 * precisely which of the problematic types it is,
1816 * and we deal with those in the overflow handling
1817 * code */
1818 && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW))
57ff5f59
KW
1819 && ( isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0)
1820 || UNLIKELY(isUTF8_PERL_EXTENDED(s0)))))
760c7c2f
KW
1821 && ((flags & ( UTF8_DISALLOW_NONCHAR
1822 |UTF8_DISALLOW_SURROGATE
1823 |UTF8_DISALLOW_SUPER
d044b7a7 1824 |UTF8_DISALLOW_PERL_EXTENDED
760c7c2f
KW
1825 |UTF8_WARN_NONCHAR
1826 |UTF8_WARN_SURROGATE
1827 |UTF8_WARN_SUPER
d22ec717 1828 |UTF8_WARN_PERL_EXTENDED))))
eb83ed87 1829 {
2b5e7bc2
KW
1830 /* If there were no malformations, or the only malformation is an
1831 * overlong, 'uv' is valid */
1832 if (LIKELY(! (possible_problems & ~UTF8_GOT_LONG))) {
1833 if (UNLIKELY(UNICODE_IS_SURROGATE(uv))) {
1834 possible_problems |= UTF8_GOT_SURROGATE;
1835 }
1836 else if (UNLIKELY(uv > PERL_UNICODE_MAX)) {
1837 possible_problems |= UTF8_GOT_SUPER;
1838 }
1839 else if (UNLIKELY(UNICODE_IS_NONCHAR(uv))) {
1840 possible_problems |= UTF8_GOT_NONCHAR;
1841 }
1842 }
1843 else { /* Otherwise, need to look at the source UTF-8, possibly
1844 adjusted to be non-overlong */
1845
1846 if (UNLIKELY(NATIVE_UTF8_TO_I8(*adjusted_s0)
1847 >= FIRST_START_BYTE_THAT_IS_DEFINITELY_SUPER))
ea5ced44 1848 {
2b5e7bc2
KW
1849 possible_problems |= UTF8_GOT_SUPER;
1850 }
1851 else if (curlen > 1) {
1852 if (UNLIKELY(IS_UTF8_2_BYTE_SUPER(
1853 NATIVE_UTF8_TO_I8(*adjusted_s0),
1854 NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
ea5ced44 1855 {
2b5e7bc2 1856 possible_problems |= UTF8_GOT_SUPER;
ea5ced44 1857 }
2b5e7bc2
KW
1858 else if (UNLIKELY(IS_UTF8_2_BYTE_SURROGATE(
1859 NATIVE_UTF8_TO_I8(*adjusted_s0),
1860 NATIVE_UTF8_TO_I8(*(adjusted_s0 + 1)))))
1861 {
1862 possible_problems |= UTF8_GOT_SURROGATE;
ea5ced44
KW
1863 }
1864 }
c0236afe 1865
2b5e7bc2
KW
1866 /* We need a complete well-formed UTF-8 character to discern
1867 * non-characters, so can't look for them here */
1868 }
1869 }
949cf498 1870
2b5e7bc2
KW
1871 ready_to_handle_errors:
1872
1873 /* At this point:
1874 * curlen contains the number of bytes in the sequence that
1875 * this call should advance the input by.
e308b348
KW
1876 * avail_len gives the available number of bytes passed in, but
1877 * only if this is less than the expected number of
1878 * bytes, based on the code point's start byte.
2b5e7bc2
KW
1879 * possible_problems' is 0 if there weren't any problems; otherwise a bit
1880 * is set in it for each potential problem found.
1881 * uv contains the code point the input sequence
1882 * represents; or if there is a problem that prevents
1883 * a well-defined value from being computed, it is
1884 * some subsitute value, typically the REPLACEMENT
1885 * CHARACTER.
1886 * s0 points to the first byte of the character
56576a04
KW
1887 * s points to just after were we left off processing
1888 * the character
1889 * send points to just after where that character should
1890 * end, based on how many bytes the start byte tells
1891 * us should be in it, but no further than s0 +
1892 * avail_len
2b5e7bc2 1893 */
eb83ed87 1894
2b5e7bc2
KW
1895 if (UNLIKELY(possible_problems)) {
1896 bool disallowed = FALSE;
1897 const U32 orig_problems = possible_problems;
1898
37657a5b
KW
1899 if (msgs) {
1900 *msgs = NULL;
1901 }
1902
2b5e7bc2
KW
1903 while (possible_problems) { /* Handle each possible problem */
1904 UV pack_warn = 0;
1905 char * message = NULL;
37657a5b 1906 U32 this_flag_bit = 0;
2b5e7bc2
KW
1907
1908 /* Each 'if' clause handles one problem. They are ordered so that
1909 * the first ones' messages will be displayed before the later
6c64cd9d
KW
1910 * ones; this is kinda in decreasing severity order. But the
1911 * overlong must come last, as it changes 'uv' looked at by the
1912 * others */
2b5e7bc2
KW
1913 if (possible_problems & UTF8_GOT_OVERFLOW) {
1914
56576a04
KW
1915 /* Overflow means also got a super and are using Perl's
1916 * extended UTF-8, but we handle all three cases here */
2b5e7bc2 1917 possible_problems
d044b7a7 1918 &= ~(UTF8_GOT_OVERFLOW|UTF8_GOT_SUPER|UTF8_GOT_PERL_EXTENDED);
f9380377
KW
1919 *errors |= UTF8_GOT_OVERFLOW;
1920
1921 /* But the API says we flag all errors found */
1922 if (flags & (UTF8_WARN_SUPER|UTF8_DISALLOW_SUPER)) {
1923 *errors |= UTF8_GOT_SUPER;
1924 }
ddb65933 1925 if (flags
d044b7a7 1926 & (UTF8_WARN_PERL_EXTENDED|UTF8_DISALLOW_PERL_EXTENDED))
ddb65933 1927 {
d044b7a7 1928 *errors |= UTF8_GOT_PERL_EXTENDED;
f9380377 1929 }
2b5e7bc2 1930
d60baaa7 1931 /* Disallow if any of the three categories say to */
56576a04 1932 if ( ! (flags & UTF8_ALLOW_OVERFLOW)
d60baaa7 1933 || (flags & ( UTF8_DISALLOW_SUPER
d044b7a7 1934 |UTF8_DISALLOW_PERL_EXTENDED)))
d60baaa7
KW
1935 {
1936 disallowed = TRUE;
1937 }
1938
d22ec717
KW
1939 /* Likewise, warn if any say to */
1940 if ( ! (flags & UTF8_ALLOW_OVERFLOW)
1941 || (flags & (UTF8_WARN_SUPER|UTF8_WARN_PERL_EXTENDED)))
d60baaa7 1942 {
2b5e7bc2 1943
ddb65933
KW
1944 /* The warnings code explicitly says it doesn't handle the
1945 * case of packWARN2 and two categories which have
1946 * parent-child relationship. Even if it works now to
1947 * raise the warning if either is enabled, it wouldn't
1948 * necessarily do so in the future. We output (only) the
56576a04 1949 * most dire warning */
ddb65933 1950 if (! (flags & UTF8_CHECK_ONLY)) {
37657a5b 1951 if (msgs || ckWARN_d(WARN_UTF8)) {
ddb65933
KW
1952 pack_warn = packWARN(WARN_UTF8);
1953 }
37657a5b 1954 else if (msgs || ckWARN_d(WARN_NON_UNICODE)) {
ddb65933
KW
1955 pack_warn = packWARN(WARN_NON_UNICODE);
1956 }
1957 if (pack_warn) {
1958 message = Perl_form(aTHX_ "%s: %s (overflows)",
1959 malformed_text,
05b9033b 1960 _byte_dump_string(s0, curlen, 0));
37657a5b 1961 this_flag_bit = UTF8_GOT_OVERFLOW;
ddb65933 1962 }
2b5e7bc2
KW
1963 }
1964 }
1965 }
1966 else if (possible_problems & UTF8_GOT_EMPTY) {
1967 possible_problems &= ~UTF8_GOT_EMPTY;
f9380377 1968 *errors |= UTF8_GOT_EMPTY;
2b5e7bc2
KW
1969
1970 if (! (flags & UTF8_ALLOW_EMPTY)) {
d1f8d421
KW
1971
1972 /* This so-called malformation is now treated as a bug in
1973 * the caller. If you have nothing to decode, skip calling
1974 * this function */
1975 assert(0);
1976
2b5e7bc2 1977 disallowed = TRUE;
37657a5b
KW
1978 if ( (msgs
1979 || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1980 {
2b5e7bc2
KW
1981 pack_warn = packWARN(WARN_UTF8);
1982 message = Perl_form(aTHX_ "%s (empty string)",
1983 malformed_text);
37657a5b 1984 this_flag_bit = UTF8_GOT_EMPTY;
2b5e7bc2
KW
1985 }
1986 }
1987 }
1988 else if (possible_problems & UTF8_GOT_CONTINUATION) {
1989 possible_problems &= ~UTF8_GOT_CONTINUATION;
f9380377 1990 *errors |= UTF8_GOT_CONTINUATION;
2b5e7bc2
KW
1991
1992 if (! (flags & UTF8_ALLOW_CONTINUATION)) {
1993 disallowed = TRUE;
37657a5b
KW
1994 if (( msgs
1995 || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
1996 {
2b5e7bc2
KW
1997 pack_warn = packWARN(WARN_UTF8);
1998 message = Perl_form(aTHX_
1999 "%s: %s (unexpected continuation byte 0x%02x,"
2000 " with no preceding start byte)",
2001 malformed_text,
7e2f38b2 2002 _byte_dump_string(s0, 1, 0), *s0);
37657a5b 2003 this_flag_bit = UTF8_GOT_CONTINUATION;
2b5e7bc2
KW
2004 }
2005 }
2006 }
2b5e7bc2
KW
2007 else if (possible_problems & UTF8_GOT_SHORT) {
2008 possible_problems &= ~UTF8_GOT_SHORT;
f9380377 2009 *errors |= UTF8_GOT_SHORT;
2b5e7bc2
KW
2010
2011 if (! (flags & UTF8_ALLOW_SHORT)) {
2012 disallowed = TRUE;
37657a5b
KW
2013 if (( msgs
2014 || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
2015 {
2b5e7bc2
KW
2016 pack_warn = packWARN(WARN_UTF8);
2017 message = Perl_form(aTHX_
56576a04
KW
2018 "%s: %s (too short; %d byte%s available, need %d)",
2019 malformed_text,
2020 _byte_dump_string(s0, send - s0, 0),
2021 (int)avail_len,
2022 avail_len == 1 ? "" : "s",
2023 (int)expectlen);
37657a5b 2024 this_flag_bit = UTF8_GOT_SHORT;
2b5e7bc2
KW
2025 }
2026 }
ba210ebe 2027
2b5e7bc2 2028 }
e308b348
KW
2029 else if (possible_problems & UTF8_GOT_NON_CONTINUATION) {
2030 possible_problems &= ~UTF8_GOT_NON_CONTINUATION;
2031 *errors |= UTF8_GOT_NON_CONTINUATION;
2032
2033 if (! (flags & UTF8_ALLOW_NON_CONTINUATION)) {
2034 disallowed = TRUE;
37657a5b
KW
2035 if (( msgs
2036 || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
2037 {
99a765e9
KW
2038
2039 /* If we don't know for sure that the input length is
2040 * valid, avoid as much as possible reading past the
2041 * end of the buffer */
2042 int printlen = (flags & _UTF8_NO_CONFIDENCE_IN_CURLEN)
2043 ? s - s0
2044 : send - s0;
e308b348
KW
2045 pack_warn = packWARN(WARN_UTF8);
2046 message = Perl_form(aTHX_ "%s",
2047 unexpected_non_continuation_text(s0,
99a765e9 2048 printlen,
e308b348
KW
2049 s - s0,
2050 (int) expectlen));
37657a5b 2051 this_flag_bit = UTF8_GOT_NON_CONTINUATION;
e308b348
KW
2052 }
2053 }
2054 }
2b5e7bc2
KW
2055 else if (possible_problems & UTF8_GOT_SURROGATE) {
2056 possible_problems &= ~UTF8_GOT_SURROGATE;
2057
f9380377
KW
2058 if (flags & UTF8_WARN_SURROGATE) {
2059 *errors |= UTF8_GOT_SURROGATE;
2060
2061 if ( ! (flags & UTF8_CHECK_ONLY)
37657a5b 2062 && (msgs || ckWARN_d(WARN_SURROGATE)))
f9380377 2063 {
2b5e7bc2
KW
2064 pack_warn = packWARN(WARN_SURROGATE);
2065
2066 /* These are the only errors that can occur with a
2067 * surrogate when the 'uv' isn't valid */
2068 if (orig_problems & UTF8_GOT_TOO_SHORT) {
2069 message = Perl_form(aTHX_
2070 "UTF-16 surrogate (any UTF-8 sequence that"
2071 " starts with \"%s\" is for a surrogate)",
7e2f38b2 2072 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
2073 }
2074 else {
c94c2f39 2075 message = Perl_form(aTHX_ surrogate_cp_format, uv);
2b5e7bc2 2076 }
37657a5b 2077 this_flag_bit = UTF8_GOT_SURROGATE;
f9380377 2078 }
2b5e7bc2 2079 }
ba210ebe 2080
2b5e7bc2
KW
2081 if (flags & UTF8_DISALLOW_SURROGATE) {
2082 disallowed = TRUE;
f9380377 2083 *errors |= UTF8_GOT_SURROGATE;
2b5e7bc2
KW
2084 }
2085 }
2086 else if (possible_problems & UTF8_GOT_SUPER) {
2087 possible_problems &= ~UTF8_GOT_SUPER;
949cf498 2088
f9380377
KW
2089 if (flags & UTF8_WARN_SUPER) {
2090 *errors |= UTF8_GOT_SUPER;
2091
2092 if ( ! (flags & UTF8_CHECK_ONLY)
37657a5b 2093 && (msgs || ckWARN_d(WARN_NON_UNICODE)))
f9380377 2094 {
2b5e7bc2
KW
2095 pack_warn = packWARN(WARN_NON_UNICODE);
2096
2097 if (orig_problems & UTF8_GOT_TOO_SHORT) {
2098 message = Perl_form(aTHX_
2099 "Any UTF-8 sequence that starts with"
2100 " \"%s\" is for a non-Unicode code point,"
2101 " may not be portable",
7e2f38b2 2102 _byte_dump_string(s0, curlen, 0));
2b5e7bc2
KW
2103 }
2104 else {
c94c2f39 2105 message = Perl_form(aTHX_ super_cp_format, uv);
2b5e7bc2 2106 }
37657a5b 2107 this_flag_bit = UTF8_GOT_SUPER;
f9380377 2108 }
2b5e7bc2 2109 }
ba210ebe 2110
57ff5f59
KW
2111 /* Test for Perl's extended UTF-8 after the regular SUPER ones,
2112 * and before possibly bailing out, so that the more dire
2113 * warning will override the regular one. */
2114 if (UNLIKELY(isUTF8_PERL_EXTENDED(s0))) {
2b5e7bc2 2115 if ( ! (flags & UTF8_CHECK_ONLY)
d044b7a7 2116 && (flags & (UTF8_WARN_PERL_EXTENDED|UTF8_WARN_SUPER))
37657a5b 2117 && (msgs || ckWARN_d(WARN_NON_UNICODE)))
2b5e7bc2 2118 {
db0f09e6 2119 pack_warn = packWARN(WARN_NON_UNICODE);
2b5e7bc2 2120
57ff5f59
KW
2121 /* If it is an overlong that evaluates to a code point
2122 * that doesn't have to use the Perl extended UTF-8, it
2123 * still used it, and so we output a message that
2124 * doesn't refer to the code point. The same is true
2125 * if there was a SHORT malformation where the code
2126 * point is not valid. In that case, 'uv' will have
2127 * been set to the REPLACEMENT CHAR, and the message
2128 * below without the code point in it will be selected
2129 * */
2130 if (UNICODE_IS_PERL_EXTENDED(uv)) {
2b5e7bc2 2131 message = Perl_form(aTHX_
57ff5f59 2132 perl_extended_cp_format, uv);
2b5e7bc2
KW
2133 }
2134 else {
2135 message = Perl_form(aTHX_
57ff5f59
KW
2136 "Any UTF-8 sequence that starts with"
2137 " \"%s\" is a Perl extension, and"
2138 " so is not portable",
2139 _byte_dump_string(s0, curlen, 0));
2b5e7bc2 2140 }
37657a5b 2141 this_flag_bit = UTF8_GOT_PERL_EXTENDED;
2b5e7bc2
KW
2142 }
2143
d044b7a7
KW
2144 if (flags & ( UTF8_WARN_PERL_EXTENDED
2145 |UTF8_DISALLOW_PERL_EXTENDED))
ddb65933 2146 {
d044b7a7 2147 *errors |= UTF8_GOT_PERL_EXTENDED;
f9380377 2148
d044b7a7 2149 if (flags & UTF8_DISALLOW_PERL_EXTENDED) {
f9380377
KW
2150 disallowed = TRUE;
2151 }
2b5e7bc2
KW
2152 }
2153 }
eb83ed87 2154
2b5e7bc2 2155 if (flags & UTF8_DISALLOW_SUPER) {
f9380377 2156 *errors |= UTF8_GOT_SUPER;
2b5e7bc2
KW
2157 disallowed = TRUE;
2158 }
2b5e7bc2
KW
2159 }
2160 else if (possible_problems & UTF8_GOT_NONCHAR) {
2161 possible_problems &= ~UTF8_GOT_NONCHAR;
ba210ebe 2162
f9380377
KW
2163 if (flags & UTF8_WARN_NONCHAR) {
2164 *errors |= UTF8_GOT_NONCHAR;
2165
2166 if ( ! (flags & UTF8_CHECK_ONLY)
37657a5b 2167 && (msgs || ckWARN_d(WARN_NONCHAR)))
f9380377 2168 {
2b5e7bc2
KW
2169 /* The code above should have guaranteed that we don't
2170 * get here with errors other than overlong */
2171 assert (! (orig_problems
2172 & ~(UTF8_GOT_LONG|UTF8_GOT_NONCHAR)));
2173
2174 pack_warn = packWARN(WARN_NONCHAR);
c94c2f39 2175 message = Perl_form(aTHX_ nonchar_cp_format, uv);
37657a5b 2176 this_flag_bit = UTF8_GOT_NONCHAR;
f9380377 2177 }
2b5e7bc2 2178 }
5b311467 2179
2b5e7bc2
KW
2180 if (flags & UTF8_DISALLOW_NONCHAR) {
2181 disallowed = TRUE;
f9380377 2182 *errors |= UTF8_GOT_NONCHAR;
2b5e7bc2 2183 }
6c64cd9d
KW
2184 }
2185 else if (possible_problems & UTF8_GOT_LONG) {
2186 possible_problems &= ~UTF8_GOT_LONG;
2187 *errors |= UTF8_GOT_LONG;
2188
2189 if (flags & UTF8_ALLOW_LONG) {
2190
2191 /* We don't allow the actual overlong value, unless the
2192 * special extra bit is also set */
2193 if (! (flags & ( UTF8_ALLOW_LONG_AND_ITS_VALUE
2194 & ~UTF8_ALLOW_LONG)))
2195 {
2196 uv = UNICODE_REPLACEMENT;
2197 }
2198 }
2199 else {
2200 disallowed = TRUE;
2201
37657a5b
KW
2202 if (( msgs
2203 || ckWARN_d(WARN_UTF8)) && ! (flags & UTF8_CHECK_ONLY))
2204 {
6c64cd9d
KW
2205 pack_warn = packWARN(WARN_UTF8);
2206
2207 /* These error types cause 'uv' to be something that
2208 * isn't what was intended, so can't use it in the
2209 * message. The other error types either can't
2210 * generate an overlong, or else the 'uv' is valid */
2211 if (orig_problems &
2212 (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
2213 {
2214 message = Perl_form(aTHX_
2215 "%s: %s (any UTF-8 sequence that starts"
2216 " with \"%s\" is overlong which can and"
2217 " should be represented with a"
2218 " different, shorter sequence)",
2219 malformed_text,
2220 _byte_dump_string(s0, send - s0, 0),
2221 _byte_dump_string(s0, curlen, 0));
2222 }
2223 else {
2224 U8 tmpbuf[UTF8_MAXBYTES+1];
1be62ab9
KW
2225 const U8 * const e = uvoffuni_to_utf8_flags(tmpbuf,
2226 uv, 0);
d819dc50
KW
2227 /* Don't use U+ for non-Unicode code points, which
2228 * includes those in the Latin1 range */
2229 const char * preface = ( uv > PERL_UNICODE_MAX
2230#ifdef EBCDIC
2231 || uv <= 0xFF
2232#endif
2233 )
2234 ? "0x"
2235 : "U+";
6c64cd9d
KW
2236 message = Perl_form(aTHX_
2237 "%s: %s (overlong; instead use %s to represent"
2238 " %s%0*" UVXf ")",
2239 malformed_text,
2240 _byte_dump_string(s0, send - s0, 0),
2241 _byte_dump_string(tmpbuf, e - tmpbuf, 0),
2242 preface,
2243 ((uv < 256) ? 2 : 4), /* Field width of 2 for
2244 small code points */
1be62ab9 2245 UNI_TO_NATIVE(uv));
6c64cd9d 2246 }
37657a5b 2247 this_flag_bit = UTF8_GOT_LONG;
6c64cd9d
KW
2248 }
2249 }
2b5e7bc2
KW
2250 } /* End of looking through the possible flags */
2251
2252 /* Display the message (if any) for the problem being handled in
2253 * this iteration of the loop */
2254 if (message) {
37657a5b 2255 if (msgs) {
37657a5b
KW
2256 assert(this_flag_bit);
2257
2258 if (*msgs == NULL) {
2259 *msgs = newAV();
2260 }
2261
bb07812e
KW
2262 av_push(*msgs, newRV_noinc((SV*) new_msg_hv(message,
2263 pack_warn,
2264 this_flag_bit)));
37657a5b
KW
2265 }
2266 else if (PL_op)
2b5e7bc2
KW
2267 Perl_warner(aTHX_ pack_warn, "%s in %s", message,
2268 OP_DESC(PL_op));
2269 else
2270 Perl_warner(aTHX_ pack_warn, "%s", message);
2271 }
ddb65933 2272 } /* End of 'while (possible_problems)' */
a0dbb045 2273
2b5e7bc2
KW
2274 /* Since there was a possible problem, the returned length may need to
2275 * be changed from the one stored at the beginning of this function.
2276 * Instead of trying to figure out if that's needed, just do it. */
2277 if (retlen) {
2278 *retlen = curlen;
2279 }
a0dbb045 2280
2b5e7bc2
KW
2281 if (disallowed) {
2282 if (flags & UTF8_CHECK_ONLY && retlen) {
2283 *retlen = ((STRLEN) -1);
2284 }
2285 return 0;
2286 }
eb83ed87 2287 }
ba210ebe 2288
2b5e7bc2 2289 return UNI_TO_NATIVE(uv);
a0ed51b3
LW
2290}
2291
8e84507e 2292/*
ec5f19d0
KW
2293=for apidoc utf8_to_uvchr_buf
2294
2295Returns the native code point of the first character in the string C<s> which
2296is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
524080c4 2297C<*retlen> will be set to the length, in bytes, of that character.
ec5f19d0 2298
524080c4
KW
2299If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
2300enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
796b6530 2301C<NULL>) to -1. If those warnings are off, the computed value, if well-defined
173db420 2302(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
796b6530 2303C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
173db420 2304the next possible position in C<s> that could begin a non-malformed character.
de69f3af 2305See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
173db420 2306returned.
ec5f19d0
KW
2307
2308=cut
52be2536
KW
2309
2310Also implemented as a macro in utf8.h
2311
ec5f19d0
KW
2312*/
2313
2314
2315UV
2316Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
2317{
7f974d7e
KW
2318 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
2319
ec5f19d0
KW
2320 assert(s < send);
2321
2322 return utf8n_to_uvchr(s, send - s, retlen,
ddb65933 2323 ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
ec5f19d0
KW
2324}
2325
52be2536
KW
2326/* This is marked as deprecated
2327 *
ec5f19d0
KW
2328=for apidoc utf8_to_uvuni_buf
2329
de69f3af
KW
2330Only in very rare circumstances should code need to be dealing in Unicode
2331(as opposed to native) code points. In those few cases, use
2332C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>> instead.
4f83cdcd
KW
2333
2334Returns the Unicode (not-native) code point of the first character in the
2335string C<s> which
ec5f19d0
KW
2336is assumed to be in UTF-8 encoding; C<send> points to 1 beyond the end of C<s>.
2337C<retlen> will be set to the length, in bytes, of that character.
2338
524080c4
KW
2339If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
2340enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
2341NULL) to -1. If those warnings are off, the computed value if well-defined (or
2342the Unicode REPLACEMENT CHARACTER, if not) is silently returned, and C<*retlen>
2343is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is the
2344next possible position in C<s> that could begin a non-malformed character.
de69f3af 2345See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is returned.
ec5f19d0
KW
2346
2347=cut
2348*/
2349
2350UV
2351Perl_utf8_to_uvuni_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
2352{
2353 PERL_ARGS_ASSERT_UTF8_TO_UVUNI_BUF;
2354
2355 assert(send > s);
2356
5962d97e 2357 return NATIVE_TO_UNI(utf8_to_uvchr_buf(s, send, retlen));
ec5f19d0
KW
2358}
2359
b76347f2 2360/*
87cea99e 2361=for apidoc utf8_length
b76347f2 2362
b2e7ed74
KW
2363Returns the number of characters in the sequence of UTF-8-encoded bytes starting
2364at C<s> and ending at the byte just before C<e>. If <s> and <e> point to the
2365same place, it returns 0 with no warning raised.
2366
2367If C<e E<lt> s> or if the scan would end up past C<e>, it raises a UTF8 warning
2368and returns the number of valid characters.
b76347f2
JH
2369
2370=cut
2371*/
2372
2373STRLEN
35a4481c 2374Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
b76347f2
JH
2375{
2376 STRLEN len = 0;
2377
7918f24d
NC
2378 PERL_ARGS_ASSERT_UTF8_LENGTH;
2379
8850bf83
JH
2380 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
2381 * the bitops (especially ~) can create illegal UTF-8.
2382 * In other words: in Perl UTF-8 is not just for Unicode. */
2383
a3b680e6
AL
2384 if (e < s)
2385 goto warn_and_return;
b76347f2 2386 while (s < e) {
4cbf4130 2387 s += UTF8SKIP(s);
8e91ec7f
AV
2388 len++;
2389 }
2390
2391 if (e != s) {
2392 len--;
2393 warn_and_return:
9b387841
NC
2394 if (PL_op)
2395 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2396 "%s in %s", unees, OP_DESC(PL_op));
2397 else
61a12c31 2398 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
b76347f2
JH
2399 }
2400
2401 return len;
2402}
2403
b06226ff 2404/*
fed3ba5d
NC
2405=for apidoc bytes_cmp_utf8
2406
a1433954 2407Compares the sequence of characters (stored as octets) in C<b>, C<blen> with the
72d33970
FC
2408sequence of characters (stored as UTF-8)
2409in C<u>, C<ulen>. Returns 0 if they are
fed3ba5d
NC
2410equal, -1 or -2 if the first string is less than the second string, +1 or +2
2411if the first string is greater than the second string.
2412
2413-1 or +1 is returned if the shorter string was identical to the start of the
72d33970
FC
2414longer string. -2 or +2 is returned if
2415there was a difference between characters
fed3ba5d
NC
2416within the strings.
2417
2418=cut
2419*/
2420
2421int
2422Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
2423{
2424 const U8 *const bend = b + blen;
2425 const U8 *const uend = u + ulen;
2426
2427 PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
fed3ba5d
NC
2428
2429 while (b < bend && u < uend) {
2430 U8 c = *u++;
2431 if (!UTF8_IS_INVARIANT(c)) {
2432 if (UTF8_IS_DOWNGRADEABLE_START(c)) {
2433 if (u < uend) {
2434 U8 c1 = *u++;
2435 if (UTF8_IS_CONTINUATION(c1)) {
a62b247b 2436 c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
fed3ba5d 2437 } else {
2b5e7bc2 2438 /* diag_listed_as: Malformed UTF-8 character%s */
fed3ba5d 2439 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
56576a04
KW
2440 "%s %s%s",
2441 unexpected_non_continuation_text(u - 2, 2, 1, 2),
2442 PL_op ? " in " : "",
2443 PL_op ? OP_DESC(PL_op) : "");
fed3ba5d
NC
2444 return -2;
2445 }
2446 } else {
2447 if (PL_op)
2448 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2449 "%s in %s", unees, OP_DESC(PL_op));
2450 else
61a12c31 2451 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
fed3ba5d
NC
2452 return -2; /* Really want to return undef :-) */
2453 }
2454 } else {
2455 return -2;
2456 }
2457 }
2458 if (*b != c) {
2459 return *b < c ? -2 : +2;
2460 }
2461 ++b;
2462 }
2463
2464 if (b == bend && u == uend)
2465 return 0;
2466
2467 return b < bend ? +1 : -1;
2468}
2469
2470/*
87cea99e 2471=for apidoc utf8_to_bytes
6940069f 2472
3bc0c78c 2473Converts a string C<"s"> of length C<*lenp> from UTF-8 into native byte encoding.
a1433954 2474Unlike L</bytes_to_utf8>, this over-writes the original string, and
09af0336 2475updates C<*lenp> to contain the new length.
3bc0c78c
KW
2476Returns zero on failure (leaving C<"s"> unchanged) setting C<*lenp> to -1.
2477
2478Upon successful return, the number of variants in the string can be computed by
23b37b12
KW
2479having saved the value of C<*lenp> before the call, and subtracting the
2480after-call value of C<*lenp> from it.
6940069f 2481
a1433954 2482If you need a copy of the string, see L</bytes_from_utf8>.
95be277c 2483
6940069f
GS
2484=cut
2485*/
2486
2487U8 *
09af0336 2488Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *lenp)
6940069f 2489{
9fe0d3c2 2490 U8 * first_variant;
246fae53 2491
7918f24d 2492 PERL_ARGS_ASSERT_UTF8_TO_BYTES;
81611534 2493 PERL_UNUSED_CONTEXT;
7918f24d 2494
9fe0d3c2 2495 /* This is a no-op if no variants at all in the input */
09af0336 2496 if (is_utf8_invariant_string_loc(s, *lenp, (const U8 **) &first_variant)) {
9fe0d3c2
KW
2497 return s;
2498 }
2499
2500 {
3c5aa262 2501 U8 * const save = s;
09af0336 2502 U8 * const send = s + *lenp;
3c5aa262
KW
2503 U8 * d;
2504
2505 /* Nothing before the first variant needs to be changed, so start the real
2506 * work there */
2507 s = first_variant;
2508 while (s < send) {
2509 if (! UTF8_IS_INVARIANT(*s)) {
2510 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, send)) {
09af0336 2511 *lenp = ((STRLEN) -1);
3c5aa262
KW
2512 return 0;
2513 }
2514 s++;
d59937ca
KW
2515 }
2516 s++;
dcad2880 2517 }
dcad2880 2518
3c5aa262
KW
2519 /* Is downgradable, so do it */
2520 d = s = first_variant;
2521 while (s < send) {
2522 U8 c = *s++;
2523 if (! UVCHR_IS_INVARIANT(c)) {
2524 /* Then it is two-byte encoded */
2525 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
2526 s++;
2527 }
2528 *d++ = c;
2529 }
2530 *d = '\0';
09af0336 2531 *lenp = d - save;
3c5aa262
KW
2532
2533 return save;
9fe0d3c2 2534 }
6940069f
GS
2535}
2536
2537/*
87cea99e 2538=for apidoc bytes_from_utf8
f9a63242 2539
09af0336 2540Converts a potentially UTF-8 encoded string C<s> of length C<*lenp> into native
41ae6089 2541byte encoding. On input, the boolean C<*is_utf8p> gives whether or not C<s> is
4f3d592d
KW
2542actually encoded in UTF-8.
2543
2544Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, this is non-destructive of
2545the input string.
2546
41ae6089
KW
2547Do nothing if C<*is_utf8p> is 0, or if there are code points in the string
2548not expressible in native byte encoding. In these cases, C<*is_utf8p> and
09af0336 2549C<*lenp> are unchanged, and the return value is the original C<s>.
4f3d592d 2550
41ae6089 2551Otherwise, C<*is_utf8p> is set to 0, and the return value is a pointer to a
4f3d592d 2552newly created string containing a downgraded copy of C<s>, and whose length is
23b37b12 2553returned in C<*lenp>, updated. The new string is C<NUL>-terminated.
f9a63242 2554
3bc0c78c 2555Upon successful return, the number of variants in the string can be computed by
23b37b12
KW
2556having saved the value of C<*lenp> before the call, and subtracting the
2557after-call value of C<*lenp> from it.
3bc0c78c 2558
37607a96 2559=cut
976c1b08
KW
2560
2561There is a macro that avoids this function call, but this is retained for
2562anyone who calls it with the Perl_ prefix */
f9a63242
JH
2563
2564U8 *
41ae6089 2565Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *lenp, bool *is_utf8p)
f9a63242 2566{
7918f24d 2567 PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
96a5add6 2568 PERL_UNUSED_CONTEXT;
f9a63242 2569
976c1b08
KW
2570 return bytes_from_utf8_loc(s, lenp, is_utf8p, NULL);
2571}
2572
2573/*
2574No = here because currently externally undocumented
2575for apidoc bytes_from_utf8_loc
2576
2577Like C<L</bytes_from_utf8>()>, but takes an extra parameter, a pointer to where
2578to store the location of the first character in C<"s"> that cannot be
2579converted to non-UTF8.
2580
2581If that parameter is C<NULL>, this function behaves identically to
2582C<bytes_from_utf8>.
2583
2584Otherwise if C<*is_utf8p> is 0 on input, the function behaves identically to
2585C<bytes_from_utf8>, except it also sets C<*first_non_downgradable> to C<NULL>.
2586
2587Otherwise, the function returns a newly created C<NUL>-terminated string
2588containing the non-UTF8 equivalent of the convertible first portion of
2589C<"s">. C<*lenp> is set to its length, not including the terminating C<NUL>.
2590If the entire input string was converted, C<*is_utf8p> is set to a FALSE value,
2591and C<*first_non_downgradable> is set to C<NULL>.
2592
2593Otherwise, C<*first_non_downgradable> set to point to the first byte of the
2594first character in the original string that wasn't converted. C<*is_utf8p> is
2595unchanged. Note that the new string may have length 0.
2596
2597Another way to look at it is, if C<*first_non_downgradable> is non-C<NULL> and
2598C<*is_utf8p> is TRUE, this function starts at the beginning of C<"s"> and
2599converts as many characters in it as possible stopping at the first one it
385b74be 2600finds that can't be converted to non-UTF-8. C<*first_non_downgradable> is
976c1b08
KW
2601set to point to that. The function returns the portion that could be converted
2602in a newly created C<NUL>-terminated string, and C<*lenp> is set to its length,
2603not including the terminating C<NUL>. If the very first character in the
2604original could not be converted, C<*lenp> will be 0, and the new string will
2605contain just a single C<NUL>. If the entire input string was converted,
2606C<*is_utf8p> is set to FALSE and C<*first_non_downgradable> is set to C<NULL>.
2607
2608Upon successful return, the number of variants in the converted portion of the
2609string can be computed by having saved the value of C<*lenp> before the call,
2610and subtracting the after-call value of C<*lenp> from it.
2611
2612=cut
2613
2614
2615*/
2616
2617U8 *
2618Perl_bytes_from_utf8_loc(const U8 *s, STRLEN *lenp, bool *is_utf8p, const U8** first_unconverted)
2619{
2620 U8 *d;
2621 const U8 *original = s;
2622 U8 *converted_start;
2623 const U8 *send = s + *lenp;
f9a63242 2624
976c1b08 2625 PERL_ARGS_ASSERT_BYTES_FROM_UTF8_LOC;
170a1c22 2626
976c1b08
KW
2627 if (! *is_utf8p) {
2628 if (first_unconverted) {
2629 *first_unconverted = NULL;
2630 }
2631
2632 return (U8 *) original;
2633 }
2634
2635 Newx(d, (*lenp) + 1, U8);
2636
2637 converted_start = d;
7299a045
KW
2638 while (s < send) {
2639 U8 c = *s++;
2640 if (! UTF8_IS_INVARIANT(c)) {
976c1b08
KW
2641
2642 /* Then it is multi-byte encoded. If the code point is above 0xFF,
2643 * have to stop now */
2644 if (UNLIKELY (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s - 1, send))) {
2645 if (first_unconverted) {
2646 *first_unconverted = s - 1;
2647 goto finish_and_return;
2648 }
2649 else {
2650 Safefree(converted_start);
2651 return (U8 *) original;
2652 }
2653 }
2654
7299a045
KW
2655 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
2656 s++;
38af28cf 2657 }
7299a045
KW
2658 *d++ = c;
2659 }
170a1c22 2660
976c1b08
KW
2661 /* Here, converted the whole of the input */
2662 *is_utf8p = FALSE;
2663 if (first_unconverted) {
2664 *first_unconverted = NULL;
170a1c22 2665 }
976c1b08
KW
2666
2667 finish_and_return:
46a08a6f
KW
2668 *d = '\0';
2669 *lenp = d - converted_start;
976c1b08
KW
2670
2671 /* Trim unused space */
2672 Renew(converted_start, *lenp + 1, U8);
2673
2674 return converted_start;
f9a63242
JH
2675}
2676
2677/*
87cea99e 2678=for apidoc bytes_to_utf8
6940069f 2679
09af0336 2680Converts a string C<s> of length C<*lenp> bytes from the native encoding into
ff97e5cf 2681UTF-8.
09af0336 2682Returns a pointer to the newly-created string, and sets C<*lenp> to
ff97e5cf 2683reflect the new length in bytes.
6940069f 2684
3bc0c78c 2685Upon successful return, the number of variants in the string can be computed by
23b37b12 2686having saved the value of C<*lenp> before the call, and subtracting it from the
3bc0c78c
KW
2687after-call value of C<*lenp>.
2688
75200dff 2689A C<NUL> character will be written after the end of the string.
2bbc8d55
SP
2690
2691If you want to convert to UTF-8 from encodings other than
2692the native (Latin1 or EBCDIC),
a1433954 2693see L</sv_recode_to_utf8>().
c9ada85f 2694
497711e7 2695=cut
6940069f
GS
2696*/
2697
2698U8*
09af0336 2699Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *lenp)
6940069f 2700{
09af0336 2701 const U8 * const send = s + (*lenp);
6940069f
GS
2702 U8 *d;
2703 U8 *dst;
7918f24d
NC
2704
2705 PERL_ARGS_ASSERT_BYTES_TO_UTF8;
96a5add6 2706 PERL_UNUSED_CONTEXT;
6940069f 2707
09af0336 2708 Newx(d, (*lenp) * 2 + 1, U8);
6940069f
GS
2709 dst = d;
2710
2711 while (s < send) {
55d09dc8
KW
2712 append_utf8_from_native_byte(*s, &d);
2713 s++;
6940069f 2714 }
2e11cf67 2715
6940069f 2716 *d = '\0';
09af0336 2717 *lenp = d-dst;
2e11cf67
KW
2718
2719 /* Trim unused space */
2720 Renew(dst, *lenp + 1, U8);
2721
6940069f
GS
2722 return dst;
2723}
2724
a0ed51b3 2725/*
624504c5
KW
2726 * Convert native (big-endian) UTF-16 to UTF-8. For reversed (little-endian),
2727 * use utf16_to_utf8_reversed().
a0ed51b3 2728 *
624504c5
KW
2729 * UTF-16 requires 2 bytes for every code point below 0x10000; otherwise 4 bytes.
2730 * UTF-8 requires 1-3 bytes for every code point below 0x1000; otherwise 4 bytes.
2731 * UTF-EBCDIC requires 1-4 bytes for every code point below 0x1000; otherwise 4-5 bytes.
2732 *
2733 * These functions don't check for overflow. The worst case is every code
2734 * point in the input is 2 bytes, and requires 4 bytes on output. (If the code
2735 * is never going to run in EBCDIC, it is 2 bytes requiring 3 on output.) Therefore the
2736 * destination must be pre-extended to 2 times the source length.
2737 *
2738 * Do not use in-place. We optimize for native, for obvious reasons. */
a0ed51b3
LW
2739
2740U8*
dea0fc0b 2741Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3 2742{
dea0fc0b
JH
2743 U8* pend;
2744 U8* dstart = d;
2745
7918f24d
NC
2746 PERL_ARGS_ASSERT_UTF16_TO_UTF8;
2747
dea0fc0b 2748 if (bytelen & 1)
56576a04
KW
2749 Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %" UVuf,
2750 (UV)bytelen);
dea0fc0b
JH
2751
2752 pend = p + bytelen;
2753
a0ed51b3 2754 while (p < pend) {
dea0fc0b
JH
2755 UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
2756 p += 2;
2d1545e5 2757 if (OFFUNI_IS_INVARIANT(uv)) {
56d37426 2758 *d++ = LATIN1_TO_NATIVE((U8) uv);
a0ed51b3
LW
2759 continue;
2760 }
56d37426
KW
2761 if (uv <= MAX_UTF8_TWO_BYTE) {
2762 *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv));
2763 *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv));
a0ed51b3
LW
2764 continue;
2765 }
ffd0a9d3 2766
46956fad
KW
2767#define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST
2768#define LAST_HIGH_SURROGATE 0xDBFF
2769#define FIRST_LOW_SURROGATE 0xDC00
2770#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
ffd0a9d3 2771#define FIRST_IN_PLANE1 0x10000
e23c50db
KW
2772
2773 /* This assumes that most uses will be in the first Unicode plane, not
2774 * needing surrogates */
2775 if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST
2776 && uv <= UNICODE_SURROGATE_LAST))
2777 {
2778 if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) {
2779 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
2780 }
2781 else {
01ea242b 2782 UV low = (p[0] << 8) + p[1];
e23c50db
KW
2783 if ( UNLIKELY(low < FIRST_LOW_SURROGATE)
2784 || UNLIKELY(low > LAST_LOW_SURROGATE))
2785 {
01ea242b 2786 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
e23c50db
KW
2787 }
2788 p += 2;
46956fad 2789 uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
ffd0a9d3 2790 + (low - FIRST_LOW_SURROGATE) + FIRST_IN_PLANE1;
01ea242b 2791 }
a0ed51b3 2792 }
56d37426
KW
2793#ifdef EBCDIC
2794 d = uvoffuni_to_utf8_flags(d, uv, 0);
2795#else
ffd0a9d3 2796 if (uv < FIRST_IN_PLANE1) {
eb160463
GS
2797 *d++ = (U8)(( uv >> 12) | 0xe0);
2798 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
2799 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
2800 continue;
2801 }
2802 else {
eb160463
GS
2803 *d++ = (U8)(( uv >> 18) | 0xf0);
2804 *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
2805 *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
2806 *d++ = (U8)(( uv & 0x3f) | 0x80);
a0ed51b3
LW
2807 continue;
2808 }
56d37426 2809#endif
a0ed51b3 2810 }
dea0fc0b 2811 *newlen = d - dstart;
a0ed51b3
LW
2812 return d;
2813}
2814
2815/* Note: this one is slightly destructive of the source. */
2816
2817U8*
dea0fc0b 2818Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
a0ed51b3
LW
2819{
2820 U8* s = (U8*)p;
d4c19fe8 2821 U8* const send = s + bytelen;
7918f24d
NC
2822
2823 PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
2824
e0ea5e2d 2825 if (bytelen & 1)
147e3846 2826 Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %" UVuf,
e0ea5e2d
NC
2827 (UV)bytelen);
2828
a0ed51b3 2829 while (s < send) {
d4c19fe8 2830 const U8 tmp = s[0];
a0ed51b3
LW
2831 s[0] = s[1];
2832 s[1] = tmp;
2833 s += 2;
2834 }
dea0fc0b 2835 return utf16_to_utf8(p, d, bytelen, newlen);
a0ed51b3
LW
2836}
2837
922e8cb4
KW
2838bool
2839Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
2840{
2841 U8 tmpbuf[UTF8_MAXBYTES+1];
2842 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2843 return _is_utf8_FOO_with_len(classnum, tmpbuf, tmpbuf + sizeof(tmpbuf));
922e8cb4
KW
2844}
2845
f9ae8fb6
JD
2846/* Internal function so we can deprecate the external one, and call
2847 this one from other deprecated functions in this file */
2848
f2645549
KW
2849bool
2850Perl__is_utf8_idstart(pTHX_ const U8 *p)
61b19385 2851{
f2645549 2852 PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
61b19385
KW
2853
2854 if (*p == '_')
2855 return TRUE;
f25ce844 2856 return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
61b19385
KW
2857}
2858
5092f92a 2859bool
eba68aa0
KW
2860Perl__is_uni_perl_idcont(pTHX_ UV c)
2861{
2862 U8 tmpbuf[UTF8_MAXBYTES+1];
2863 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2864 return _is_utf8_perl_idcont_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
eba68aa0
KW
2865}
2866
2867bool
f91dcd13
KW
2868Perl__is_uni_perl_idstart(pTHX_ UV c)
2869{
2870 U8 tmpbuf[UTF8_MAXBYTES+1];
2871 uvchr_to_utf8(tmpbuf, c);
da8c1a98 2872 return _is_utf8_perl_idstart_with_len(tmpbuf, tmpbuf + sizeof(tmpbuf));
f91dcd13
KW
2873}
2874
3a4c58c9 2875UV
56576a04
KW
2876Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp,
2877 const char S_or_s)
3a4c58c9
KW
2878{
2879 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 2880 * those, converting the result to UTF-8. The only difference between upper
3a4c58c9
KW
2881 * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
2882 * either "SS" or "Ss". Which one to use is passed into the routine in
2883 * 'S_or_s' to avoid a test */
2884
2885 UV converted = toUPPER_LATIN1_MOD(c);
2886
2887 PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
2888
2889 assert(S_or_s == 'S' || S_or_s == 's');
2890
6f2d5cbc 2891 if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for
f4cd282c 2892 characters in this range */
3a4c58c9
KW
2893 *p = (U8) converted;
2894 *lenp = 1;
2895 return converted;
2896 }
2897
2898 /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
2899 * which it maps to one of them, so as to only have to have one check for
2900 * it in the main case */
2901 if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
2902 switch (c) {
2903 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
2904 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
2905 break;
2906 case MICRO_SIGN:
2907 converted = GREEK_CAPITAL_LETTER_MU;
2908 break;
79e064b9
KW
2909#if UNICODE_MAJOR_VERSION > 2 \
2910 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
2911 && UNICODE_DOT_DOT_VERSION >= 8)
3a4c58c9
KW
2912 case LATIN_SMALL_LETTER_SHARP_S:
2913 *(p)++ = 'S';
2914 *p = S_or_s;
2915 *lenp = 2;
2916 return 'S';
79e064b9 2917#endif
3a4c58c9 2918 default:
56576a04
KW
2919 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect"
2920 " '%c' to map to '%c'",
2921 c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
e5964223 2922 NOT_REACHED; /* NOTREACHED */
3a4c58c9
KW
2923 }
2924 }
2925
2926 *(p)++ = UTF8_TWO_BYTE_HI(converted);
2927 *p = UTF8_TWO_BYTE_LO(converted);
2928 *lenp = 2;
2929
2930 return converted;
2931}
2932
50bda2c3
KW
2933/* Call the function to convert a UTF-8 encoded character to the specified case.
2934 * Note that there may be more than one character in the result.
2935 * INP is a pointer to the first byte of the input character
2936 * OUTP will be set to the first byte of the string of changed characters. It
2937 * needs to have space for UTF8_MAXBYTES_CASE+1 bytes
2938 * LENP will be set to the length in bytes of the string of changed characters
2939 *
56576a04
KW
2940 * The functions return the ordinal of the first character in the string of
2941 * OUTP */
2942#define CALL_UPPER_CASE(uv, s, d, lenp) \
2943 _to_utf8_case(uv, s, d, lenp, &PL_utf8_toupper, "ToUc", "")
2944#define CALL_TITLE_CASE(uv, s, d, lenp) \
2945 _to_utf8_case(uv, s, d, lenp, &PL_utf8_totitle, "ToTc", "")
2946#define CALL_LOWER_CASE(uv, s, d, lenp) \
2947 _to_utf8_case(uv, s, d, lenp, &PL_utf8_tolower, "ToLc", "")
50bda2c3 2948
b9992569
KW
2949/* This additionally has the input parameter 'specials', which if non-zero will
2950 * cause this to use the specials hash for folding (meaning get full case
50bda2c3 2951 * folding); otherwise, when zero, this implies a simple case fold */
56576a04
KW
2952#define CALL_FOLD_CASE(uv, s, d, lenp, specials) \
2953_to_utf8_case(uv, s, d, lenp, &PL_utf8_tofold, "ToCf", (specials) ? "" : NULL)
c3fd2246 2954
84afefe6
JH
2955UV
2956Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 2957{
a1433954
KW
2958 /* Convert the Unicode character whose ordinal is <c> to its uppercase
2959 * version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
2960 * Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
c3fd2246
KW
2961 * the changed version may be longer than the original character.
2962 *
2963 * The ordinal of the first character of the changed version is returned
2964 * (but note, as explained above, that there may be more.) */
2965
7918f24d
NC
2966 PERL_ARGS_ASSERT_TO_UNI_UPPER;
2967
3a4c58c9
KW
2968 if (c < 256) {
2969 return _to_upper_title_latin1((U8) c, p, lenp, 'S');
2970 }
2971
0ebc6274 2972 uvchr_to_utf8(p, c);
b9992569 2973 return CALL_UPPER_CASE(c, p, p, lenp);
a0ed51b3
LW
2974}
2975
84afefe6
JH
2976UV
2977Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 2978{
7918f24d
NC
2979 PERL_ARGS_ASSERT_TO_UNI_TITLE;
2980
3a4c58c9
KW
2981 if (c < 256) {
2982 return _to_upper_title_latin1((U8) c, p, lenp, 's');
2983 }
2984
0ebc6274 2985 uvchr_to_utf8(p, c);
b9992569 2986 return CALL_TITLE_CASE(c, p, p, lenp);
a0ed51b3
LW
2987}
2988
afc16117 2989STATIC U8
eaf412bf 2990S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp, const char dummy)
afc16117
KW
2991{
2992 /* We have the latin1-range values compiled into the core, so just use
4a4088c4 2993 * those, converting the result to UTF-8. Since the result is always just
a1433954 2994 * one character, we allow <p> to be NULL */
afc16117
KW
2995
2996 U8 converted = toLOWER_LATIN1(c);
2997
eaf412bf
KW
2998 PERL_UNUSED_ARG(dummy);
2999
afc16117 3000 if (p != NULL) {
6f2d5cbc 3001 if (NATIVE_BYTE_IS_INVARIANT(converted)) {
afc16117
KW
3002 *p = converted;
3003 *lenp = 1;
3004 }
3005 else {
430c9760
KW
3006 /* Result is known to always be < 256, so can use the EIGHT_BIT
3007 * macros */
3008 *p = UTF8_EIGHT_BIT_HI(converted);
3009 *(p+1) = UTF8_EIGHT_BIT_LO(converted);
afc16117
KW
3010 *lenp = 2;
3011 }
3012 }
3013 return converted;
3014}
3015
84afefe6
JH
3016UV
3017Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
a0ed51b3 3018{
7918f24d
NC
3019 PERL_ARGS_ASSERT_TO_UNI_LOWER;
3020
afc16117 3021 if (c < 256) {
eaf412bf 3022 return to_lower_latin1((U8) c, p, lenp, 0 /* 0 is a dummy arg */ );
bca00c02
KW
3023 }
3024
afc16117 3025 uvchr_to_utf8(p, c);
b9992569 3026 return CALL_LOWER_CASE(c, p, p, lenp);
a0ed51b3
LW
3027}
3028
84afefe6 3029UV
56576a04
KW
3030Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp,
3031 const unsigned int flags)
a1dde8de 3032{
51910141 3033 /* Corresponds to to_lower_latin1(); <flags> bits meanings:
1ca267a5 3034 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
51910141 3035 * FOLD_FLAGS_FULL iff full folding is to be used;
1ca267a5
KW
3036 *
3037 * Not to be used for locale folds
51910141 3038 */
f673fad4 3039
a1dde8de
KW
3040 UV converted;
3041
3042 PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
81611534 3043 PERL_UNUSED_CONTEXT;
a1dde8de 3044
1ca267a5
KW
3045 assert (! (flags & FOLD_FLAGS_LOCALE));
3046
659a7c2d 3047 if (UNLIKELY(c == MICRO_SIGN)) {
a1dde8de
KW
3048 converted = GREEK_SMALL_LETTER_MU;
3049 }
9b63e895
KW
3050#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
3051 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
3052 || UNICODE_DOT_DOT_VERSION > 0)
659a7c2d
KW
3053 else if ( (flags & FOLD_FLAGS_FULL)
3054 && UNLIKELY(c == LATIN_SMALL_LETTER_SHARP_S))
3055 {
1ca267a5
KW
3056 /* If can't cross 127/128 boundary, can't return "ss"; instead return
3057 * two U+017F characters, as fc("\df") should eq fc("\x{17f}\x{17f}")
3058 * under those circumstances. */
3059 if (flags & FOLD_FLAGS_NOMIX_ASCII) {
3060 *lenp = 2 * sizeof(LATIN_SMALL_LETTER_LONG_S_UTF8) - 2;
3061 Copy(LATIN_SMALL_LETTER_LONG_S_UTF8 LATIN_SMALL_LETTER_LONG_S_UTF8,
3062 p, *lenp, U8);
3063 return LATIN_SMALL_LETTER_LONG_S;
3064 }
3065 else {
4f489194
KW
3066 *(p)++ = 's';
3067 *p = 's';
3068 *lenp = 2;
3069 return 's';
1ca267a5 3070 }
a1dde8de 3071 }
9b63e895 3072#endif
a1dde8de
KW
3073 else { /* In this range the fold of all other characters is their lower
3074 case */
3075 converted = toLOWER_LATIN1(c);
3076 }
3077
6f2d5cbc 3078 if (UVCHR_IS_INVARIANT(converted)) {
a1dde8de
KW
3079 *p = (U8) converted;
3080 *lenp = 1;
3081 }
3082 else {
3083 *(p)++ = UTF8_TWO_BYTE_HI(converted);
3084 *p = UTF8_TWO_BYTE_LO(converted);
3085 *lenp = 2;
3086 }
3087
3088 return converted;
3089}
3090
3091UV
31f05a37 3092Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags)
84afefe6 3093{
4b593389 3094
a0270393
KW
3095 /* Not currently externally documented, and subject to change
3096 * <flags> bits meanings:
3097 * FOLD_FLAGS_FULL iff full folding is to be used;
31f05a37
KW
3098 * FOLD_FLAGS_LOCALE is set iff the rules from the current underlying
3099 * locale are to be used.
a0270393
KW
3100 * FOLD_FLAGS_NOMIX_ASCII iff non-ASCII to ASCII folds are prohibited
3101 */
4b593389 3102
36bb2ab6 3103 PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
7918f24d 3104
780fcc9f
KW
3105 if (flags & FOLD_FLAGS_LOCALE) {
3106 /* Treat a UTF-8 locale as not being in locale at all */
3107 if (IN_UTF8_CTYPE_LOCALE) {
3108 flags &= ~FOLD_FLAGS_LOCALE;
3109 }
3110 else {
3111 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
e7b7ac46 3112 goto needs_full_generality;
780fcc9f 3113 }
31f05a37
KW
3114 }
3115
a1dde8de 3116 if (c < 256) {
e7b7ac46 3117 return _to_fold_latin1((U8) c, p, lenp,
31f05a37 3118 flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
a1dde8de
KW
3119 }
3120
2f306ab9 3121 /* Here, above 255. If no special needs, just use the macro */
a0270393
KW
3122 if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
3123 uvchr_to_utf8(p, c);
b9992569 3124 return CALL_FOLD_CASE(c, p, p, lenp, flags & FOLD_FLAGS_FULL);
a0270393 3125 }
567b353c 3126 else { /* Otherwise, _toFOLD_utf8_flags has the intelligence to deal with
a0270393
KW
3127 the special flags. */
3128 U8 utf8_c[UTF8_MAXBYTES + 1];
e7b7ac46
KW
3129
3130 needs_full_generality:
a0270393 3131 uvchr_to_utf8(utf8_c, c);
56576a04
KW
3132 return _toFOLD_utf8_flags(utf8_c, utf8_c + sizeof(utf8_c),
3133 p, lenp, flags);
a0270393 3134 }
84afefe6
JH
3135}
3136
26483009 3137PERL_STATIC_INLINE bool
5141f98e 3138S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
f25ce844 3139 const char *const swashname, SV* const invlist)
bde6a22d 3140{
ea317ccb
KW
3141 /* returns a boolean giving whether or not the UTF8-encoded character that
3142 * starts at <p> is in the swash indicated by <swashname>. <swash>
3143 * contains a pointer to where the swash indicated by <swashname>
3144 * is to be stored; which this routine will do, so that future calls will
f25ce844
KW
3145 * look at <*swash> and only generate a swash if it is not null. <invlist>
3146 * is NULL or an inversion list that defines the swash. If not null, it
3147 * saves time during initialization of the swash.
ea317ccb
KW
3148 *
3149 * Note that it is assumed that the buffer length of <p> is enough to
3150 * contain all the bytes that comprise the character. Thus, <*p> should
3151 * have been checked before this call for mal-formedness enough to assure
3152 * that. */
3153
7918f24d
NC
3154 PERL_ARGS_ASSERT_IS_UTF8_COMMON;
3155
492a624f 3156 /* The API should have included a length for the UTF-8 character in <p>,
28123549 3157 * but it doesn't. We therefore assume that p has been validated at least
492a624f
KW
3158 * as far as there being enough bytes available in it to accommodate the
3159 * character without reading beyond the end, and pass that number on to the
3160 * validating routine */
6302f837 3161 if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
86ae6e94 3162 _force_out_malformed_utf8_message(p, p + UTF8SKIP(p),
99a765e9 3163 _UTF8_NO_CONFIDENCE_IN_CURLEN,
86ae6e94
KW
3164 1 /* Die */ );
3165 NOT_REACHED; /* NOTREACHED */
28123549 3166 }
86ae6e94 3167
87367d5f
KW
3168 if (!*swash) {
3169 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
f25ce844
KW
3170 *swash = _core_swash_init("utf8",
3171
3172 /* Only use the name if there is no inversion
3173 * list; otherwise will go out to disk */
3174 (invlist) ? "" : swashname,
3175
3176 &PL_sv_undef, 1, 0, invlist, &flags);
87367d5f 3177 }
28123549 3178
bde6a22d
NC
3179 return swash_fetch(*swash, p, TRUE) != 0;
3180}
3181
da8c1a98 3182PERL_STATIC_INLINE bool
56576a04
KW
3183S_is_utf8_common_with_len(pTHX_ const U8 *const p, const U8 * const e,
3184 SV **swash, const char *const swashname,
3185 SV* const invlist)
da8c1a98
KW
3186{
3187 /* returns a boolean giving whether or not the UTF8-encoded character that
3188 * starts at <p>, and extending no further than <e - 1> is in the swash
3189 * indicated by <swashname>. <swash> contains a pointer to where the swash
3190 * indicated by <swashname> is to be stored; which this routine will do, so
3191 * that future calls will look at <*swash> and only generate a swash if it
3192 * is not null. <invlist> is NULL or an inversion list that defines the
3193 * swash. If not null, it saves time during initialization of the swash.
3194 */
3195
3196 PERL_ARGS_ASSERT_IS_UTF8_COMMON_WITH_LEN;
3197
3198 if (! isUTF8_CHAR(p, e)) {
3199 _force_out_malformed_utf8_message(p, e, 0, 1);
3200 NOT_REACHED; /* NOTREACHED */
3201 }
3202
3203 if (!*swash) {
3204 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
3205 *swash = _core_swash_init("utf8",
3206
3207 /* Only use the name if there is no inversion
3208 * list; otherwise will go out to disk */
3209 (invlist) ? "" : swashname,
3210
3211 &PL_sv_undef, 1, 0, invlist, &flags);
3212 }
3213
3214 return swash_fetch(*swash, p, TRUE) != 0;
3215}
3216
34aeb2e9
KW
3217STATIC void
3218S_warn_on_first_deprecated_use(pTHX_ const char * const name,
3219 const char * const alternative,
3220 const bool use_locale,
3221 const char * const file,
3222 const unsigned line)
3223{
3224 const char * key;
3225
3226 PERL_ARGS_ASSERT_WARN_ON_FIRST_DEPRECATED_USE;
3227
3228 if (ckWARN_d(WARN_DEPRECATED)) {
3229
3230 key = Perl_form(aTHX_ "%s;%d;%s;%d", name, use_locale, file, line);
3231 if (! hv_fetch(PL_seen_deprecated_macro, key, strlen(key), 0)) {
3232 if (! PL_seen_deprecated_macro) {
3233 PL_seen_deprecated_macro = newHV();
3234 }
3235 if (! hv_store(PL_seen_deprecated_macro, key,
3236 strlen(key), &PL_sv_undef, 0))
3237 {
3238 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3239 }
3240
c44e9413 3241 if (instr(file, "mathoms.c")) {
607313a1
KW
3242 Perl_warner(aTHX_ WARN_DEPRECATED,
3243 "In %s, line %d, starting in Perl v5.30, %s()"
3244 " will be removed. Avoid this message by"
3245 " converting to use %s().\n",
3246 file, line, name, alternative);
3247 }
3248 else {
34aeb2e9
KW
3249 Perl_warner(aTHX_ WARN_DEPRECATED,
3250 "In %s, line %d, starting in Perl v5.30, %s() will"
3251 " require an additional parameter. Avoid this"
3252 " message by converting to use %s().\n",
3253 file, line, name, alternative);
607313a1 3254 }
34aeb2e9
KW
3255 }
3256 }
3257}
3258
bde6a22d 3259bool
34aeb2e9 3260Perl__is_utf8_FOO(pTHX_ U8 classnum,
be99e2c2 3261 const U8 * const p,
34aeb2e9
KW
3262 const char * const name,
3263 const char * const alternative,
3264 const bool use_utf8,
3265 const bool use_locale,
3266 const char * const file,
3267 const unsigned line)
922e8cb4 3268{
922e8cb4
KW
3269 PERL_ARGS_ASSERT__IS_UTF8_FOO;
3270
34aeb2e9
KW
3271 warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
3272
3273 if (use_utf8 && UTF8_IS_ABOVE_LATIN1(*p)) {
34aeb2e9
KW
3274
3275 switch (classnum) {
3276 case _CC_WORDCHAR:
3277 case _CC_DIGIT:
3278 case _CC_ALPHA:
3279 case _CC_LOWER:
3280 case _CC_UPPER:
3281 case _CC_PUNCT:
3282 case _CC_PRINT:
3283 case _CC_ALPHANUMERIC:
3284 case _CC_GRAPH:
3285 case _CC_CASED:
3286
3287 return is_utf8_common(p,
3288 &PL_utf8_swash_ptrs[classnum],
3289 swash_property_names[classnum],
3290 PL_XPosix_ptrs[classnum]);
3291
3292 case _CC_SPACE:
3293 return is_XPERLSPACE_high(p);
3294 case _CC_BLANK:
3295 return is_HORIZWS_high(p);
3296 case _CC_XDIGIT:
3297 return is_XDIGIT_high(p);
3298 case _CC_CNTRL:
3299 return 0;
3300 case _CC_ASCII:
3301 return 0;
3302 case _CC_VERTSPACE:
3303 return is_VERTWS_high(p);
3304 case _CC_IDFIRST:
3305 if (! PL_utf8_perl_idstart) {
22f0498f
KW
3306 PL_utf8_perl_idstart
3307 = _new_invlist_C_array(_Perl_IDStart_invlist);
34aeb2e9 3308 }
22f0498f
KW
3309 return is_utf8_common(p, &PL_utf8_perl_idstart,
3310 "_Perl_IDStart", NULL);
34aeb2e9
KW
3311 case _CC_IDCONT:
3312 if (! PL_utf8_perl_idcont) {
22f0498f
KW
3313 PL_utf8_perl_idcont
3314 = _new_invlist_C_array(_Perl_IDCont_invlist);
34aeb2e9 3315 }
22f0498f
KW
3316 return is_utf8_common(p, &PL_utf8_perl_idcont,
3317 "_Perl_IDCont", NULL);
34aeb2e9
KW
3318 }
3319 }
3320
3321 /* idcont is the same as wordchar below 256 */
3322 if (classnum == _CC_IDCONT) {
3323 classnum = _CC_WORDCHAR;
3324 }
3325 else if (classnum == _CC_IDFIRST) {
3326 if (*p == '_') {
3327 return TRUE;
3328 }
3329 classnum = _CC_ALPHA;
3330 }
3331
3332 if (! use_locale) {
3333 if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
3334 return _generic_isCC(*p, classnum);
3335 }
922e8cb4 3336
34aeb2e9
KW
3337 return _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )), classnum);
3338 }
3339 else {
3340 if (! use_utf8 || UTF8_IS_INVARIANT(*p)) {
3341 return isFOO_lc(classnum, *p);
3342 }
3343
3344 return isFOO_lc(classnum, EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p + 1 )));
3345 }
3346
3347 NOT_REACHED; /* NOTREACHED */
922e8cb4
KW
3348}
3349
3350bool
da8c1a98
KW
3351Perl__is_utf8_FOO_with_len(pTHX_ const U8 classnum, const U8 *p,
3352 const U8 * const e)
3353{
3354 PERL_ARGS_ASSERT__IS_UTF8_FOO_WITH_LEN;
3355
3356 assert(classnum < _FIRST_NON_SWASH_CC);
3357
3358 return is_utf8_common_with_len(p,
3359 e,
3360 &PL_utf8_swash_ptrs[classnum],
3361 swash_property_names[classnum],
3362 PL_XPosix_ptrs[classnum]);
3363}
3364
3365bool
da8c1a98
KW
3366Perl__is_utf8_perl_idstart_with_len(pTHX_ const U8 *p, const U8 * const e)
3367{
3368 SV* invlist = NULL;
3369
3370 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART_WITH_LEN;
3371
3372 if (! PL_utf8_perl_idstart) {
3373 invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
3374 }
3375 return is_utf8_common_with_len(p, e, &PL_utf8_perl_idstart,
3376 "_Perl_IDStart", invlist);
3377}
3378
3379bool
f2645549 3380Perl__is_utf8_xidstart(pTHX_ const U8 *p)
c11ff943 3381{
f2645549 3382 PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
c11ff943
KW
3383
3384 if (*p == '_')
3385 return TRUE;
f25ce844 3386 return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
c11ff943
KW
3387}
3388
3389bool
da8c1a98
KW
3390Perl__is_utf8_perl_idcont_with_len(pTHX_ const U8 *p, const U8 * const e)
3391{
3392 SV* invlist = NULL;
3393
3394 PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT_WITH_LEN;
3395
3396 if (! PL_utf8_perl_idcont) {
3397 invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
3398 }
3399 return is_utf8_common_with_len(p, e, &PL_utf8_perl_idcont,
3400 "_Perl_IDCont", invlist);
3401}
3402
3403bool
f2645549 3404Perl__is_utf8_idcont(pTHX_ const U8 *p)
82686b01 3405{
f2645549 3406 PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
7918f24d 3407
f25ce844 3408 return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
a0ed51b3
LW
3409}
3410
3411bool
f2645549 3412Perl__is_utf8_xidcont(pTHX_ const U8 *p)
c11ff943 3413{
f2645549 3414 PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
c11ff943 3415
f25ce844 3416 return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
c11ff943
KW
3417}
3418
3419bool
7dbf68d2
KW
3420Perl__is_utf8_mark(pTHX_ const U8 *p)
3421{
7dbf68d2
KW
3422 PERL_ARGS_ASSERT__IS_UTF8_MARK;
3423
f25ce844 3424 return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
7dbf68d2
KW
3425}
3426
b9992569 3427 /* change namve uv1 to 'from' */
6a4a25f4 3428STATIC UV
b9992569
KW
3429S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
3430 SV **swashp, const char *normal, const char *special)
3431{
0134edef 3432 STRLEN len = 0;
7918f24d 3433
b9992569 3434 PERL_ARGS_ASSERT__TO_UTF8_CASE;
7918f24d 3435
36eaa811
KW
3436 /* For code points that don't change case, we already know that the output
3437 * of this function is the unchanged input, so we can skip doing look-ups
3438 * for them. Unfortunately the case-changing code points are scattered
3439 * around. But there are some long consecutive ranges where there are no
3440 * case changing code points. By adding tests, we can eliminate the lookup
3441 * for all the ones in such ranges. This is currently done here only for
3442 * just a few cases where the scripts are in common use in modern commerce
3443 * (and scripts adjacent to those which can be included without additional
3444 * tests). */
3445
3446 if (uv1 >= 0x0590) {
3447 /* This keeps from needing further processing the code points most
3448 * likely to be used in the following non-cased scripts: Hebrew,
3449 * Arabic, Syriac, Thaana, NKo, Samaritan, Mandaic, Devanagari,
3450 * Bengali, Gurmukhi, Gujarati, Oriya, Tamil, Telugu, Kannada,
3451 * Malayalam, Sinhala, Thai, Lao, Tibetan, Myanmar */
3452 if (uv1 < 0x10A0) {
3453 goto cases_to_self;
3454 }
3455
3456 /* The following largish code point ranges also don't have case
3457 * changes, but khw didn't think they warranted extra tests to speed
3458 * them up (which would slightly slow down everything else above them):
3459 * 1100..139F Hangul Jamo, Ethiopic
3460 * 1400..1CFF Unified Canadian Aboriginal Syllabics, Ogham, Runic,
3461 * Tagalog, Hanunoo, Buhid, Tagbanwa, Khmer, Mongolian,
3462 * Limbu, Tai Le, New Tai Lue, Buginese, Tai Tham,
3463 * Combining Diacritical Marks Extended, Balinese,
3464 * Sundanese, Batak, Lepcha, Ol Chiki
3465 * 2000..206F General Punctuation
3466 */
3467
3468 if (uv1 >= 0x2D30) {
3469
3470 /* This keeps the from needing further processing the code points
3471 * most likely to be used in the following non-cased major scripts:
3472 * CJK, Katakana, Hiragana, plus some less-likely scripts.
3473 *
3474 * (0x2D30 above might have to be changed to 2F00 in the unlikely
3475 * event that Unicode eventually allocates the unused block as of
3476 * v8.0 2FE0..2FEF to code points that are cased. khw has verified
3477 * that the test suite will start having failures to alert you
3478 * should that happen) */
3479 if (uv1 < 0xA640) {
3480 goto cases_to_self;
3481 }
3482
3483 if (uv1 >= 0xAC00) {
3484 if (UNLIKELY(UNICODE_IS_SURROGATE(uv1))) {
5af9bc97
KW
3485 if (ckWARN_d(WARN_SURROGATE)) {
3486 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
3487 Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
56576a04
KW
3488 "Operation \"%s\" returns its argument for"
3489 " UTF-16 surrogate U+%04" UVXf, desc, uv1);
5af9bc97
KW
3490 }
3491 goto cases_to_self;
3492 }
36eaa811
KW
3493
3494 /* AC00..FAFF Catches Hangul syllables and private use, plus
3495 * some others */
3496 if (uv1 < 0xFB00) {
3497 goto cases_to_self;
3498
3499 }
3500
5af9bc97 3501 if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
d22ec717
KW
3502 if (UNLIKELY(uv1 > MAX_EXTERNALLY_LEGAL_CP)) {
3503 Perl_croak(aTHX_ cp_above_legal_max, uv1,
3504 MAX_EXTERNALLY_LEGAL_CP);
5af9bc97
KW
3505 }
3506 if (ckWARN_d(WARN_NON_UNICODE)) {
3507 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
3508 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
56576a04
KW
3509 "Operation \"%s\" returns its argument for"
3510 " non-Unicode code point 0x%04" UVXf, desc, uv1);
5af9bc97
KW
3511 }
3512 goto cases_to_self;
3513 }
3bfc1e70
KW
3514#ifdef HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C
3515 if (UNLIKELY(uv1
3516 > HIGHEST_CASE_CHANGING_CP_FOR_USE_ONLY_BY_UTF8_DOT_C))
3517 {
3518
56576a04
KW
3519 /* As of Unicode 10.0, this means we avoid swash creation
3520 * for anything beyond high Plane 1 (below emojis) */
3bfc1e70
KW
3521 goto cases_to_self;
3522 }
3523#endif
36eaa811
KW
3524 }
3525 }
9ae3ac1a 3526
36eaa811
KW
3527 /* Note that non-characters are perfectly legal, so no warning should
3528 * be given. There are so few of them, that it isn't worth the extra
3529 * tests to avoid swash creation */
9ae3ac1a
KW
3530 }
3531
0134edef 3532 if (!*swashp) /* load on-demand */
56576a04
KW
3533 *swashp = _core_swash_init("utf8", normal, &PL_sv_undef,
3534 4, 0, NULL, NULL);
0134edef 3535
a6f87d8c 3536 if (special) {
0134edef 3537 /* It might be "special" (sometimes, but not always,
2a37f04d 3538 * a multicharacter mapping) */
4a8240a3 3539 HV *hv = NULL;
b08cf34e
JH
3540 SV **svp;
3541
4a8240a3
KW
3542 /* If passed in the specials name, use that; otherwise use any
3543 * given in the swash */
3544 if (*special != '\0') {
3545 hv = get_hv(special, 0);
3546 }
3547 else {
3548 svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0);
3549 if (svp) {
3550 hv = MUTABLE_HV(SvRV(*svp));
3551 }
3552 }
3553
176fe009 3554 if (hv
5f560d8a 3555 && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
176fe009
KW
3556 && (*svp))
3557 {
cfd0369c 3558 const char *s;
47654450 3559
cfd0369c 3560 s = SvPV_const(*svp, len);
47654450 3561 if (len == 1)
f4cd282c 3562 /* EIGHTBIT */
c80e42f3 3563 len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp;
2a37f04d 3564 else {
d2dcd0fb 3565 Copy(s, ustrp, len, U8);
29e98929 3566 }
983ffd37 3567 }
0134edef
JH
3568 }
3569
3570 if (!len && *swashp) {
4a4088c4 3571 const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
d4c19fe8 3572
0134edef
JH
3573 if (uv2) {
3574 /* It was "normal" (a single character mapping). */
f4cd282c 3575 len = uvchr_to_utf8(ustrp, uv2) - ustrp;
2a37f04d
JH
3576 }
3577 }
1feea2c7 3578
cbe07460
KW
3579 if (len) {
3580 if (lenp) {
3581 *lenp = len;
3582 }
3583 return valid_utf8_to_uvchr(ustrp, 0);
3584 }
3585
3586 /* Here, there was no mapping defined, which means that the code point maps
3587 * to itself. Return the inputs */
e24dfe9c 3588 cases_to_self:
bfdf22ec 3589 len = UTF8SKIP(p);
ca9fab46
KW
3590 if (p != ustrp) { /* Don't copy onto itself */
3591 Copy(p, ustrp, len, U8);
3592 }
0134edef 3593
2a37f04d
JH
3594 if (lenp)
3595 *lenp = len;
3596
f4cd282c 3597 return uv1;
cbe07460 3598
a0ed51b3
LW
3599}
3600
051a06d4 3601STATIC UV
56576a04
KW
3602S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result,
3603 U8* const ustrp, STRLEN *lenp)
051a06d4 3604{
4a4088c4 3605 /* This is called when changing the case of a UTF-8-encoded character above
31f05a37
KW
3606 * the Latin1 range, and the operation is in a non-UTF-8 locale. If the
3607 * result contains a character that crosses the 255/256 boundary, disallow
3608 * the change, and return the original code point. See L<perlfunc/lc> for
3609 * why;
051a06d4 3610 *
a1433954
KW
3611 * p points to the original string whose case was changed; assumed
3612 * by this routine to be well-formed
051a06d4 3613 * result the code point of the first character in the changed-case string
56576a04
KW
3614 * ustrp points to the changed-case string (<result> represents its
3615 * first char)
051a06d4
KW
3616 * lenp points to the length of <ustrp> */
3617
3618 UV original; /* To store the first code point of <p> */
3619
3620 PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
3621
a4f12ed7 3622 assert(UTF8_IS_ABOVE_LATIN1(*p));
051a06d4
KW
3623
3624 /* We know immediately if the first character in the string crosses the
3625 * boundary, so can skip */
3626 if (result > 255) {
3627
3628 /* Look at every character in the result; if any cross the
3629 * boundary, the whole thing is disallowed */
3630 U8* s = ustrp + UTF8SKIP(ustrp);
3631 U8* e = ustrp + *lenp;
3632 while (s < e) {
a4f12ed7 3633 if (! UTF8_IS_ABOVE_LATIN1(*s)) {
051a06d4
KW
3634 goto bad_crossing;
3635 }
3636 s += UTF8SKIP(s);
3637 }
3638
613abc6d
KW
3639 /* Here, no characters crossed, result is ok as-is, but we warn. */
3640 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p));
051a06d4
KW
3641 return result;
3642 }
3643
7b52d656 3644 bad_crossing:
051a06d4
KW
3645
3646 /* Failed, have to return the original */
4b88fb76 3647 original = valid_utf8_to_uvchr(p, lenp);
ab0b796c
KW
3648
3649 /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
3650 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
56576a04
KW
3651 "Can't do %s(\"\\x{%" UVXf "}\") on non-UTF-8"
3652 " locale; resolved to \"\\x{%" UVXf "}\".",
357aadde 3653 OP_DESC(PL_op),
ab0b796c
KW
3654 original,
3655 original);
051a06d4
KW
3656 Copy(p, ustrp, *lenp, char);
3657 return original;
3658}
3659
607313a1
KW
3660STATIC U32
3661S_check_and_deprecate(pTHX_ const U8 *p,
3662 const U8 **e,
3663 const unsigned int type, /* See below */
3664 const bool use_locale, /* Is this a 'LC_'
3665 macro call? */
3666 const char * const file,
3667 const unsigned line)
3668{
3669 /* This is a temporary function to deprecate the unsafe calls to the case
3670 * changing macros and functions. It keeps all the special stuff in just
3671 * one place.
3672 *
3673 * It updates *e with the pointer to the end of the input string. If using
3674 * the old-style macros, *e is NULL on input, and so this function assumes
3675 * the input string is long enough to hold the entire UTF-8 sequence, and
3676 * sets *e accordingly, but it then returns a flag to pass the
3677 * utf8n_to_uvchr(), to tell it that this size is a guess, and to avoid
3678 * using the full length if possible.
3679 *
3680 * It also does the assert that *e > p when *e is not NULL. This should be
3681 * migrated to the callers when this function gets deleted.
3682 *
3683 * The 'type' parameter is used for the caller to specify which case
3684 * changing function this is called from: */
3685
3686# define DEPRECATE_TO_UPPER 0
3687# define DEPRECATE_TO_TITLE 1
3688# define DEPRECATE_TO_LOWER 2
3689# define DEPRECATE_TO_FOLD 3
3690
3691 U32 utf8n_flags = 0;
3692 const char * name;
3693 const char * alternative;
3694
3695 PERL_ARGS_ASSERT_CHECK_AND_DEPRECATE;
3696
3697 if (*e == NULL) {
3698 utf8n_flags = _UTF8_NO_CONFIDENCE_IN_CURLEN;
3699 *e = p + UTF8SKIP(p);
3700
3701 /* For mathoms.c calls, we use the function name we know is stored
c44e9413 3702 * there. It could be part of a larger path */
607313a1 3703 if (type == DEPRECATE_TO_UPPER) {
c44e9413 3704 name = instr(file, "mathoms.c")
607313a1
KW
3705 ? "to_utf8_upper"
3706 : "toUPPER_utf8";
3707 alternative = "toUPPER_utf8_safe";
3708 }
3709 else if (type == DEPRECATE_TO_TITLE) {
c44e9413 3710 name = instr(file, "mathoms.c")
607313a1
KW
3711 ? "to_utf8_title"
3712 : "toTITLE_utf8";
3713 alternative = "toTITLE_utf8_safe";
3714 }
3715 else if (type == DEPRECATE_TO_LOWER) {
c44e9413 3716 name = instr(file, "mathoms.c")
607313a1
KW
3717 ? "to_utf8_lower"
3718 : "toLOWER_utf8";
3719 alternative = "toLOWER_utf8_safe";
3720 }
3721 else if (type == DEPRECATE_TO_FOLD) {
c44e9413 3722 name = instr(file, "mathoms.c")
607313a1
KW
3723 ? "to_utf8_fold"
3724 : "toFOLD_utf8";
3725 alternative = "toFOLD_utf8_safe";
3726 }
3727 else Perl_croak(aTHX_ "panic: Unexpected case change type");
3728
3729 warn_on_first_deprecated_use(name, alternative, use_locale, file, line);
3730 }
3731 else {
3732 assert (p < *e);
3733 }
3734
3735 return utf8n_flags;
3736}
3737
eaf412bf
KW
3738/* The process for changing the case is essentially the same for the four case
3739 * change types, except there are complications for folding. Otherwise the
3740 * difference is only which case to change to. To make sure that they all do
3741 * the same thing, the bodies of the functions are extracted out into the
3742 * following two macros. The functions are written with the same variable
3743 * names, and these are known and used inside these macros. It would be
3744 * better, of course, to have inline functions to do it, but since different
3745 * macros are called, depending on which case is being changed to, this is not
3746 * feasible in C (to khw's knowledge). Two macros are created so that the fold
3747 * function can start with the common start macro, then finish with its special
3748 * handling; while the other three cases can just use the common end macro.