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