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