3 * Copyright (C) 2012 by Larry Wall and others
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.
8 * This file is a home for static inline functions that cannot go in other
9 * headers files, because they depend on proto.h (included after most other
10 * headers) or struct definitions.
12 * Each section names the header file that the functions "belong" to.
15 /* ------------------------------- av.h ------------------------------- */
17 PERL_STATIC_INLINE SSize_t
18 S_av_top_index(pTHX_ AV *av)
20 PERL_ARGS_ASSERT_AV_TOP_INDEX;
21 assert(SvTYPE(av) == SVt_PVAV);
26 /* ------------------------------- cv.h ------------------------------- */
28 PERL_STATIC_INLINE GV *
32 ? Perl_cvgv_from_hek(aTHX_ sv)
33 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
36 PERL_STATIC_INLINE I32 *
37 S_CvDEPTHp(const CV * const sv)
39 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
40 return &((XPVCV*)SvANY(sv))->xcv_depth;
44 CvPROTO returns the prototype as stored, which is not necessarily what
45 the interpreter should be using. Specifically, the interpreter assumes
46 that spaces have been stripped, which has been the case if the prototype
47 was added by toke.c, but is generally not the case if it was added elsewhere.
48 Since we can't enforce the spacelessness at assignment time, this routine
49 provides a temporary copy at parse time with spaces removed.
50 I<orig> is the start of the original buffer, I<len> is the length of the
51 prototype and will be updated when this returns.
55 PERL_STATIC_INLINE char *
56 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
60 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
68 *len = tmps - SvPVX(tmpsv);
73 /* ------------------------------- mg.h ------------------------------- */
75 #if defined(PERL_CORE) || defined(PERL_EXT)
76 /* assumes get-magic and stringification have already occurred */
77 PERL_STATIC_INLINE STRLEN
78 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
80 assert(mg->mg_type == PERL_MAGIC_regex_global);
81 assert(mg->mg_len != -1);
82 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
83 return (STRLEN)mg->mg_len;
85 const STRLEN pos = (STRLEN)mg->mg_len;
86 /* Without this check, we may read past the end of the buffer: */
87 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
88 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
93 /* ------------------------------- pad.h ------------------------------ */
95 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96 PERL_STATIC_INLINE bool
97 PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
99 /* is seq within the range _LOW to _HIGH ?
100 * This is complicated by the fact that PL_cop_seqmax
101 * may have wrapped around at some point */
102 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
103 return FALSE; /* not yet introduced */
105 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
106 /* in compiling scope */
108 (seq > COP_SEQ_RANGE_LOW(pn))
109 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
110 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
115 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
117 ( seq > COP_SEQ_RANGE_LOW(pn)
118 || seq <= COP_SEQ_RANGE_HIGH(pn))
120 : ( seq > COP_SEQ_RANGE_LOW(pn)
121 && seq <= COP_SEQ_RANGE_HIGH(pn))
128 /* ------------------------------- pp.h ------------------------------- */
130 PERL_STATIC_INLINE I32
133 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
134 "MARK top %p %" IVdf "\n",
136 (IV)*PL_markstack_ptr)));
137 return *PL_markstack_ptr;
140 PERL_STATIC_INLINE I32
143 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
144 "MARK pop %p %" IVdf "\n",
145 (PL_markstack_ptr-1),
146 (IV)*(PL_markstack_ptr-1))));
147 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
148 return *PL_markstack_ptr--;
151 /* ----------------------------- regexp.h ----------------------------- */
153 PERL_STATIC_INLINE struct regexp *
154 S_ReANY(const REGEXP * const re)
156 XPV* const p = (XPV*)SvANY(re);
157 assert(isREGEXP(re));
158 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
159 : (struct regexp *)p;
162 /* ------------------------------- sv.h ------------------------------- */
164 PERL_STATIC_INLINE SV *
165 S_SvREFCNT_inc(SV *sv)
167 if (LIKELY(sv != NULL))
171 PERL_STATIC_INLINE SV *
172 S_SvREFCNT_inc_NN(SV *sv)
177 PERL_STATIC_INLINE void
178 S_SvREFCNT_inc_void(SV *sv)
180 if (LIKELY(sv != NULL))
183 PERL_STATIC_INLINE void
184 S_SvREFCNT_dec(pTHX_ SV *sv)
186 if (LIKELY(sv != NULL)) {
187 U32 rc = SvREFCNT(sv);
189 SvREFCNT(sv) = rc - 1;
191 Perl_sv_free2(aTHX_ sv, rc);
195 PERL_STATIC_INLINE void
196 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
198 U32 rc = SvREFCNT(sv);
200 SvREFCNT(sv) = rc - 1;
202 Perl_sv_free2(aTHX_ sv, rc);
205 PERL_STATIC_INLINE void
209 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
211 PERL_STATIC_INLINE void
214 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
215 HvAMAGIC_off(SvSTASH(SvRV(sv)));
218 PERL_STATIC_INLINE U32
219 S_SvPADSTALE_on(SV *sv)
221 assert(!(SvFLAGS(sv) & SVs_PADTMP));
222 return SvFLAGS(sv) |= SVs_PADSTALE;
224 PERL_STATIC_INLINE U32
225 S_SvPADSTALE_off(SV *sv)
227 assert(!(SvFLAGS(sv) & SVs_PADTMP));
228 return SvFLAGS(sv) &= ~SVs_PADSTALE;
230 #if defined(PERL_CORE) || defined (PERL_EXT)
231 PERL_STATIC_INLINE STRLEN
232 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
234 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
236 U8 *hopped = utf8_hop((U8 *)pv, pos);
237 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
238 return (STRLEN)(hopped - (U8 *)pv);
240 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
244 /* ------------------------------- handy.h ------------------------------- */
246 /* saves machine code for a common noreturn idiom typically used in Newx*() */
247 #ifdef GCC_DIAG_PRAGMA
248 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
251 S_croak_memory_wrap(void)
253 Perl_croak_nocontext("%s",PL_memory_wrap);
255 #ifdef GCC_DIAG_PRAGMA
256 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
259 /* ------------------------------- utf8.h ------------------------------- */
262 =head1 Unicode Support
265 PERL_STATIC_INLINE void
266 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
268 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
269 * encoded string at '*dest', updating '*dest' to include it */
271 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
273 if (NATIVE_BYTE_IS_INVARIANT(byte))
276 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
277 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
282 =for apidoc valid_utf8_to_uvchr
283 Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
284 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
285 it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
286 non-Unicode code points are allowed.
292 PERL_STATIC_INLINE UV
293 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
295 const UV expectlen = UTF8SKIP(s);
296 const U8* send = s + expectlen;
299 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
305 /* An invariant is trivially returned */
306 if (expectlen == 1) {
310 /* Remove the leading bits that indicate the number of bytes, leaving just
311 * the bits that are part of the value */
312 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
314 /* Now, loop through the remaining bytes, accumulating each into the
315 * working total as we go. (I khw tried unrolling the loop for up to 4
316 * bytes, but there was no performance improvement) */
317 for (++s; s < send; s++) {
318 uv = UTF8_ACCUMULATE(uv, *s);
321 return UNI_TO_NATIVE(uv);
326 =for apidoc is_utf8_invariant_string
328 Returns TRUE if the first C<len> bytes of the string C<s> are the same
329 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
330 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
331 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
332 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
333 characters are invariant, but so also are the C1 controls.
335 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
336 use this option, that C<s> can't have embedded C<NUL> characters and has to
337 have a terminating C<NUL> byte).
340 C<L</is_utf8_string>>,
341 C<L</is_utf8_string_flags>>,
342 C<L</is_utf8_string_loc>>,
343 C<L</is_utf8_string_loc_flags>>,
344 C<L</is_utf8_string_loclen>>,
345 C<L</is_utf8_string_loclen_flags>>,
346 C<L</is_utf8_fixed_width_buf_flags>>,
347 C<L</is_utf8_fixed_width_buf_loc_flags>>,
348 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
349 C<L</is_strict_utf8_string>>,
350 C<L</is_strict_utf8_string_loc>>,
351 C<L</is_strict_utf8_string_loclen>>,
352 C<L</is_c9strict_utf8_string>>,
353 C<L</is_c9strict_utf8_string_loc>>,
355 C<L</is_c9strict_utf8_string_loclen>>.
361 #define is_utf8_invariant_string(s, len) \
362 is_utf8_invariant_string_loc(s, len, NULL)
365 =for apidoc is_utf8_invariant_string_loc
367 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
368 the first UTF-8 variant character in the C<ep> pointer; if all characters are
369 UTF-8 invariant, this function does not change the contents of C<*ep>.
373 XXX On ASCII machines this could be sped up by doing word-at-a-time operations
377 PERL_STATIC_INLINE bool
378 S_is_utf8_invariant_string_loc(const U8* const s, const STRLEN len, const U8 ** ep)
380 const U8* const send = s + (len ? len : strlen((const char *)s));
383 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
386 if (UTF8_IS_INVARIANT(*x)) {
402 =for apidoc is_utf8_string
404 Returns TRUE if the first C<len> bytes of string C<s> form a valid
405 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
406 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
407 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
408 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
410 This function considers Perl's extended UTF-8 to be valid. That means that
411 code points above Unicode, surrogates, and non-character code points are
412 considered valid by this function. Use C<L</is_strict_utf8_string>>,
413 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
414 code points are considered valid.
417 C<L</is_utf8_invariant_string>>,
418 C<L</is_utf8_invariant_string_loc>>,
419 C<L</is_utf8_string_loc>>,
420 C<L</is_utf8_string_loclen>>,
421 C<L</is_utf8_fixed_width_buf_flags>>,
422 C<L</is_utf8_fixed_width_buf_loc_flags>>,
423 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
428 PERL_STATIC_INLINE bool
429 Perl_is_utf8_string(const U8 *s, const STRLEN len)
431 /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
432 * Be aware of possible changes to that */
434 const U8* const send = s + (len ? len : strlen((const char *)s));
437 PERL_ARGS_ASSERT_IS_UTF8_STRING;
440 const STRLEN cur_len = isUTF8_CHAR(x, send);
441 if (UNLIKELY(! cur_len)) {
451 =for apidoc is_strict_utf8_string
453 Returns TRUE if the first C<len> bytes of string C<s> form a valid
454 UTF-8-encoded string that is fully interchangeable by any application using
455 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
456 calculated using C<strlen(s)> (which means if you use this option, that C<s>
457 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
458 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
460 This function returns FALSE for strings containing any
461 code points above the Unicode max of 0x10FFFF, surrogate code points, or
462 non-character code points.
465 C<L</is_utf8_invariant_string>>,
466 C<L</is_utf8_invariant_string_loc>>,
467 C<L</is_utf8_string>>,
468 C<L</is_utf8_string_flags>>,
469 C<L</is_utf8_string_loc>>,
470 C<L</is_utf8_string_loc_flags>>,
471 C<L</is_utf8_string_loclen>>,
472 C<L</is_utf8_string_loclen_flags>>,
473 C<L</is_utf8_fixed_width_buf_flags>>,
474 C<L</is_utf8_fixed_width_buf_loc_flags>>,
475 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
476 C<L</is_strict_utf8_string_loc>>,
477 C<L</is_strict_utf8_string_loclen>>,
478 C<L</is_c9strict_utf8_string>>,
479 C<L</is_c9strict_utf8_string_loc>>,
481 C<L</is_c9strict_utf8_string_loclen>>.
486 PERL_STATIC_INLINE bool
487 S_is_strict_utf8_string(const U8 *s, const STRLEN len)
489 const U8* const send = s + (len ? len : strlen((const char *)s));
492 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING;
495 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
496 if (UNLIKELY(! cur_len)) {
506 =for apidoc is_c9strict_utf8_string
508 Returns TRUE if the first C<len> bytes of string C<s> form a valid
509 UTF-8-encoded string that conforms to
510 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
511 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
512 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
513 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
514 characters being ASCII constitute 'a valid UTF-8 string'.
516 This function returns FALSE for strings containing any code points above the
517 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
519 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
522 C<L</is_utf8_invariant_string>>,
523 C<L</is_utf8_invariant_string_loc>>,
524 C<L</is_utf8_string>>,
525 C<L</is_utf8_string_flags>>,
526 C<L</is_utf8_string_loc>>,
527 C<L</is_utf8_string_loc_flags>>,
528 C<L</is_utf8_string_loclen>>,
529 C<L</is_utf8_string_loclen_flags>>,
530 C<L</is_utf8_fixed_width_buf_flags>>,
531 C<L</is_utf8_fixed_width_buf_loc_flags>>,
532 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
533 C<L</is_strict_utf8_string>>,
534 C<L</is_strict_utf8_string_loc>>,
535 C<L</is_strict_utf8_string_loclen>>,
536 C<L</is_c9strict_utf8_string_loc>>,
538 C<L</is_c9strict_utf8_string_loclen>>.
543 PERL_STATIC_INLINE bool
544 S_is_c9strict_utf8_string(const U8 *s, const STRLEN len)
546 const U8* const send = s + (len ? len : strlen((const char *)s));
549 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING;
552 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
553 if (UNLIKELY(! cur_len)) {
562 /* The above 3 functions could have been moved into the more general one just
563 * below, and made #defines that call it with the right 'flags'. They are
564 * currently kept separate to increase their chances of getting inlined */
567 =for apidoc is_utf8_string_flags
569 Returns TRUE if the first C<len> bytes of string C<s> form a valid
570 UTF-8 string, subject to the restrictions imposed by C<flags>;
571 returns FALSE otherwise. If C<len> is 0, it will be calculated
572 using C<strlen(s)> (which means if you use this option, that C<s> can't have
573 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
574 that all characters being ASCII constitute 'a valid UTF-8 string'.
576 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
577 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
578 as C<L</is_strict_utf8_string>>; and if C<flags> is
579 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
580 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
581 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
582 C<L</utf8n_to_uvchr>>, with the same meanings.
585 C<L</is_utf8_invariant_string>>,
586 C<L</is_utf8_invariant_string_loc>>,
587 C<L</is_utf8_string>>,
588 C<L</is_utf8_string_loc>>,
589 C<L</is_utf8_string_loc_flags>>,
590 C<L</is_utf8_string_loclen>>,
591 C<L</is_utf8_string_loclen_flags>>,
592 C<L</is_utf8_fixed_width_buf_flags>>,
593 C<L</is_utf8_fixed_width_buf_loc_flags>>,
594 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
595 C<L</is_strict_utf8_string>>,
596 C<L</is_strict_utf8_string_loc>>,
597 C<L</is_strict_utf8_string_loclen>>,
598 C<L</is_c9strict_utf8_string>>,
599 C<L</is_c9strict_utf8_string_loc>>,
601 C<L</is_c9strict_utf8_string_loclen>>.
606 PERL_STATIC_INLINE bool
607 S_is_utf8_string_flags(const U8 *s, const STRLEN len, const U32 flags)
609 const U8* const send = s + (len ? len : strlen((const char *)s));
612 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
613 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
614 |UTF8_DISALLOW_PERL_EXTENDED)));
617 return is_utf8_string(s, len);
620 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
621 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
623 return is_strict_utf8_string(s, len);
626 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
627 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
629 return is_c9strict_utf8_string(s, len);
633 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
634 if (UNLIKELY(! cur_len)) {
645 =for apidoc is_utf8_string_loc
647 Like C<L</is_utf8_string>> but stores the location of the failure (in the
648 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
649 "utf8ness success") in the C<ep> pointer.
651 See also C<L</is_utf8_string_loclen>>.
656 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
660 =for apidoc is_utf8_string_loclen
662 Like C<L</is_utf8_string>> but stores the location of the failure (in the
663 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
664 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
665 encoded characters in the C<el> pointer.
667 See also C<L</is_utf8_string_loc>>.
672 PERL_STATIC_INLINE bool
673 Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
675 const U8* const send = s + (len ? len : strlen((const char *)s));
679 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
682 const STRLEN cur_len = isUTF8_CHAR(x, send);
683 if (UNLIKELY(! cur_len)) {
702 =for apidoc is_strict_utf8_string_loc
704 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
705 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
706 "utf8ness success") in the C<ep> pointer.
708 See also C<L</is_strict_utf8_string_loclen>>.
713 #define is_strict_utf8_string_loc(s, len, ep) \
714 is_strict_utf8_string_loclen(s, len, ep, 0)
718 =for apidoc is_strict_utf8_string_loclen
720 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
721 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
722 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
723 encoded characters in the C<el> pointer.
725 See also C<L</is_strict_utf8_string_loc>>.
730 PERL_STATIC_INLINE bool
731 S_is_strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
733 const U8* const send = s + (len ? len : strlen((const char *)s));
737 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
740 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
741 if (UNLIKELY(! cur_len)) {
760 =for apidoc is_c9strict_utf8_string_loc
762 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
763 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
764 "utf8ness success") in the C<ep> pointer.
766 See also C<L</is_c9strict_utf8_string_loclen>>.
771 #define is_c9strict_utf8_string_loc(s, len, ep) \
772 is_c9strict_utf8_string_loclen(s, len, ep, 0)
776 =for apidoc is_c9strict_utf8_string_loclen
778 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
779 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
780 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
781 characters in the C<el> pointer.
783 See also C<L</is_c9strict_utf8_string_loc>>.
788 PERL_STATIC_INLINE bool
789 S_is_c9strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
791 const U8* const send = s + (len ? len : strlen((const char *)s));
795 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
798 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
799 if (UNLIKELY(! cur_len)) {
818 =for apidoc is_utf8_string_loc_flags
820 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
821 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
822 "utf8ness success") in the C<ep> pointer.
824 See also C<L</is_utf8_string_loclen_flags>>.
829 #define is_utf8_string_loc_flags(s, len, ep, flags) \
830 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
833 /* The above 3 actual functions could have been moved into the more general one
834 * just below, and made #defines that call it with the right 'flags'. They are
835 * currently kept separate to increase their chances of getting inlined */
839 =for apidoc is_utf8_string_loclen_flags
841 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
842 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
843 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
844 encoded characters in the C<el> pointer.
846 See also C<L</is_utf8_string_loc_flags>>.
851 PERL_STATIC_INLINE bool
852 S_is_utf8_string_loclen_flags(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
854 const U8* const send = s + (len ? len : strlen((const char *)s));
858 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
859 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
860 |UTF8_DISALLOW_PERL_EXTENDED)));
863 return is_utf8_string_loclen(s, len, ep, el);
866 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
867 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
869 return is_strict_utf8_string_loclen(s, len, ep, el);
872 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
873 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
875 return is_c9strict_utf8_string_loclen(s, len, ep, el);
879 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
880 if (UNLIKELY(! cur_len)) {
898 =for apidoc utf8_distance
900 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
903 WARNING: use only if you *know* that the pointers point inside the
909 PERL_STATIC_INLINE IV
910 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
912 PERL_ARGS_ASSERT_UTF8_DISTANCE;
914 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
920 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
923 WARNING: do not use the following unless you *know* C<off> is within
924 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
925 on the first byte of character or just after the last byte of a character.
930 PERL_STATIC_INLINE U8 *
931 Perl_utf8_hop(const U8 *s, SSize_t off)
933 PERL_ARGS_ASSERT_UTF8_HOP;
935 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
936 * the bitops (especially ~) can create illegal UTF-8.
937 * In other words: in Perl UTF-8 is not just for Unicode. */
946 while (UTF8_IS_CONTINUATION(*s))
950 GCC_DIAG_IGNORE(-Wcast-qual);
956 =for apidoc utf8_hop_forward
958 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
961 C<off> must be non-negative.
963 C<s> must be before or equal to C<end>.
965 When moving forward it will not move beyond C<end>.
967 Will not exceed this limit even if the string is not valid "UTF-8".
972 PERL_STATIC_INLINE U8 *
973 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
975 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
977 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
978 * the bitops (especially ~) can create illegal UTF-8.
979 * In other words: in Perl UTF-8 is not just for Unicode. */
985 STRLEN skip = UTF8SKIP(s);
986 if ((STRLEN)(end - s) <= skip) {
987 GCC_DIAG_IGNORE(-Wcast-qual);
994 GCC_DIAG_IGNORE(-Wcast-qual);
1000 =for apidoc utf8_hop_back
1002 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1005 C<off> must be non-positive.
1007 C<s> must be after or equal to C<start>.
1009 When moving backward it will not move before C<start>.
1011 Will not exceed this limit even if the string is not valid "UTF-8".
1016 PERL_STATIC_INLINE U8 *
1017 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1019 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1021 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1022 * the bitops (especially ~) can create illegal UTF-8.
1023 * In other words: in Perl UTF-8 is not just for Unicode. */
1028 while (off++ && s > start) {
1030 while (UTF8_IS_CONTINUATION(*s) && s > start)
1034 GCC_DIAG_IGNORE(-Wcast-qual);
1040 =for apidoc utf8_hop_safe
1042 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1043 either forward or backward.
1045 When moving backward it will not move before C<start>.
1047 When moving forward it will not move beyond C<end>.
1049 Will not exceed those limits even if the string is not valid "UTF-8".
1054 PERL_STATIC_INLINE U8 *
1055 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1057 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1059 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1060 * the bitops (especially ~) can create illegal UTF-8.
1061 * In other words: in Perl UTF-8 is not just for Unicode. */
1063 assert(start <= s && s <= end);
1066 return utf8_hop_forward(s, off, end);
1069 return utf8_hop_back(s, off, start);
1075 =for apidoc is_utf8_valid_partial_char
1077 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1078 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1079 points. Otherwise, it returns 1 if there exists at least one non-empty
1080 sequence of bytes that when appended to sequence C<s>, starting at position
1081 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1082 otherwise returns 0.
1084 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1087 This is useful when a fixed-length buffer is being tested for being well-formed
1088 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1089 it is split somewhere in the middle of the final code point's UTF-8
1090 representation. (Presumably when the buffer is refreshed with the next chunk
1091 of data, the new first bytes will complete the partial code point.) This
1092 function is used to verify that the final bytes in the current buffer are in
1093 fact the legal beginning of some code point, so that if they aren't, the
1094 failure can be signalled without having to wait for the next read.
1098 #define is_utf8_valid_partial_char(s, e) \
1099 is_utf8_valid_partial_char_flags(s, e, 0)
1103 =for apidoc is_utf8_valid_partial_char_flags
1105 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1106 or not the input is a valid UTF-8 encoded partial character, but it takes an
1107 extra parameter, C<flags>, which can further restrict which code points are
1110 If C<flags> is 0, this behaves identically to
1111 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1112 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1113 there is any sequence of bytes that can complete the input partial character in
1114 such a way that a non-prohibited character is formed, the function returns
1115 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1116 partial character input. But many of the other possible excluded types can be
1117 determined from just the first one or two bytes.
1122 PERL_STATIC_INLINE bool
1123 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1125 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1127 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1128 |UTF8_DISALLOW_PERL_EXTENDED)));
1130 if (s >= e || s + UTF8SKIP(s) <= e) {
1134 return cBOOL(_is_utf8_char_helper(s, e, flags));
1139 =for apidoc is_utf8_fixed_width_buf_flags
1141 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1142 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1143 otherwise it returns FALSE.
1145 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1146 without restriction. If the final few bytes of the buffer do not form a
1147 complete code point, this will return TRUE anyway, provided that
1148 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1150 If C<flags> in non-zero, it can be any combination of the
1151 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1154 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1155 returns FALSE if the final few bytes of the string don't form a complete code
1160 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1161 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1165 =for apidoc is_utf8_fixed_width_buf_loc_flags
1167 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1168 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1169 to the beginning of any partial character at the end of the buffer; if there is
1170 no partial character C<*ep> will contain C<s>+C<len>.
1172 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1177 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1178 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1182 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1184 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1185 complete, valid characters found in the C<el> pointer.
1190 PERL_STATIC_INLINE bool
1191 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1197 const U8 * maybe_partial;
1199 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1202 ep = &maybe_partial;
1205 /* If it's entirely valid, return that; otherwise see if the only error is
1206 * that the final few bytes are for a partial character */
1207 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1208 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1211 /* ------------------------------- perl.h ----------------------------- */
1214 =head1 Miscellaneous Functions
1216 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1218 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1219 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1221 Return TRUE if the name is safe.
1223 Used by the C<IS_SAFE_SYSCALL()> macro.
1228 PERL_STATIC_INLINE bool
1229 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1230 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1231 * perl itself uses xce*() functions which accept 8-bit strings.
1234 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1238 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1239 SETERRNO(ENOENT, LIB_INVARG);
1240 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1241 "Invalid \\0 character in %s for %s: %s\\0%s",
1242 what, op_name, pv, null_at+1);
1252 Return true if the supplied filename has a newline character
1253 immediately before the first (hopefully only) NUL.
1255 My original look at this incorrectly used the len from SvPV(), but
1256 that's incorrect, since we allow for a NUL in pv[len-1].
1258 So instead, strlen() and work from there.
1260 This allow for the user reading a filename, forgetting to chomp it,
1263 open my $foo, "$file\0";
1269 PERL_STATIC_INLINE bool
1270 S_should_warn_nl(const char *pv) {
1273 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1277 return len > 0 && pv[len-1] == '\n';
1282 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1284 #define MAX_CHARSET_NAME_LENGTH 2
1286 PERL_STATIC_INLINE const char *
1287 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1289 /* Returns a string that corresponds to the name of the regex character set
1290 * given by 'flags', and *lenp is set the length of that string, which
1291 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1294 switch (get_regex_charset(flags)) {
1295 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1296 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1297 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1298 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1299 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1301 return ASCII_MORE_RESTRICT_PAT_MODS;
1303 /* The NOT_REACHED; hides an assert() which has a rather complex
1304 * definition in perl.h. */
1305 NOT_REACHED; /* NOTREACHED */
1306 return "?"; /* Unknown */
1311 Return false if any get magic is on the SV other than taint magic.
1315 PERL_STATIC_INLINE bool
1316 S_sv_only_taint_gmagic(SV *sv) {
1317 MAGIC *mg = SvMAGIC(sv);
1319 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1322 if (mg->mg_type != PERL_MAGIC_taint
1323 && !(mg->mg_flags & MGf_GSKIP)
1324 && mg->mg_virtual->svt_get) {
1327 mg = mg->mg_moremagic;
1333 /* ------------------ cop.h ------------------------------------------- */
1336 /* Enter a block. Push a new base context and return its address. */
1338 PERL_STATIC_INLINE PERL_CONTEXT *
1339 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1343 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1348 cx->blk_gimme = gimme;
1349 cx->blk_oldsaveix = saveix;
1350 cx->blk_oldsp = (I32)(sp - PL_stack_base);
1351 cx->blk_oldcop = PL_curcop;
1352 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
1353 cx->blk_oldscopesp = PL_scopestack_ix;
1354 cx->blk_oldpm = PL_curpm;
1355 cx->blk_old_tmpsfloor = PL_tmps_floor;
1357 PL_tmps_floor = PL_tmps_ix;
1358 CX_DEBUG(cx, "PUSH");
1363 /* Exit a block (RETURN and LAST). */
1365 PERL_STATIC_INLINE void
1366 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1368 PERL_ARGS_ASSERT_CX_POPBLOCK;
1370 CX_DEBUG(cx, "POP");
1371 /* these 3 are common to cx_popblock and cx_topblock */
1372 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1373 PL_scopestack_ix = cx->blk_oldscopesp;
1374 PL_curpm = cx->blk_oldpm;
1376 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1377 * and leaves a CX entry lying around for repeated use, so
1378 * skip for multicall */ \
1379 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1380 || PL_savestack_ix == cx->blk_oldsaveix);
1381 PL_curcop = cx->blk_oldcop;
1382 PL_tmps_floor = cx->blk_old_tmpsfloor;
1385 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1386 * Whereas cx_popblock() restores the state to the point just before
1387 * cx_pushblock() was called, cx_topblock() restores it to the point just
1388 * *after* cx_pushblock() was called. */
1390 PERL_STATIC_INLINE void
1391 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1393 PERL_ARGS_ASSERT_CX_TOPBLOCK;
1395 CX_DEBUG(cx, "TOP");
1396 /* these 3 are common to cx_popblock and cx_topblock */
1397 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1398 PL_scopestack_ix = cx->blk_oldscopesp;
1399 PL_curpm = cx->blk_oldpm;
1401 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1405 PERL_STATIC_INLINE void
1406 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1408 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1410 PERL_ARGS_ASSERT_CX_PUSHSUB;
1412 PERL_DTRACE_PROBE_ENTRY(cv);
1413 cx->blk_sub.cv = cv;
1414 cx->blk_sub.olddepth = CvDEPTH(cv);
1415 cx->blk_sub.prevcomppad = PL_comppad;
1416 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1417 cx->blk_sub.retop = retop;
1418 SvREFCNT_inc_simple_void_NN(cv);
1419 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1423 /* subsets of cx_popsub() */
1425 PERL_STATIC_INLINE void
1426 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1430 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1431 assert(CxTYPE(cx) == CXt_SUB);
1433 PL_comppad = cx->blk_sub.prevcomppad;
1434 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1435 cv = cx->blk_sub.cv;
1436 CvDEPTH(cv) = cx->blk_sub.olddepth;
1437 cx->blk_sub.cv = NULL;
1442 /* handle the @_ part of leaving a sub */
1444 PERL_STATIC_INLINE void
1445 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1449 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1450 assert(CxTYPE(cx) == CXt_SUB);
1451 assert(AvARRAY(MUTABLE_AV(
1452 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1453 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1455 CX_POP_SAVEARRAY(cx);
1456 av = MUTABLE_AV(PAD_SVl(0));
1457 if (UNLIKELY(AvREAL(av)))
1458 /* abandon @_ if it got reified */
1459 clear_defarray(av, 0);
1466 PERL_STATIC_INLINE void
1467 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1469 PERL_ARGS_ASSERT_CX_POPSUB;
1470 assert(CxTYPE(cx) == CXt_SUB);
1472 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1476 cx_popsub_common(cx);
1480 PERL_STATIC_INLINE void
1481 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1483 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1485 cx->blk_format.cv = cv;
1486 cx->blk_format.retop = retop;
1487 cx->blk_format.gv = gv;
1488 cx->blk_format.dfoutgv = PL_defoutgv;
1489 cx->blk_format.prevcomppad = PL_comppad;
1492 SvREFCNT_inc_simple_void_NN(cv);
1494 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1498 PERL_STATIC_INLINE void
1499 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1504 PERL_ARGS_ASSERT_CX_POPFORMAT;
1505 assert(CxTYPE(cx) == CXt_FORMAT);
1507 dfout = cx->blk_format.dfoutgv;
1509 cx->blk_format.dfoutgv = NULL;
1510 SvREFCNT_dec_NN(dfout);
1512 PL_comppad = cx->blk_format.prevcomppad;
1513 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1514 cv = cx->blk_format.cv;
1515 cx->blk_format.cv = NULL;
1517 SvREFCNT_dec_NN(cv);
1521 PERL_STATIC_INLINE void
1522 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1524 PERL_ARGS_ASSERT_CX_PUSHEVAL;
1526 cx->blk_eval.retop = retop;
1527 cx->blk_eval.old_namesv = namesv;
1528 cx->blk_eval.old_eval_root = PL_eval_root;
1529 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
1530 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
1531 cx->blk_eval.cur_top_env = PL_top_env;
1533 assert(!(PL_in_eval & ~ 0x3F));
1534 assert(!(PL_op->op_type & ~0x1FF));
1535 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1539 PERL_STATIC_INLINE void
1540 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1544 PERL_ARGS_ASSERT_CX_POPEVAL;
1545 assert(CxTYPE(cx) == CXt_EVAL);
1547 PL_in_eval = CxOLD_IN_EVAL(cx);
1548 assert(!(PL_in_eval & 0xc0));
1549 PL_eval_root = cx->blk_eval.old_eval_root;
1550 sv = cx->blk_eval.cur_text;
1551 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1552 cx->blk_eval.cur_text = NULL;
1553 SvREFCNT_dec_NN(sv);
1556 sv = cx->blk_eval.old_namesv;
1558 cx->blk_eval.old_namesv = NULL;
1559 SvREFCNT_dec_NN(sv);
1564 /* push a plain loop, i.e.
1566 * while (cond) { block }
1567 * for (init;cond;continue) { block }
1568 * This loop can be last/redo'ed etc.
1571 PERL_STATIC_INLINE void
1572 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1574 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1575 cx->blk_loop.my_op = cLOOP;
1579 /* push a true for loop, i.e.
1580 * for var (list) { block }
1583 PERL_STATIC_INLINE void
1584 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1586 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1588 /* this one line is common with cx_pushloop_plain */
1589 cx->blk_loop.my_op = cLOOP;
1591 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1592 cx->blk_loop.itersave = itersave;
1594 cx->blk_loop.oldcomppad = PL_comppad;
1599 /* pop all loop types, including plain */
1601 PERL_STATIC_INLINE void
1602 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1604 PERL_ARGS_ASSERT_CX_POPLOOP;
1606 assert(CxTYPE_is_LOOP(cx));
1607 if ( CxTYPE(cx) == CXt_LOOP_ARY
1608 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1610 /* Free ary or cur. This assumes that state_u.ary.ary
1611 * aligns with state_u.lazysv.cur. See cx_dup() */
1612 SV *sv = cx->blk_loop.state_u.lazysv.cur;
1613 cx->blk_loop.state_u.lazysv.cur = NULL;
1614 SvREFCNT_dec_NN(sv);
1615 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1616 sv = cx->blk_loop.state_u.lazysv.end;
1617 cx->blk_loop.state_u.lazysv.end = NULL;
1618 SvREFCNT_dec_NN(sv);
1621 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1623 SV **svp = (cx)->blk_loop.itervar_u.svp;
1624 if ((cx->cx_type & CXp_FOR_GV))
1625 svp = &GvSV((GV*)svp);
1627 *svp = cx->blk_loop.itersave;
1628 cx->blk_loop.itersave = NULL;
1629 SvREFCNT_dec(cursv);
1634 PERL_STATIC_INLINE void
1635 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1637 PERL_ARGS_ASSERT_CX_PUSHWHEN;
1639 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1643 PERL_STATIC_INLINE void
1644 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1646 PERL_ARGS_ASSERT_CX_POPWHEN;
1647 assert(CxTYPE(cx) == CXt_WHEN);
1649 PERL_UNUSED_ARG(cx);
1650 PERL_UNUSED_CONTEXT;
1651 /* currently NOOP */
1655 PERL_STATIC_INLINE void
1656 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1658 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1660 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1661 cx->blk_givwhen.defsv_save = orig_defsv;
1665 PERL_STATIC_INLINE void
1666 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1670 PERL_ARGS_ASSERT_CX_POPGIVEN;
1671 assert(CxTYPE(cx) == CXt_GIVEN);
1673 sv = GvSV(PL_defgv);
1674 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1675 cx->blk_givwhen.defsv_save = NULL;
1679 /* ------------------ util.h ------------------------------------------- */
1682 =head1 Miscellaneous Functions
1686 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1688 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1689 match themselves and their opposite case counterparts. Non-cased and non-ASCII
1690 range bytes match only themselves.
1695 PERL_STATIC_INLINE I32
1696 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1698 const U8 *a = (const U8 *)s1;
1699 const U8 *b = (const U8 *)s2;
1701 PERL_ARGS_ASSERT_FOLDEQ;
1706 if (*a != *b && *a != PL_fold[*b])
1713 PERL_STATIC_INLINE I32
1714 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1716 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1717 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1718 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1719 * does it check that the strings each have at least 'len' characters */
1721 const U8 *a = (const U8 *)s1;
1722 const U8 *b = (const U8 *)s2;
1724 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1729 if (*a != *b && *a != PL_fold_latin1[*b]) {
1738 =for apidoc foldEQ_locale
1740 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1741 same case-insensitively in the current locale; false otherwise.
1746 PERL_STATIC_INLINE I32
1747 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1750 const U8 *a = (const U8 *)s1;
1751 const U8 *b = (const U8 *)s2;
1753 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1758 if (*a != *b && *a != PL_fold_locale[*b])
1765 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1767 PERL_STATIC_INLINE void *
1768 S_my_memrchr(const char * s, const char c, const STRLEN len)
1770 /* memrchr(), since many platforms lack it */
1772 const char * t = s + len - 1;
1774 PERL_ARGS_ASSERT_MY_MEMRCHR;
1789 * ex: set ts=8 sts=4 sw=4 et: