This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8_to_uvchr_buf() make behavior match docs
[perl5.git] / inline.h
CommitLineData
25468daa
FC
1/* inline.h
2 *
3 * Copyright (C) 2012 by Larry Wall and others
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8ed185f9
KW
8 * This file contains tables and code adapted from
9 * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
10 * copyright notice:
11
12Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
13
14Permission is hereby granted, free of charge, to any person obtaining a copy of
15this software and associated documentation files (the "Software"), to deal in
16the Software without restriction, including without limitation the rights to
17use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
18of the Software, and to permit persons to whom the Software is furnished to do
19so, subject to the following conditions:
20
21The above copyright notice and this permission notice shall be included in all
22copies or substantial portions of the Software.
23
24THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
25IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
26FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
27AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
29OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
30SOFTWARE.
31
32 *
25468daa 33 * This file is a home for static inline functions that cannot go in other
e15e54ff 34 * header files, because they depend on proto.h (included after most other
25468daa
FC
35 * headers) or struct definitions.
36 *
37 * Each section names the header file that the functions "belong" to.
38 */
27669aa4 39
be3a7a5d
KW
40/* ------------------------------- av.h ------------------------------- */
41
c70927a6 42PERL_STATIC_INLINE SSize_t
be3a7a5d
KW
43S_av_top_index(pTHX_ AV *av)
44{
45 PERL_ARGS_ASSERT_AV_TOP_INDEX;
46 assert(SvTYPE(av) == SVt_PVAV);
47
48 return AvFILL(av);
49}
50
1afe1db1
FC
51/* ------------------------------- cv.h ------------------------------- */
52
ae77754a
FC
53PERL_STATIC_INLINE GV *
54S_CvGV(pTHX_ CV *sv)
55{
56 return CvNAMED(sv)
57 ? Perl_cvgv_from_hek(aTHX_ sv)
58 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
59}
60
1afe1db1
FC
61PERL_STATIC_INLINE I32 *
62S_CvDEPTHp(const CV * const sv)
63{
64 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
8de47657 65 return &((XPVCV*)SvANY(sv))->xcv_depth;
1afe1db1
FC
66}
67
d16269d8
PM
68/*
69 CvPROTO returns the prototype as stored, which is not necessarily what
70 the interpreter should be using. Specifically, the interpreter assumes
71 that spaces have been stripped, which has been the case if the prototype
72 was added by toke.c, but is generally not the case if it was added elsewhere.
73 Since we can't enforce the spacelessness at assignment time, this routine
74 provides a temporary copy at parse time with spaces removed.
75 I<orig> is the start of the original buffer, I<len> is the length of the
76 prototype and will be updated when this returns.
77 */
78
5b67adb8 79#ifdef PERL_CORE
d16269d8
PM
80PERL_STATIC_INLINE char *
81S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
82{
83 SV * tmpsv;
84 char * tmps;
85 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
86 tmps = SvPVX(tmpsv);
87 while ((*len)--) {
88 if (!isSPACE(*orig))
89 *tmps++ = *orig;
90 orig++;
91 }
92 *tmps = '\0';
93 *len = tmps - SvPVX(tmpsv);
94 return SvPVX(tmpsv);
95}
5b67adb8 96#endif
d16269d8 97
25fdce4a
FC
98/* ------------------------------- mg.h ------------------------------- */
99
100#if defined(PERL_CORE) || defined(PERL_EXT)
101/* assumes get-magic and stringification have already occurred */
102PERL_STATIC_INLINE STRLEN
103S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
104{
105 assert(mg->mg_type == PERL_MAGIC_regex_global);
106 assert(mg->mg_len != -1);
107 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
108 return (STRLEN)mg->mg_len;
109 else {
110 const STRLEN pos = (STRLEN)mg->mg_len;
111 /* Without this check, we may read past the end of the buffer: */
112 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
113 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
114 }
115}
116#endif
117
03414f05
FC
118/* ------------------------------- pad.h ------------------------------ */
119
120#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
121PERL_STATIC_INLINE bool
122PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
123{
124 /* is seq within the range _LOW to _HIGH ?
125 * This is complicated by the fact that PL_cop_seqmax
126 * may have wrapped around at some point */
127 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
128 return FALSE; /* not yet introduced */
129
130 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
131 /* in compiling scope */
132 if (
133 (seq > COP_SEQ_RANGE_LOW(pn))
134 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
135 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
136 )
137 return TRUE;
138 }
139 else if (
140 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
141 ?
142 ( seq > COP_SEQ_RANGE_LOW(pn)
143 || seq <= COP_SEQ_RANGE_HIGH(pn))
144
145 : ( seq > COP_SEQ_RANGE_LOW(pn)
146 && seq <= COP_SEQ_RANGE_HIGH(pn))
147 )
148 return TRUE;
149 return FALSE;
150}
151#endif
152
33a4312b
FC
153/* ------------------------------- pp.h ------------------------------- */
154
155PERL_STATIC_INLINE I32
156S_TOPMARK(pTHX)
157{
158 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 159 "MARK top %p %" IVdf "\n",
33a4312b
FC
160 PL_markstack_ptr,
161 (IV)*PL_markstack_ptr)));
162 return *PL_markstack_ptr;
163}
164
165PERL_STATIC_INLINE I32
166S_POPMARK(pTHX)
167{
168 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 169 "MARK pop %p %" IVdf "\n",
33a4312b
FC
170 (PL_markstack_ptr-1),
171 (IV)*(PL_markstack_ptr-1))));
172 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
173 return *PL_markstack_ptr--;
174}
175
8d919b0a
FC
176/* ----------------------------- regexp.h ----------------------------- */
177
178PERL_STATIC_INLINE struct regexp *
179S_ReANY(const REGEXP * const re)
180{
df6b4bd5 181 XPV* const p = (XPV*)SvANY(re);
8d919b0a 182 assert(isREGEXP(re));
df6b4bd5
DM
183 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
184 : (struct regexp *)p;
8d919b0a
FC
185}
186
27669aa4
FC
187/* ------------------------------- sv.h ------------------------------- */
188
189PERL_STATIC_INLINE SV *
190S_SvREFCNT_inc(SV *sv)
191{
2439e033 192 if (LIKELY(sv != NULL))
27669aa4
FC
193 SvREFCNT(sv)++;
194 return sv;
195}
196PERL_STATIC_INLINE SV *
197S_SvREFCNT_inc_NN(SV *sv)
198{
199 SvREFCNT(sv)++;
200 return sv;
201}
202PERL_STATIC_INLINE void
203S_SvREFCNT_inc_void(SV *sv)
204{
2439e033 205 if (LIKELY(sv != NULL))
27669aa4
FC
206 SvREFCNT(sv)++;
207}
75e16a44
FC
208PERL_STATIC_INLINE void
209S_SvREFCNT_dec(pTHX_ SV *sv)
210{
2439e033 211 if (LIKELY(sv != NULL)) {
75a9bf96 212 U32 rc = SvREFCNT(sv);
79e2a32a 213 if (LIKELY(rc > 1))
75a9bf96
DM
214 SvREFCNT(sv) = rc - 1;
215 else
216 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
217 }
218}
541377b1
FC
219
220PERL_STATIC_INLINE void
4a9a56a7
DM
221S_SvREFCNT_dec_NN(pTHX_ SV *sv)
222{
223 U32 rc = SvREFCNT(sv);
79e2a32a 224 if (LIKELY(rc > 1))
4a9a56a7
DM
225 SvREFCNT(sv) = rc - 1;
226 else
227 Perl_sv_free2(aTHX_ sv, rc);
228}
229
230PERL_STATIC_INLINE void
541377b1
FC
231SvAMAGIC_on(SV *sv)
232{
233 assert(SvROK(sv));
234 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
235}
236PERL_STATIC_INLINE void
237SvAMAGIC_off(SV *sv)
238{
239 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
240 HvAMAGIC_off(SvSTASH(SvRV(sv)));
241}
242
243PERL_STATIC_INLINE U32
541377b1
FC
244S_SvPADSTALE_on(SV *sv)
245{
c0683843 246 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
247 return SvFLAGS(sv) |= SVs_PADSTALE;
248}
249PERL_STATIC_INLINE U32
250S_SvPADSTALE_off(SV *sv)
251{
c0683843 252 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
253 return SvFLAGS(sv) &= ~SVs_PADSTALE;
254}
25fdce4a 255#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 256PERL_STATIC_INLINE STRLEN
6964422a 257S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 258{
25fdce4a 259 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
260 if (SvGAMAGIC(sv)) {
261 U8 *hopped = utf8_hop((U8 *)pv, pos);
262 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
263 return (STRLEN)(hopped - (U8 *)pv);
264 }
265 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
266}
267#endif
f019c49e 268
d1decf2b
TC
269/* ------------------------------- handy.h ------------------------------- */
270
271/* saves machine code for a common noreturn idiom typically used in Newx*() */
7347ee54 272GCC_DIAG_IGNORE_DECL(-Wunused-function);
d1decf2b
TC
273static void
274S_croak_memory_wrap(void)
275{
276 Perl_croak_nocontext("%s",PL_memory_wrap);
277}
7347ee54 278GCC_DIAG_RESTORE_DECL;
d1decf2b 279
a8a2ceaa
KW
280/* ------------------------------- utf8.h ------------------------------- */
281
2fe720e2
KW
282/*
283=head1 Unicode Support
284*/
285
55d09dc8
KW
286PERL_STATIC_INLINE void
287S_append_utf8_from_native_byte(const U8 byte, U8** dest)
288{
289 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
290 * encoded string at '*dest', updating '*dest' to include it */
291
55d09dc8
KW
292 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
293
6f2d5cbc 294 if (NATIVE_BYTE_IS_INVARIANT(byte))
a09ec51a 295 *((*dest)++) = byte;
55d09dc8 296 else {
a09ec51a
KW
297 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
298 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
299 }
300}
301
e123187a 302/*
2fe720e2 303=for apidoc valid_utf8_to_uvchr
2717076a 304Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
2fe720e2
KW
305the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
306it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
307non-Unicode code points are allowed.
308
309=cut
310
311 */
312
313PERL_STATIC_INLINE UV
314Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
315{
c41b2540 316 const UV expectlen = UTF8SKIP(s);
2fe720e2
KW
317 const U8* send = s + expectlen;
318 UV uv = *s;
319
320 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
321
322 if (retlen) {
323 *retlen = expectlen;
324 }
325
326 /* An invariant is trivially returned */
327 if (expectlen == 1) {
328 return uv;
329 }
330
331 /* Remove the leading bits that indicate the number of bytes, leaving just
332 * the bits that are part of the value */
333 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
334
335 /* Now, loop through the remaining bytes, accumulating each into the
336 * working total as we go. (I khw tried unrolling the loop for up to 4
337 * bytes, but there was no performance improvement) */
338 for (++s; s < send; s++) {
339 uv = UTF8_ACCUMULATE(uv, *s);
340 }
341
342 return UNI_TO_NATIVE(uv);
343
344}
345
1e599354
KW
346/*
347=for apidoc is_utf8_invariant_string
348
82c5d941 349Returns TRUE if the first C<len> bytes of the string C<s> are the same
1e599354 350regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
82c5d941
KW
351EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
352are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
353the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
354characters are invariant, but so also are the C1 controls.
1e599354
KW
355
356If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
357use this option, that C<s> can't have embedded C<NUL> characters and has to
358have a terminating C<NUL> byte).
359
9f2abfde
KW
360See also
361C<L</is_utf8_string>>,
362C<L</is_utf8_string_flags>>,
363C<L</is_utf8_string_loc>>,
364C<L</is_utf8_string_loc_flags>>,
365C<L</is_utf8_string_loclen>>,
366C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
367C<L</is_utf8_fixed_width_buf_flags>>,
368C<L</is_utf8_fixed_width_buf_loc_flags>>,
369C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
370C<L</is_strict_utf8_string>>,
371C<L</is_strict_utf8_string_loc>>,
372C<L</is_strict_utf8_string_loclen>>,
373C<L</is_c9strict_utf8_string>>,
374C<L</is_c9strict_utf8_string_loc>>,
375and
376C<L</is_c9strict_utf8_string_loclen>>.
1e599354
KW
377
378=cut
0cbf5865
KW
379
380*/
381
382#define is_utf8_invariant_string(s, len) \
383 is_utf8_invariant_string_loc(s, len, NULL)
384
385/*
386=for apidoc is_utf8_invariant_string_loc
387
388Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
389the first UTF-8 variant character in the C<ep> pointer; if all characters are
390UTF-8 invariant, this function does not change the contents of C<*ep>.
391
392=cut
393
1e599354
KW
394*/
395
396PERL_STATIC_INLINE bool
e17544a6 397S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
1e599354 398{
e17544a6 399 const U8* send;
1e599354
KW
400 const U8* x = s;
401
0cbf5865
KW
402 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
403
e17544a6
KW
404 if (len == 0) {
405 len = strlen((const char *)s);
406 }
407
408 send = s + len;
409
4ab2fd9b 410/* This looks like 0x010101... */
2c5c8af5 411# define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
4ab2fd9b
KW
412
413/* This looks like 0x808080... */
2c5c8af5 414# define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
e099ea69 415# define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
2c5c8af5 416# define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
e17544a6 417
099e59a4
KW
418/* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
419 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
420 * optimized out completely on a 32-bit system, and its mask gets optimized out
421 * on a 64-bit system */
2c5c8af5 422# define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
5eabe374
KW
423 | ( PTR2nat(x) >> 1) \
424 | ( ( (PTR2nat(x) \
425 & PERL_WORD_BOUNDARY_MASK) >> 2))))
099e59a4 426
3f515a2e
KW
427#ifndef EBCDIC
428
099e59a4
KW
429 /* Do the word-at-a-time iff there is at least one usable full word. That
430 * means that after advancing to a word boundary, there still is at least a
431 * full word left. The number of bytes needed to advance is 'wordsize -
432 * offset' unless offset is 0. */
433 if ((STRLEN) (send - x) >= PERL_WORDSIZE
434
435 /* This term is wordsize if subword; 0 if not */
436 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
437
438 /* 'offset' */
439 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
440 {
b40579ff 441
46bb68f6
KW
442 /* Process per-byte until reach word boundary. XXX This loop could be
443 * eliminated if we knew that this platform had fast unaligned reads */
b40579ff 444 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
46bb68f6
KW
445 if (! UTF8_IS_INVARIANT(*x)) {
446 if (ep) {
447 *ep = x;
448 }
e17544a6 449
46bb68f6
KW
450 return FALSE;
451 }
452 x++;
e17544a6 453 }
e17544a6 454
099e59a4
KW
455 /* Here, we know we have at least one full word to process. Process
456 * per-word as long as we have at least a full word left */
457 do {
4ab2fd9b 458 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
e17544a6 459
46bb68f6
KW
460 /* Found a variant. Just return if caller doesn't want its
461 * exact position */
462 if (! ep) {
463 return FALSE;
464 }
e17544a6 465
2c5c8af5
KW
466# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
467 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
1d2af574
KW
468
469 *ep = x + _variant_byte_number(* (PERL_UINTMAX_T *) x);
470 assert(*ep >= s && *ep < send);
471
472 return FALSE;
473
2c5c8af5 474# else /* If weird byte order, drop into next loop to do byte-at-a-time
1d2af574
KW
475 checks. */
476
46bb68f6 477 break;
2c5c8af5 478# endif
46bb68f6 479 }
1d2af574 480
46bb68f6 481 x += PERL_WORDSIZE;
1d2af574 482
099e59a4 483 } while (x + PERL_WORDSIZE <= send);
b40579ff 484 }
e17544a6 485
0b08cab0 486#endif /* End of ! EBCDIC */
e17544a6
KW
487
488 /* Process per-byte */
489 while (x < send) {
490 if (! UTF8_IS_INVARIANT(*x)) {
491 if (ep) {
492 *ep = x;
493 }
0cbf5865 494
e17544a6 495 return FALSE;
0cbf5865 496 }
1e599354 497
e17544a6 498 x++;
1e599354
KW
499 }
500
501 return TRUE;
502}
503
23a7ee81
KW
504#ifndef EBCDIC
505
1d2af574
KW
506PERL_STATIC_INLINE unsigned int
507S__variant_byte_number(PERL_UINTMAX_T word)
508{
509
510 /* This returns the position in a word (0..7) of the first variant byte in
511 * it. This is a helper function. Note that there are no branches */
512
513 assert(word);
514
515 /* Get just the msb bits of each byte */
516 word &= PERL_VARIANTS_WORD_MASK;
517
597ee3f4
KW
518# ifdef USING_MSVC6 /* VC6 has some issues with the normal code, and the
519 easiest thing is to hide that from the callers */
520 {
521 unsigned int i;
522 const U8 * s = (U8 *) &word;
523 dTHX;
524
525 for (i = 0; i < sizeof(word); i++ ) {
526 if (s[i]) {
527 return i;
528 }
529 }
530
531 Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
532 __FILE__, __LINE__);
533 }
534
535# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1d2af574
KW
536
537 /* Bytes are stored like
538 * Byte8 ... Byte2 Byte1
539 * 63..56...15...8 7...0
540 *
541 * Isolate the lsb;
542 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
543 *
544 * The word will look this this, with a rightmost set bit in position 's':
545 * ('x's are don't cares)
546 * s
547 * x..x100..0
548 * x..xx10..0 Right shift (rightmost 0 is shifted off)
549 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
550 * the 1 just to their left into a 0; the remainder is
551 * untouched
4fa92663
KW
552 * 0..0011..1 The xor with the original, x..xx10..0, clears that
553 * remainder, sets the bottom to all 1
1d2af574
KW
554 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
555 *
556 * Another method is to do 'word &= -word'; but it generates a compiler
557 * message on some platforms about taking the negative of an unsigned */
558
559 word >>= 1;
560 word = 1 + (word ^ (word - 1));
561
562# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
563
564 /* Bytes are stored like
565 * Byte1 Byte2 ... Byte8
566 * 63..56 55..47 ... 7...0
567 *
568 * Isolate the msb; http://codeforces.com/blog/entry/10330
569 *
570 * Only the most significant set bit matters. Or'ing word with its right
571 * shift of 1 makes that bit and the next one to its right both 1. Then
572 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
573 * msb and all to the right being 1. */
574 word |= word >> 1;
575 word |= word >> 2;
576 word |= word >> 4;
577 word |= word >> 8;
578 word |= word >> 16;
579 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
580
581 /* Then subtracting the right shift by 1 clears all but the left-most of
582 * the 1 bits, which is our desired result */
583 word -= (word >> 1);
584
585# else
586# error Unexpected byte order
587# endif
588
7cf2d6c7
KW
589 /* Here 'word' has a single bit set: the msb of the first byte in which it
590 * is set. Calculate that position in the word. We can use this
1d2af574 591 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
67e12c5c
KW
592 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
593 * just get shifted off at compile time) */
594 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
595 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
596 | (39 << 24) | (47 << 16)
597 | (55 << 8) | (63 << 0));
1d2af574
KW
598 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
599
600 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
601 word = ((word + 1) >> 3) - 1;
602
603# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
604
605 /* And invert the result */
606 word = CHARBITS - word - 1;
607
608# endif
609
610 return (unsigned int) word;
611}
612
23a7ee81 613#endif
03c1e4ab
KW
614#if defined(PERL_CORE) || defined(PERL_EXT)
615
616/*
617=for apidoc variant_under_utf8_count
618
619This function looks at the sequence of bytes between C<s> and C<e>, which are
620assumed to be encoded in ASCII/Latin1, and returns how many of them would
621change should the string be translated into UTF-8. Due to the nature of UTF-8,
622each of these would occupy two bytes instead of the single one in the input
623string. Thus, this function returns the precise number of bytes the string
624would expand by when translated to UTF-8.
625
626Unlike most of the other functions that have C<utf8> in their name, the input
627to this function is NOT a UTF-8-encoded string. The function name is slightly
628I<odd> to emphasize this.
629
630This function is internal to Perl because khw thinks that any XS code that
631would want this is probably operating too close to the internals. Presenting a
632valid use case could change that.
633
634See also
635C<L<perlapi/is_utf8_invariant_string>>
636and
637C<L<perlapi/is_utf8_invariant_string_loc>>,
638
639=cut
640
641*/
642
643PERL_STATIC_INLINE Size_t
644S_variant_under_utf8_count(const U8* const s, const U8* const e)
645{
646 const U8* x = s;
647 Size_t count = 0;
648
649 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
650
651# ifndef EBCDIC
652
5d0379de
KW
653 /* Test if the string is long enough to use word-at-a-time. (Logic is the
654 * same as for is_utf8_invariant_string()) */
03c1e4ab
KW
655 if ((STRLEN) (e - x) >= PERL_WORDSIZE
656 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
657 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
658 {
659
660 /* Process per-byte until reach word boundary. XXX This loop could be
661 * eliminated if we knew that this platform had fast unaligned reads */
662 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
663 count += ! UTF8_IS_INVARIANT(*x++);
664 }
665
666 /* Process per-word as long as we have at least a full word left */
74472cc2
KW
667 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
668 explanation of how this works */
e5863284
KW
669 PERL_UINTMAX_T increment
670 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
03c1e4ab
KW
671 * PERL_COUNT_MULTIPLIER)
672 >> ((PERL_WORDSIZE - 1) * CHARBITS);
e5863284 673 count += (Size_t) increment;
03c1e4ab
KW
674 x += PERL_WORDSIZE;
675 } while (x + PERL_WORDSIZE <= e);
676 }
677
678# endif
679
680 /* Process per-byte */
681 while (x < e) {
682 if (! UTF8_IS_INVARIANT(*x)) {
683 count++;
684 }
685
686 x++;
687 }
688
689 return count;
690}
691
692#endif
693
aff4cafe
KW
694#ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
695# undef PERL_WORDSIZE
696# undef PERL_COUNT_MULTIPLIER
697# undef PERL_WORD_BOUNDARY_MASK
698# undef PERL_VARIANTS_WORD_MASK
699#endif
03c1e4ab 700
7c93d8f0 701/*
5ff889fb
KW
702=for apidoc is_utf8_string
703
82c5d941
KW
704Returns TRUE if the first C<len> bytes of string C<s> form a valid
705Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
706be calculated using C<strlen(s)> (which means if you use this option, that C<s>
707can't have embedded C<NUL> characters and has to have a terminating C<NUL>
708byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
709
2717076a
KW
710This function considers Perl's extended UTF-8 to be valid. That means that
711code points above Unicode, surrogates, and non-character code points are
9f2abfde
KW
712considered valid by this function. Use C<L</is_strict_utf8_string>>,
713C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
714code points are considered valid.
5ff889fb 715
9f2abfde
KW
716See also
717C<L</is_utf8_invariant_string>>,
0cbf5865 718C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
719C<L</is_utf8_string_loc>>,
720C<L</is_utf8_string_loclen>>,
8bc127bf
KW
721C<L</is_utf8_fixed_width_buf_flags>>,
722C<L</is_utf8_fixed_width_buf_loc_flags>>,
723C<L</is_utf8_fixed_width_buf_loclen_flags>>,
5ff889fb
KW
724
725=cut
726*/
727
dd237e82 728#define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
5ff889fb 729
c9cd936b
KW
730#if defined(PERL_CORE) || defined (PERL_EXT)
731
732/*
733=for apidoc is_utf8_non_invariant_string
734
735Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
736C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
737UTF-8; otherwise returns FALSE.
738
739A TRUE return means that at least one code point represented by the sequence
740either is a wide character not representable as a single byte, or the
741representation differs depending on whether the sequence is encoded in UTF-8 or
742not.
743
744See also
745C<L<perlapi/is_utf8_invariant_string>>,
746C<L<perlapi/is_utf8_string>>
747
748=cut
749
750This is commonly used to determine if a SV's UTF-8 flag should be turned on.
b3b93dfe
KW
751It generally needn't be if its string is entirely UTF-8 invariant, and it
752shouldn't be if it otherwise contains invalid UTF-8.
c9cd936b
KW
753
754It is an internal function because khw thinks that XS code shouldn't be working
755at this low a level. A valid use case could change that.
756
757*/
758
759PERL_STATIC_INLINE bool
760S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
761{
762 const U8 * first_variant;
763
764 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
765
766 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
767 return FALSE;
768 }
769
770 return is_utf8_string(first_variant, len - (first_variant - s));
771}
772
773#endif
774
5ff889fb 775/*
9f2abfde
KW
776=for apidoc is_strict_utf8_string
777
778Returns TRUE if the first C<len> bytes of string C<s> form a valid
779UTF-8-encoded string that is fully interchangeable by any application using
780Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
781calculated using C<strlen(s)> (which means if you use this option, that C<s>
782can't have embedded C<NUL> characters and has to have a terminating C<NUL>
783byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
784
785This function returns FALSE for strings containing any
786code points above the Unicode max of 0x10FFFF, surrogate code points, or
787non-character code points.
788
789See also
790C<L</is_utf8_invariant_string>>,
0cbf5865 791C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
792C<L</is_utf8_string>>,
793C<L</is_utf8_string_flags>>,
794C<L</is_utf8_string_loc>>,
795C<L</is_utf8_string_loc_flags>>,
796C<L</is_utf8_string_loclen>>,
797C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
798C<L</is_utf8_fixed_width_buf_flags>>,
799C<L</is_utf8_fixed_width_buf_loc_flags>>,
800C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
801C<L</is_strict_utf8_string_loc>>,
802C<L</is_strict_utf8_string_loclen>>,
803C<L</is_c9strict_utf8_string>>,
804C<L</is_c9strict_utf8_string_loc>>,
805and
806C<L</is_c9strict_utf8_string_loclen>>.
807
808=cut
809*/
810
dd237e82 811#define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
9f2abfde
KW
812
813/*
814=for apidoc is_c9strict_utf8_string
815
816Returns TRUE if the first C<len> bytes of string C<s> form a valid
817UTF-8-encoded string that conforms to
818L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
819otherwise it returns FALSE. If C<len> is 0, it will be calculated using
820C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
821C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
822characters being ASCII constitute 'a valid UTF-8 string'.
823
824This function returns FALSE for strings containing any code points above the
825Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
826code points per
827L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
828
829See also
830C<L</is_utf8_invariant_string>>,
0cbf5865 831C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
832C<L</is_utf8_string>>,
833C<L</is_utf8_string_flags>>,
834C<L</is_utf8_string_loc>>,
835C<L</is_utf8_string_loc_flags>>,
836C<L</is_utf8_string_loclen>>,
837C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
838C<L</is_utf8_fixed_width_buf_flags>>,
839C<L</is_utf8_fixed_width_buf_loc_flags>>,
840C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
841C<L</is_strict_utf8_string>>,
842C<L</is_strict_utf8_string_loc>>,
843C<L</is_strict_utf8_string_loclen>>,
844C<L</is_c9strict_utf8_string_loc>>,
845and
846C<L</is_c9strict_utf8_string_loclen>>.
847
848=cut
849*/
850
dd237e82 851#define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
9f2abfde
KW
852
853/*
854=for apidoc is_utf8_string_flags
855
856Returns TRUE if the first C<len> bytes of string C<s> form a valid
857UTF-8 string, subject to the restrictions imposed by C<flags>;
858returns FALSE otherwise. If C<len> is 0, it will be calculated
859using C<strlen(s)> (which means if you use this option, that C<s> can't have
860embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
861that all characters being ASCII constitute 'a valid UTF-8 string'.
862
863If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
864C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
865as C<L</is_strict_utf8_string>>; and if C<flags> is
866C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
867C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
868combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
869C<L</utf8n_to_uvchr>>, with the same meanings.
870
871See also
872C<L</is_utf8_invariant_string>>,
0cbf5865 873C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
874C<L</is_utf8_string>>,
875C<L</is_utf8_string_loc>>,
876C<L</is_utf8_string_loc_flags>>,
877C<L</is_utf8_string_loclen>>,
878C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
879C<L</is_utf8_fixed_width_buf_flags>>,
880C<L</is_utf8_fixed_width_buf_loc_flags>>,
881C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
882C<L</is_strict_utf8_string>>,
883C<L</is_strict_utf8_string_loc>>,
884C<L</is_strict_utf8_string_loclen>>,
885C<L</is_c9strict_utf8_string>>,
886C<L</is_c9strict_utf8_string_loc>>,
887and
888C<L</is_c9strict_utf8_string_loclen>>.
889
890=cut
891*/
892
893PERL_STATIC_INLINE bool
f60f61fd 894S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
9f2abfde 895{
33756530 896 const U8 * first_variant;
9f2abfde
KW
897
898 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
899 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 900 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 901
f60f61fd
KW
902 if (len == 0) {
903 len = strlen((const char *)s);
904 }
905
9f2abfde
KW
906 if (flags == 0) {
907 return is_utf8_string(s, len);
908 }
909
d044b7a7 910 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
911 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
912 {
913 return is_strict_utf8_string(s, len);
914 }
915
d044b7a7 916 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
917 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
918 {
919 return is_c9strict_utf8_string(s, len);
920 }
921
33756530
KW
922 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
923 const U8* const send = s + len;
924 const U8* x = first_variant;
925
a0d7f935
KW
926 while (x < send) {
927 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
928 if (UNLIKELY(! cur_len)) {
929 return FALSE;
930 }
931 x += cur_len;
9f2abfde 932 }
33756530 933 }
9f2abfde
KW
934
935 return TRUE;
936}
937
938/*
5ff889fb
KW
939
940=for apidoc is_utf8_string_loc
941
2717076a 942Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 943case of "utf8ness failure") or the location C<s>+C<len> (in the case of
82c5d941 944"utf8ness success") in the C<ep> pointer.
5ff889fb 945
2717076a 946See also C<L</is_utf8_string_loclen>>.
5ff889fb 947
3964c812
KW
948=cut
949*/
950
951#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
952
953/*
954
5ff889fb
KW
955=for apidoc is_utf8_string_loclen
956
2717076a 957Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 958case of "utf8ness failure") or the location C<s>+C<len> (in the case of
9f2abfde 959"utf8ness success") in the C<ep> pointer, and the number of UTF-8
82c5d941 960encoded characters in the C<el> pointer.
5ff889fb 961
2717076a 962See also C<L</is_utf8_string_loc>>.
5ff889fb
KW
963
964=cut
965*/
966
56e4cf64 967PERL_STATIC_INLINE bool
33756530 968Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
5ff889fb 969{
33756530 970 const U8 * first_variant;
5ff889fb
KW
971
972 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
973
33756530
KW
974 if (len == 0) {
975 len = strlen((const char *) s);
976 }
977
978 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
979 if (el)
980 *el = len;
981
982 if (ep) {
983 *ep = s + len;
984 }
985
986 return TRUE;
987 }
988
989 {
990 const U8* const send = s + len;
991 const U8* x = first_variant;
992 STRLEN outlen = first_variant - s;
993
a0d7f935
KW
994 while (x < send) {
995 const STRLEN cur_len = isUTF8_CHAR(x, send);
996 if (UNLIKELY(! cur_len)) {
997 break;
998 }
999 x += cur_len;
1000 outlen++;
5ff889fb 1001 }
5ff889fb 1002
a0d7f935
KW
1003 if (el)
1004 *el = outlen;
5ff889fb 1005
a0d7f935
KW
1006 if (ep) {
1007 *ep = x;
1008 }
5ff889fb 1009
a0d7f935 1010 return (x == send);
33756530 1011 }
5ff889fb
KW
1012}
1013
1014/*
9f2abfde 1015
44170c9a 1016=for apidoc isUTF8_CHAR
8ed185f9
KW
1017
1018Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1019looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1020that represents some code point; otherwise it evaluates to 0. If non-zero, the
1021value gives how many bytes starting at C<s> comprise the code point's
1022representation. Any bytes remaining before C<e>, but beyond the ones needed to
1023form the first code point in C<s>, are not examined.
1024
13aab5dd 1025The code point can be any that will fit in an IV on this machine, using Perl's
8ed185f9
KW
1026extension to official UTF-8 to represent those higher than the Unicode maximum
1027of 0x10FFFF. That means that this macro is used to efficiently decide if the
1028next few bytes in C<s> is legal UTF-8 for a single character.
1029
1030Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1031defined by Unicode to be fully interchangeable across applications;
1032C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1033#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1034code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1035
1036Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1037C<L</is_utf8_string_loclen>> to check entire strings.
1038
13aab5dd
KW
1039Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1040machines) is a valid UTF-8 character.
8ed185f9
KW
1041
1042=cut
1043
1044This uses an adaptation of the table and algorithm given in
1045http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1046documentation of the original version. A copyright notice for the original
1047version is given at the beginning of this file. The Perl adapation is
71525f77 1048documented at the definition of PL_extended_utf8_dfa_tab[].
8ed185f9
KW
1049
1050*/
1051
1052PERL_STATIC_INLINE Size_t
1053S_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1054{
1055 const U8 * s = s0;
1056 UV state = 0;
1057
1058 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1059
1060 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1061 * code point, which can be returned immediately. Otherwise, it is either
1062 * malformed, or for the start byte FF which the dfa doesn't handle (except
1063 * on 32-bit ASCII platforms where it trivially is an error). Call a
1064 * helper function for the other platforms. */
1065
1066 while (s < e && LIKELY(state != 1)) {
71525f77 1067 state = PL_extended_utf8_dfa_tab[256
8ed185f9 1068 + state
71525f77 1069 + PL_extended_utf8_dfa_tab[*s]];
8ed185f9
KW
1070 if (state != 0) {
1071 s++;
1072 continue;
1073 }
1074
1075 return s - s0 + 1;
1076 }
1077
1078#if defined(UV_IS_QUAD) || defined(EBCDIC)
1079
1080 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1081 return _is_utf8_char_helper(s0, e, 0);
1082 }
1083
1084#endif
1085
1086 return 0;
1087}
1088
1089/*
1090
67049a5f
KW
1091=for apidoc isSTRICT_UTF8_CHAR
1092
1093Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1094looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1095Unicode code point completely acceptable for open interchange between all
1096applications; otherwise it evaluates to 0. If non-zero, the value gives how
1097many bytes starting at C<s> comprise the code point's representation. Any
1098bytes remaining before C<e>, but beyond the ones needed to form the first code
1099point in C<s>, are not examined.
1100
1101The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1102be a surrogate nor a non-character code point. Thus this excludes any code
1103point from Perl's extended UTF-8.
1104
1105This is used to efficiently decide if the next few bytes in C<s> is
1106legal Unicode-acceptable UTF-8 for a single character.
1107
1108Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1109#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1110code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1111and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1112
1113Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1114C<L</is_strict_utf8_string_loclen>> to check entire strings.
1115
1116=cut
1117
1118This uses an adaptation of the tables and algorithm given in
1119http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1120documentation of the original version. A copyright notice for the original
1121version is given at the beginning of this file. The Perl adapation is
1122documented at the definition of strict_extended_utf8_dfa_tab[].
1123
1124*/
1125
1126PERL_STATIC_INLINE Size_t
1127S_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1128{
1129 const U8 * s = s0;
1130 UV state = 0;
1131
1132 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1133
1134 while (s < e && LIKELY(state != 1)) {
71525f77 1135 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
67049a5f
KW
1136
1137 if (state != 0) {
1138 s++;
1139 continue;
1140 }
1141
1142 return s - s0 + 1;
1143 }
1144
1145#ifndef EBCDIC
1146
1147 /* The dfa above drops out for certain Hanguls; handle them specially */
1148 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1149 return 3;
1150 }
1151
1152#endif
1153
1154 return 0;
1155}
1156
1157/*
1158
44170c9a 1159=for apidoc isC9_STRICT_UTF8_CHAR
c5bfbb64
KW
1160
1161Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1162looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1163Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1164the value gives how many bytes starting at C<s> comprise the code point's
1165representation. Any bytes remaining before C<e>, but beyond the ones needed to
1166form the first code point in C<s>, are not examined.
1167
1168The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1169differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1170code points. This corresponds to
1171L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1172which said that non-character code points are merely discouraged rather than
1173completely forbidden in open interchange. See
1174L<perlunicode/Noncharacter code points>.
1175
1176Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1177C<L</isUTF8_CHAR_flags>> for a more customized definition.
1178
1179Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1180C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1181
1182=cut
1183
1184This uses an adaptation of the tables and algorithm given in
1185http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1186documentation of the original version. A copyright notice for the original
1187version is given at the beginning of this file. The Perl adapation is
71525f77 1188documented at the definition of PL_c9_utf8_dfa_tab[].
c5bfbb64
KW
1189
1190*/
1191
1192PERL_STATIC_INLINE Size_t
1193S_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1194{
1195 const U8 * s = s0;
1196 UV state = 0;
1197
1198 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1199
1200 while (s < e && LIKELY(state != 1)) {
71525f77 1201 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
c5bfbb64
KW
1202
1203 if (state != 0) {
1204 s++;
1205 continue;
1206 }
1207
1208 return s - s0 + 1;
1209 }
1210
1211 return 0;
1212}
1213
1214/*
1215
9f2abfde
KW
1216=for apidoc is_strict_utf8_string_loc
1217
1218Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1219case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1220"utf8ness success") in the C<ep> pointer.
1221
1222See also C<L</is_strict_utf8_string_loclen>>.
1223
1224=cut
1225*/
1226
1227#define is_strict_utf8_string_loc(s, len, ep) \
1228 is_strict_utf8_string_loclen(s, len, ep, 0)
1229
1230/*
1231
1232=for apidoc is_strict_utf8_string_loclen
1233
1234Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1235case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1236"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1237encoded characters in the C<el> pointer.
1238
1239See also C<L</is_strict_utf8_string_loc>>.
1240
1241=cut
1242*/
1243
1244PERL_STATIC_INLINE bool
33756530 1245S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1246{
33756530 1247 const U8 * first_variant;
9f2abfde
KW
1248
1249 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1250
33756530
KW
1251 if (len == 0) {
1252 len = strlen((const char *) s);
1253 }
1254
1255 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1256 if (el)
1257 *el = len;
1258
1259 if (ep) {
1260 *ep = s + len;
1261 }
1262
1263 return TRUE;
1264 }
1265
1266 {
1267 const U8* const send = s + len;
1268 const U8* x = first_variant;
1269 STRLEN outlen = first_variant - s;
1270
a0d7f935
KW
1271 while (x < send) {
1272 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1273 if (UNLIKELY(! cur_len)) {
1274 break;
1275 }
1276 x += cur_len;
1277 outlen++;
9f2abfde 1278 }
9f2abfde 1279
a0d7f935
KW
1280 if (el)
1281 *el = outlen;
9f2abfde 1282
a0d7f935
KW
1283 if (ep) {
1284 *ep = x;
1285 }
9f2abfde 1286
a0d7f935 1287 return (x == send);
33756530 1288 }
9f2abfde
KW
1289}
1290
1291/*
1292
1293=for apidoc is_c9strict_utf8_string_loc
1294
1295Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1296the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1297"utf8ness success") in the C<ep> pointer.
1298
1299See also C<L</is_c9strict_utf8_string_loclen>>.
1300
1301=cut
1302*/
1303
1304#define is_c9strict_utf8_string_loc(s, len, ep) \
1305 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1306
1307/*
1308
1309=for apidoc is_c9strict_utf8_string_loclen
1310
1311Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1312the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1313"utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1314characters in the C<el> pointer.
1315
1316See also C<L</is_c9strict_utf8_string_loc>>.
1317
1318=cut
1319*/
1320
1321PERL_STATIC_INLINE bool
33756530 1322S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1323{
33756530 1324 const U8 * first_variant;
9f2abfde
KW
1325
1326 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1327
33756530
KW
1328 if (len == 0) {
1329 len = strlen((const char *) s);
1330 }
1331
1332 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1333 if (el)
1334 *el = len;
1335
1336 if (ep) {
1337 *ep = s + len;
1338 }
1339
1340 return TRUE;
1341 }
1342
1343 {
1344 const U8* const send = s + len;
1345 const U8* x = first_variant;
1346 STRLEN outlen = first_variant - s;
1347
a0d7f935
KW
1348 while (x < send) {
1349 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1350 if (UNLIKELY(! cur_len)) {
1351 break;
1352 }
1353 x += cur_len;
1354 outlen++;
9f2abfde 1355 }
9f2abfde 1356
a0d7f935
KW
1357 if (el)
1358 *el = outlen;
9f2abfde 1359
a0d7f935
KW
1360 if (ep) {
1361 *ep = x;
1362 }
9f2abfde 1363
a0d7f935 1364 return (x == send);
33756530 1365 }
9f2abfde
KW
1366}
1367
1368/*
1369
1370=for apidoc is_utf8_string_loc_flags
1371
1372Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1373case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1374"utf8ness success") in the C<ep> pointer.
1375
1376See also C<L</is_utf8_string_loclen_flags>>.
1377
1378=cut
1379*/
1380
1381#define is_utf8_string_loc_flags(s, len, ep, flags) \
1382 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1383
1384
1385/* The above 3 actual functions could have been moved into the more general one
1386 * just below, and made #defines that call it with the right 'flags'. They are
1387 * currently kept separate to increase their chances of getting inlined */
1388
1389/*
1390
1391=for apidoc is_utf8_string_loclen_flags
1392
1393Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1394case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1395"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1396encoded characters in the C<el> pointer.
1397
1398See also C<L</is_utf8_string_loc_flags>>.
1399
1400=cut
1401*/
1402
1403PERL_STATIC_INLINE bool
f60f61fd 1404S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
9f2abfde 1405{
33756530 1406 const U8 * first_variant;
9f2abfde
KW
1407
1408 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1409 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1410 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 1411
f60f61fd 1412 if (len == 0) {
a0d7f935 1413 len = strlen((const char *) s);
f60f61fd
KW
1414 }
1415
9f2abfde
KW
1416 if (flags == 0) {
1417 return is_utf8_string_loclen(s, len, ep, el);
1418 }
1419
d044b7a7 1420 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1421 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1422 {
1423 return is_strict_utf8_string_loclen(s, len, ep, el);
1424 }
1425
d044b7a7 1426 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1427 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1428 {
1429 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1430 }
1431
33756530
KW
1432 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1433 if (el)
1434 *el = len;
1435
1436 if (ep) {
1437 *ep = s + len;
1438 }
1439
1440 return TRUE;
1441 }
1442
1443 {
1444 const U8* send = s + len;
1445 const U8* x = first_variant;
1446 STRLEN outlen = first_variant - s;
1447
a0d7f935
KW
1448 while (x < send) {
1449 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1450 if (UNLIKELY(! cur_len)) {
1451 break;
1452 }
1453 x += cur_len;
1454 outlen++;
9f2abfde 1455 }
9f2abfde 1456
a0d7f935
KW
1457 if (el)
1458 *el = outlen;
9f2abfde 1459
a0d7f935
KW
1460 if (ep) {
1461 *ep = x;
1462 }
9f2abfde 1463
a0d7f935 1464 return (x == send);
33756530 1465 }
9f2abfde
KW
1466}
1467
1468/*
7c93d8f0
KW
1469=for apidoc utf8_distance
1470
1471Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1472and C<b>.
1473
1474WARNING: use only if you *know* that the pointers point inside the
1475same UTF-8 buffer.
1476
1477=cut
1478*/
1479
1480PERL_STATIC_INLINE IV
1481Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1482{
1483 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1484
1485 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1486}
1487
1488/*
1489=for apidoc utf8_hop
1490
1491Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1492forward or backward.
1493
1494WARNING: do not use the following unless you *know* C<off> is within
1495the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1496on the first byte of character or just after the last byte of a character.
1497
1498=cut
1499*/
1500
1501PERL_STATIC_INLINE U8 *
1502Perl_utf8_hop(const U8 *s, SSize_t off)
1503{
1504 PERL_ARGS_ASSERT_UTF8_HOP;
1505
1506 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1507 * the bitops (especially ~) can create illegal UTF-8.
1508 * In other words: in Perl UTF-8 is not just for Unicode. */
1509
1510 if (off >= 0) {
1511 while (off--)
1512 s += UTF8SKIP(s);
1513 }
1514 else {
1515 while (off++) {
1516 s--;
1517 while (UTF8_IS_CONTINUATION(*s))
1518 s--;
1519 }
1520 }
e099ea69 1521 GCC_DIAG_IGNORE(-Wcast-qual)
7c93d8f0 1522 return (U8 *)s;
e099ea69 1523 GCC_DIAG_RESTORE
7c93d8f0
KW
1524}
1525
4dab108f 1526/*
65df57a8
TC
1527=for apidoc utf8_hop_forward
1528
1529Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1530forward.
1531
1532C<off> must be non-negative.
1533
1534C<s> must be before or equal to C<end>.
1535
1536When moving forward it will not move beyond C<end>.
1537
1538Will not exceed this limit even if the string is not valid "UTF-8".
1539
1540=cut
1541*/
1542
1543PERL_STATIC_INLINE U8 *
1544Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1545{
1546 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1547
1548 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1549 * the bitops (especially ~) can create illegal UTF-8.
1550 * In other words: in Perl UTF-8 is not just for Unicode. */
1551
1552 assert(s <= end);
1553 assert(off >= 0);
1554
1555 while (off--) {
1556 STRLEN skip = UTF8SKIP(s);
de979548 1557 if ((STRLEN)(end - s) <= skip) {
e099ea69 1558 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1559 return (U8 *)end;
e099ea69 1560 GCC_DIAG_RESTORE
de979548 1561 }
65df57a8
TC
1562 s += skip;
1563 }
1564
e099ea69 1565 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1566 return (U8 *)s;
e099ea69 1567 GCC_DIAG_RESTORE
65df57a8
TC
1568}
1569
1570/*
1571=for apidoc utf8_hop_back
1572
1573Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1574backward.
1575
1576C<off> must be non-positive.
1577
1578C<s> must be after or equal to C<start>.
1579
1580When moving backward it will not move before C<start>.
1581
1582Will not exceed this limit even if the string is not valid "UTF-8".
1583
1584=cut
1585*/
1586
1587PERL_STATIC_INLINE U8 *
1588Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1589{
1590 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1591
1592 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1593 * the bitops (especially ~) can create illegal UTF-8.
1594 * In other words: in Perl UTF-8 is not just for Unicode. */
1595
1596 assert(start <= s);
1597 assert(off <= 0);
1598
1599 while (off++ && s > start) {
e7185695 1600 do {
65df57a8 1601 s--;
e7185695 1602 } while (UTF8_IS_CONTINUATION(*s) && s > start);
65df57a8
TC
1603 }
1604
e099ea69 1605 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1606 return (U8 *)s;
e099ea69 1607 GCC_DIAG_RESTORE
65df57a8
TC
1608}
1609
1610/*
1611=for apidoc utf8_hop_safe
1612
1613Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1614either forward or backward.
1615
1616When moving backward it will not move before C<start>.
1617
1618When moving forward it will not move beyond C<end>.
1619
1620Will not exceed those limits even if the string is not valid "UTF-8".
1621
1622=cut
1623*/
1624
1625PERL_STATIC_INLINE U8 *
1626Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1627{
1628 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1629
1630 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1631 * the bitops (especially ~) can create illegal UTF-8.
1632 * In other words: in Perl UTF-8 is not just for Unicode. */
1633
1634 assert(start <= s && s <= end);
1635
1636 if (off >= 0) {
1637 return utf8_hop_forward(s, off, end);
1638 }
1639 else {
1640 return utf8_hop_back(s, off, start);
1641 }
1642}
1643
1644/*
4dab108f
KW
1645
1646=for apidoc is_utf8_valid_partial_char
1647
6cbb9248
KW
1648Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1649S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1650points. Otherwise, it returns 1 if there exists at least one non-empty
1651sequence of bytes that when appended to sequence C<s>, starting at position
1652C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1653otherwise returns 0.
1654
1655In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1656point.
1657
1658This is useful when a fixed-length buffer is being tested for being well-formed
1659UTF-8, but the final few bytes in it don't comprise a full character; that is,
1660it is split somewhere in the middle of the final code point's UTF-8
1661representation. (Presumably when the buffer is refreshed with the next chunk
1662of data, the new first bytes will complete the partial code point.) This
1663function is used to verify that the final bytes in the current buffer are in
1664fact the legal beginning of some code point, so that if they aren't, the
1665failure can be signalled without having to wait for the next read.
4dab108f
KW
1666
1667=cut
1668*/
2717076a
KW
1669#define is_utf8_valid_partial_char(s, e) \
1670 is_utf8_valid_partial_char_flags(s, e, 0)
f1c999a7
KW
1671
1672/*
1673
1674=for apidoc is_utf8_valid_partial_char_flags
1675
1676Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1677or not the input is a valid UTF-8 encoded partial character, but it takes an
1678extra parameter, C<flags>, which can further restrict which code points are
1679considered valid.
1680
1681If C<flags> is 0, this behaves identically to
1682C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1683of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1684there is any sequence of bytes that can complete the input partial character in
1685such a way that a non-prohibited character is formed, the function returns
2717076a
KW
1686TRUE; otherwise FALSE. Non character code points cannot be determined based on
1687partial character input. But many of the other possible excluded types can be
f1c999a7
KW
1688determined from just the first one or two bytes.
1689
1690=cut
1691 */
1692
56e4cf64 1693PERL_STATIC_INLINE bool
f1c999a7 1694S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
4dab108f 1695{
f1c999a7 1696 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
4dab108f 1697
f1c999a7 1698 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1699 |UTF8_DISALLOW_PERL_EXTENDED)));
4dab108f 1700
8875bd48 1701 if (s >= e || s + UTF8SKIP(s) <= e) {
4dab108f
KW
1702 return FALSE;
1703 }
1704
f1c999a7 1705 return cBOOL(_is_utf8_char_helper(s, e, flags));
4dab108f
KW
1706}
1707
8bc127bf
KW
1708/*
1709
1710=for apidoc is_utf8_fixed_width_buf_flags
1711
1712Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1713is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1714otherwise it returns FALSE.
1715
1716If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1717without restriction. If the final few bytes of the buffer do not form a
1718complete code point, this will return TRUE anyway, provided that
1719C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1720
1721If C<flags> in non-zero, it can be any combination of the
1722C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1723same meanings.
1724
1725This function differs from C<L</is_utf8_string_flags>> only in that the latter
1726returns FALSE if the final few bytes of the string don't form a complete code
1727point.
1728
1729=cut
1730 */
1731#define is_utf8_fixed_width_buf_flags(s, len, flags) \
1732 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1733
1734/*
1735
1736=for apidoc is_utf8_fixed_width_buf_loc_flags
1737
1738Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1739failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1740to the beginning of any partial character at the end of the buffer; if there is
1741no partial character C<*ep> will contain C<s>+C<len>.
1742
1743See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1744
1745=cut
1746*/
1747
1748#define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1749 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1750
1751/*
1752
1753=for apidoc is_utf8_fixed_width_buf_loclen_flags
1754
1755Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1756complete, valid characters found in the C<el> pointer.
1757
1758=cut
1759*/
1760
1761PERL_STATIC_INLINE bool
1762S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
33756530 1763 STRLEN len,
8bc127bf
KW
1764 const U8 **ep,
1765 STRLEN *el,
1766 const U32 flags)
1767{
1768 const U8 * maybe_partial;
1769
1770 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1771
1772 if (! ep) {
1773 ep = &maybe_partial;
1774 }
1775
1776 /* If it's entirely valid, return that; otherwise see if the only error is
1777 * that the final few bytes are for a partial character */
1778 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1779 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1780}
1781
e6a4ffc3
KW
1782PERL_STATIC_INLINE UV
1783S_utf8n_to_uvchr_msgs(const U8 *s,
1784 STRLEN curlen,
1785 STRLEN *retlen,
1786 const U32 flags,
1787 U32 * errors,
1788 AV ** msgs)
1789{
1790 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1791 * simple cases, and, if necessary calls a helper function to deal with the
1792 * more complex ones. Almost all well-formed non-problematic code points
1793 * are considered simple, so that it's unlikely that the helper function
1794 * will need to be called.
1795 *
1796 * This is an adaptation of the tables and algorithm given in
1797 * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1798 * comprehensive documentation of the original version. A copyright notice
1799 * for the original version is given at the beginning of this file. The
71525f77 1800 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
e6a4ffc3
KW
1801 */
1802
1803 const U8 * const s0 = s;
1804 const U8 * send = s0 + curlen;
f73cfe7d 1805 UV uv = 0; /* The 0 silences some stupid compilers */
e6a4ffc3
KW
1806 UV state = 0;
1807
1808 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1809
1810 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1811 * non-problematic code point, which can be returned immediately.
1812 * Otherwise we call a helper function to figure out the more complicated
1813 * cases. */
1814
1815 while (s < send && LIKELY(state != 1)) {
71525f77 1816 UV type = PL_strict_utf8_dfa_tab[*s];
e6a4ffc3
KW
1817
1818 uv = (state == 0)
1819 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1820 : UTF8_ACCUMULATE(uv, *s);
71525f77 1821 state = PL_strict_utf8_dfa_tab[256 + state + type];
e6a4ffc3
KW
1822
1823 if (state != 0) {
1824 s++;
1825 continue;
1826 }
1827
1828 if (retlen) {
1829 *retlen = s - s0 + 1;
1830 }
1831 if (errors) {
1832 *errors = 0;
1833 }
1834 if (msgs) {
1835 *msgs = NULL;
1836 }
1837
1838 return uv;
1839 }
1840
1841 /* Here is potentially problematic. Use the full mechanism */
1842 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1843}
1844
82651abe
KW
1845PERL_STATIC_INLINE UV
1846S__utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1847{
1848 PERL_ARGS_ASSERT__UTF8_TO_UVCHR_BUF;
1849
1850 assert(s < send);
1851
1852 if (! ckWARN_d(WARN_UTF8)) {
1853 return utf8n_to_uvchr(s, send - s, retlen,
1854 (UTF8_ALLOW_ANY & ~UTF8_ALLOW_EMPTY));
1855 }
1856 else {
1857 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1858 if (retlen && ret == 0 && *s != '\0') {
1859 *retlen = (STRLEN) -1;
1860 }
1861
1862 return ret;
1863 }
1864}
1865
c8028aa6
TC
1866/* ------------------------------- perl.h ----------------------------- */
1867
1868/*
dcccc8ff
KW
1869=head1 Miscellaneous Functions
1870
44170c9a 1871=for apidoc is_safe_syscall
c8028aa6 1872
6602b933 1873Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 1874If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
1875
1876Return TRUE if the name is safe.
1877
796b6530 1878Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
1879
1880=cut
1881*/
1882
1883PERL_STATIC_INLINE bool
41188aa0 1884S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
1885 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1886 * perl itself uses xce*() functions which accept 8-bit strings.
1887 */
1888
1889 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1890
6c4650b3 1891 if (len > 1) {
c8028aa6 1892 char *null_at;
41188aa0 1893 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 1894 SETERRNO(ENOENT, LIB_INVARG);
1d505182 1895 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 1896 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 1897 what, op_name, pv, null_at+1);
c8028aa6
TC
1898 return FALSE;
1899 }
1900 }
1901
1902 return TRUE;
1903}
1904
1905/*
7cb3f959
TC
1906
1907Return true if the supplied filename has a newline character
fa6c7d00 1908immediately before the first (hopefully only) NUL.
7cb3f959
TC
1909
1910My original look at this incorrectly used the len from SvPV(), but
1911that's incorrect, since we allow for a NUL in pv[len-1].
1912
1913So instead, strlen() and work from there.
1914
1915This allow for the user reading a filename, forgetting to chomp it,
1916then calling:
1917
1918 open my $foo, "$file\0";
1919
1920*/
1921
1922#ifdef PERL_CORE
1923
1924PERL_STATIC_INLINE bool
1925S_should_warn_nl(const char *pv) {
1926 STRLEN len;
1927
1928 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1929
1930 len = strlen(pv);
1931
1932 return len > 0 && pv[len-1] == '\n';
1933}
1934
1935#endif
1936
3a019afd
KW
1937#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1938
1939PERL_STATIC_INLINE bool
1940S_lossless_NV_to_IV(const NV nv, IV *ivp)
1941{
1942 /* This function determines if the input NV 'nv' may be converted without
1943 * loss of data to an IV. If not, it returns FALSE taking no other action.
1944 * But if it is possible, it does the conversion, returning TRUE, and
1945 * storing the converted result in '*ivp' */
1946
1947 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1948
1949# if defined(Perl_isnan)
1950
1951 if (UNLIKELY(Perl_isnan(nv))) {
1952 return FALSE;
1953 }
1954
1955# endif
1956
1957 if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
1958 return FALSE;
1959 }
1960
1961 if ((IV) nv != nv) {
1962 return FALSE;
1963 }
1964
1965 *ivp = (IV) nv;
1966 return TRUE;
1967}
1968
1969#endif
1970
81d52ecd
JH
1971/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1972
1973#define MAX_CHARSET_NAME_LENGTH 2
1974
1975PERL_STATIC_INLINE const char *
1976get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1977{
1978 /* Returns a string that corresponds to the name of the regex character set
1979 * given by 'flags', and *lenp is set the length of that string, which
1980 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1981
1982 *lenp = 1;
1983 switch (get_regex_charset(flags)) {
1984 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1985 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1986 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1987 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1988 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1989 *lenp = 2;
1990 return ASCII_MORE_RESTRICT_PAT_MODS;
1991 }
1992 /* The NOT_REACHED; hides an assert() which has a rather complex
1993 * definition in perl.h. */
1994 NOT_REACHED; /* NOTREACHED */
1995 return "?"; /* Unknown */
1996}
1997
7cb3f959 1998/*
ed382232
TC
1999
2000Return false if any get magic is on the SV other than taint magic.
2001
2002*/
2003
2004PERL_STATIC_INLINE bool
2005S_sv_only_taint_gmagic(SV *sv) {
2006 MAGIC *mg = SvMAGIC(sv);
2007
2008 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2009
2010 while (mg) {
2011 if (mg->mg_type != PERL_MAGIC_taint
2012 && !(mg->mg_flags & MGf_GSKIP)
2013 && mg->mg_virtual->svt_get) {
2014 return FALSE;
2015 }
2016 mg = mg->mg_moremagic;
2017 }
2018
2019 return TRUE;
2020}
2021
ed8ff0f3
DM
2022/* ------------------ cop.h ------------------------------------------- */
2023
2024
2025/* Enter a block. Push a new base context and return its address. */
2026
2027PERL_STATIC_INLINE PERL_CONTEXT *
2028S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2029{
2030 PERL_CONTEXT * cx;
2031
2032 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2033
2034 CXINC;
2035 cx = CX_CUR();
2036 cx->cx_type = type;
2037 cx->blk_gimme = gimme;
2038 cx->blk_oldsaveix = saveix;
4caf7d8c 2039 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 2040 cx->blk_oldcop = PL_curcop;
4caf7d8c 2041 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
2042 cx->blk_oldscopesp = PL_scopestack_ix;
2043 cx->blk_oldpm = PL_curpm;
ce8bb8d8 2044 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
2045
2046 PL_tmps_floor = PL_tmps_ix;
2047 CX_DEBUG(cx, "PUSH");
2048 return cx;
2049}
2050
2051
2052/* Exit a block (RETURN and LAST). */
2053
2054PERL_STATIC_INLINE void
2055S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2056{
2057 PERL_ARGS_ASSERT_CX_POPBLOCK;
2058
2059 CX_DEBUG(cx, "POP");
2060 /* these 3 are common to cx_popblock and cx_topblock */
2061 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2062 PL_scopestack_ix = cx->blk_oldscopesp;
2063 PL_curpm = cx->blk_oldpm;
2064
2065 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2066 * and leaves a CX entry lying around for repeated use, so
2067 * skip for multicall */ \
2068 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2069 || PL_savestack_ix == cx->blk_oldsaveix);
2070 PL_curcop = cx->blk_oldcop;
ce8bb8d8 2071 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
2072}
2073
2074/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2075 * Whereas cx_popblock() restores the state to the point just before
2076 * cx_pushblock() was called, cx_topblock() restores it to the point just
2077 * *after* cx_pushblock() was called. */
2078
2079PERL_STATIC_INLINE void
2080S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2081{
2082 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2083
2084 CX_DEBUG(cx, "TOP");
2085 /* these 3 are common to cx_popblock and cx_topblock */
2086 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2087 PL_scopestack_ix = cx->blk_oldscopesp;
2088 PL_curpm = cx->blk_oldpm;
2089
2090 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2091}
2092
2093
a73d8813
DM
2094PERL_STATIC_INLINE void
2095S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2096{
2097 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2098
2099 PERL_ARGS_ASSERT_CX_PUSHSUB;
2100
3f6bd23a 2101 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
2102 cx->blk_sub.cv = cv;
2103 cx->blk_sub.olddepth = CvDEPTH(cv);
2104 cx->blk_sub.prevcomppad = PL_comppad;
2105 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2106 cx->blk_sub.retop = retop;
2107 SvREFCNT_inc_simple_void_NN(cv);
2108 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2109}
2110
2111
2112/* subsets of cx_popsub() */
2113
2114PERL_STATIC_INLINE void
2115S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2116{
2117 CV *cv;
2118
2119 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2120 assert(CxTYPE(cx) == CXt_SUB);
2121
2122 PL_comppad = cx->blk_sub.prevcomppad;
2123 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2124 cv = cx->blk_sub.cv;
2125 CvDEPTH(cv) = cx->blk_sub.olddepth;
2126 cx->blk_sub.cv = NULL;
2127 SvREFCNT_dec(cv);
2128}
2129
2130
2131/* handle the @_ part of leaving a sub */
2132
2133PERL_STATIC_INLINE void
2134S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2135{
2136 AV *av;
2137
2138 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2139 assert(CxTYPE(cx) == CXt_SUB);
2140 assert(AvARRAY(MUTABLE_AV(
2141 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2142 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2143
2144 CX_POP_SAVEARRAY(cx);
2145 av = MUTABLE_AV(PAD_SVl(0));
2146 if (UNLIKELY(AvREAL(av)))
2147 /* abandon @_ if it got reified */
2148 clear_defarray(av, 0);
2149 else {
2150 CLEAR_ARGARRAY(av);
2151 }
2152}
2153
2154
2155PERL_STATIC_INLINE void
2156S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2157{
2158 PERL_ARGS_ASSERT_CX_POPSUB;
2159 assert(CxTYPE(cx) == CXt_SUB);
2160
3f6bd23a 2161 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
2162
2163 if (CxHASARGS(cx))
2164 cx_popsub_args(cx);
2165 cx_popsub_common(cx);
2166}
2167
2168
6a7d52cc
DM
2169PERL_STATIC_INLINE void
2170S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2171{
2172 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2173
2174 cx->blk_format.cv = cv;
2175 cx->blk_format.retop = retop;
2176 cx->blk_format.gv = gv;
2177 cx->blk_format.dfoutgv = PL_defoutgv;
2178 cx->blk_format.prevcomppad = PL_comppad;
2179 cx->blk_u16 = 0;
2180
2181 SvREFCNT_inc_simple_void_NN(cv);
2182 CvDEPTH(cv)++;
2183 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2184}
2185
2186
2187PERL_STATIC_INLINE void
2188S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2189{
2190 CV *cv;
2191 GV *dfout;
2192
2193 PERL_ARGS_ASSERT_CX_POPFORMAT;
2194 assert(CxTYPE(cx) == CXt_FORMAT);
2195
2196 dfout = cx->blk_format.dfoutgv;
2197 setdefout(dfout);
2198 cx->blk_format.dfoutgv = NULL;
2199 SvREFCNT_dec_NN(dfout);
2200
2201 PL_comppad = cx->blk_format.prevcomppad;
2202 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2203 cv = cx->blk_format.cv;
2204 cx->blk_format.cv = NULL;
2205 --CvDEPTH(cv);
2206 SvREFCNT_dec_NN(cv);
2207}
2208
2209
13febba5
DM
2210PERL_STATIC_INLINE void
2211S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2212{
2213 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2214
2215 cx->blk_eval.retop = retop;
2216 cx->blk_eval.old_namesv = namesv;
2217 cx->blk_eval.old_eval_root = PL_eval_root;
2218 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2219 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2220 cx->blk_eval.cur_top_env = PL_top_env;
2221
4c57ced5 2222 assert(!(PL_in_eval & ~ 0x3F));
13febba5 2223 assert(!(PL_op->op_type & ~0x1FF));
4c57ced5 2224 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
13febba5
DM
2225}
2226
2227
2228PERL_STATIC_INLINE void
2229S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2230{
2231 SV *sv;
2232
2233 PERL_ARGS_ASSERT_CX_POPEVAL;
2234 assert(CxTYPE(cx) == CXt_EVAL);
2235
2236 PL_in_eval = CxOLD_IN_EVAL(cx);
4c57ced5 2237 assert(!(PL_in_eval & 0xc0));
13febba5
DM
2238 PL_eval_root = cx->blk_eval.old_eval_root;
2239 sv = cx->blk_eval.cur_text;
4c57ced5 2240 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
13febba5
DM
2241 cx->blk_eval.cur_text = NULL;
2242 SvREFCNT_dec_NN(sv);
2243 }
2244
2245 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
2246 if (sv) {
2247 cx->blk_eval.old_namesv = NULL;
2248 SvREFCNT_dec_NN(sv);
2249 }
13febba5 2250}
6a7d52cc 2251
a73d8813 2252
d1b6bf72
DM
2253/* push a plain loop, i.e.
2254 * { block }
2255 * while (cond) { block }
2256 * for (init;cond;continue) { block }
2257 * This loop can be last/redo'ed etc.
2258 */
2259
2260PERL_STATIC_INLINE void
2261S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2262{
2263 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2264 cx->blk_loop.my_op = cLOOP;
2265}
2266
2267
2268/* push a true for loop, i.e.
2269 * for var (list) { block }
2270 */
2271
2272PERL_STATIC_INLINE void
2273S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2274{
2275 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2276
2277 /* this one line is common with cx_pushloop_plain */
2278 cx->blk_loop.my_op = cLOOP;
2279
2280 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2281 cx->blk_loop.itersave = itersave;
2282#ifdef USE_ITHREADS
2283 cx->blk_loop.oldcomppad = PL_comppad;
2284#endif
2285}
2286
2287
2288/* pop all loop types, including plain */
2289
2290PERL_STATIC_INLINE void
2291S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2292{
2293 PERL_ARGS_ASSERT_CX_POPLOOP;
2294
2295 assert(CxTYPE_is_LOOP(cx));
2296 if ( CxTYPE(cx) == CXt_LOOP_ARY
2297 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2298 {
2299 /* Free ary or cur. This assumes that state_u.ary.ary
2300 * aligns with state_u.lazysv.cur. See cx_dup() */
2301 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2302 cx->blk_loop.state_u.lazysv.cur = NULL;
2303 SvREFCNT_dec_NN(sv);
2304 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2305 sv = cx->blk_loop.state_u.lazysv.end;
2306 cx->blk_loop.state_u.lazysv.end = NULL;
2307 SvREFCNT_dec_NN(sv);
2308 }
2309 }
2310 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2311 SV *cursv;
2312 SV **svp = (cx)->blk_loop.itervar_u.svp;
2313 if ((cx->cx_type & CXp_FOR_GV))
2314 svp = &GvSV((GV*)svp);
2315 cursv = *svp;
2316 *svp = cx->blk_loop.itersave;
2317 cx->blk_loop.itersave = NULL;
2318 SvREFCNT_dec(cursv);
2319 }
2320}
2321
2a7b7c61
DM
2322
2323PERL_STATIC_INLINE void
7896dde7 2324S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2325{
7896dde7 2326 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2a7b7c61 2327
7896dde7 2328 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2a7b7c61
DM
2329}
2330
2331
2332PERL_STATIC_INLINE void
7896dde7 2333S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2334{
7896dde7
Z
2335 PERL_ARGS_ASSERT_CX_POPWHEN;
2336 assert(CxTYPE(cx) == CXt_WHEN);
2a7b7c61
DM
2337
2338 PERL_UNUSED_ARG(cx);
59a14f30 2339 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
2340 /* currently NOOP */
2341}
2342
2343
7896dde7
Z
2344PERL_STATIC_INLINE void
2345S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2346{
2347 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2348
2349 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2350 cx->blk_givwhen.defsv_save = orig_defsv;
2351}
2352
2353
2354PERL_STATIC_INLINE void
2355S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2356{
2357 SV *sv;
2358
2359 PERL_ARGS_ASSERT_CX_POPGIVEN;
2360 assert(CxTYPE(cx) == CXt_GIVEN);
2361
2362 sv = GvSV(PL_defgv);
2363 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2364 cx->blk_givwhen.defsv_save = NULL;
2365 SvREFCNT_dec(sv);
2366}
2367
ec2c235b
KW
2368/* ------------------ util.h ------------------------------------------- */
2369
2370/*
2371=head1 Miscellaneous Functions
2372
2373=for apidoc foldEQ
2374
2375Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2376same
2377case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2378match themselves and their opposite case counterparts. Non-cased and non-ASCII
2379range bytes match only themselves.
2380
2381=cut
2382*/
2383
2384PERL_STATIC_INLINE I32
2385Perl_foldEQ(const char *s1, const char *s2, I32 len)
2386{
2387 const U8 *a = (const U8 *)s1;
2388 const U8 *b = (const U8 *)s2;
2389
2390 PERL_ARGS_ASSERT_FOLDEQ;
2391
2392 assert(len >= 0);
2393
2394 while (len--) {
2395 if (*a != *b && *a != PL_fold[*b])
2396 return 0;
2397 a++,b++;
2398 }
2399 return 1;
2400}
2401
0f9cb40c 2402PERL_STATIC_INLINE I32
ec2c235b
KW
2403Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2404{
79a1fabd
KW
2405 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2406 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2407 * does not check for this. Nor does it check that the strings each have
2408 * at least 'len' characters. */
ec2c235b
KW
2409
2410 const U8 *a = (const U8 *)s1;
2411 const U8 *b = (const U8 *)s2;
2412
2413 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2414
2415 assert(len >= 0);
2416
2417 while (len--) {
2418 if (*a != *b && *a != PL_fold_latin1[*b]) {
2419 return 0;
2420 }
2421 a++, b++;
2422 }
2423 return 1;
2424}
2425
2426/*
2427=for apidoc foldEQ_locale
2428
2429Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2430same case-insensitively in the current locale; false otherwise.
2431
2432=cut
2433*/
2434
0f9cb40c 2435PERL_STATIC_INLINE I32
ec2c235b
KW
2436Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2437{
2438 dVAR;
2439 const U8 *a = (const U8 *)s1;
2440 const U8 *b = (const U8 *)s2;
2441
2442 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2443
2444 assert(len >= 0);
2445
2446 while (len--) {
2447 if (*a != *b && *a != PL_fold_locale[*b])
2448 return 0;
2449 a++,b++;
2450 }
2451 return 1;
2452}
2453
6dba01e2
KW
2454#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2455
2456PERL_STATIC_INLINE void *
2457S_my_memrchr(const char * s, const char c, const STRLEN len)
2458{
2459 /* memrchr(), since many platforms lack it */
2460
2461 const char * t = s + len - 1;
2462
2463 PERL_ARGS_ASSERT_MY_MEMRCHR;
2464
2465 while (t >= s) {
2466 if (*t == c) {
2467 return (void *) t;
2468 }
2469 t--;
2470 }
2471
2472 return NULL;
2473}
2474
2475#endif
2476
ed382232 2477/*
c8028aa6
TC
2478 * ex: set ts=8 sts=4 sw=4 et:
2479 */