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>.
375 PERL_STATIC_INLINE bool
376 S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
381 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
384 len = strlen((const char *)s);
390 /* Try to get the widest word on this platform */
391 # ifdef HAS_LONG_LONG
392 # define PERL_WORDCAST unsigned long long
393 # define PERL_WORDSIZE LONGLONGSIZE
395 # define PERL_WORDCAST UV
396 # define PERL_WORDSIZE UVSIZE
399 # if PERL_WORDSIZE == 4
400 # define PERL_VARIANTS_WORD_MASK 0x80808080
401 # define PERL_WORD_BOUNDARY_MASK 0x3
402 # elif PERL_WORDSIZE == 8
403 # define PERL_VARIANTS_WORD_MASK UINT64_C(0x8080808080808080)
404 # define PERL_WORD_BOUNDARY_MASK 0x7
406 # error Unexpected word size
409 if ((STRLEN) (send - x) >= PERL_WORDSIZE) {
411 /* Process per-byte until reach word boundary. XXX This loop could be
412 * eliminated if we knew that this platform had fast unaligned reads */
413 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
414 if (! UTF8_IS_INVARIANT(*x)) {
424 /* Process per-word as long as we have at least a full word left */
425 while (x + PERL_WORDSIZE <= send) {
426 if ((* (PERL_WORDCAST *) x) & PERL_VARIANTS_WORD_MASK) {
428 /* Found a variant. Just return if caller doesn't want its
434 /* Otherwise fall into final loop to find which byte it is */
441 # undef PERL_WORDCAST
442 # undef PERL_WORDSIZE
443 # undef PERL_WORD_BOUNDARY_MASK
444 # undef PERL_VARIANTS_WORD_MASK
447 /* Process per-byte */
449 if (! UTF8_IS_INVARIANT(*x)) {
464 =for apidoc is_utf8_string
466 Returns TRUE if the first C<len> bytes of string C<s> form a valid
467 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
468 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
469 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
470 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
472 This function considers Perl's extended UTF-8 to be valid. That means that
473 code points above Unicode, surrogates, and non-character code points are
474 considered valid by this function. Use C<L</is_strict_utf8_string>>,
475 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
476 code points are considered valid.
479 C<L</is_utf8_invariant_string>>,
480 C<L</is_utf8_invariant_string_loc>>,
481 C<L</is_utf8_string_loc>>,
482 C<L</is_utf8_string_loclen>>,
483 C<L</is_utf8_fixed_width_buf_flags>>,
484 C<L</is_utf8_fixed_width_buf_loc_flags>>,
485 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
490 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
492 #if defined(PERL_CORE) || defined (PERL_EXT)
495 =for apidoc is_utf8_non_invariant_string
497 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
498 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
499 UTF-8; otherwise returns FALSE.
501 A TRUE return means that at least one code point represented by the sequence
502 either is a wide character not representable as a single byte, or the
503 representation differs depending on whether the sequence is encoded in UTF-8 or
507 C<L<perlapi/is_utf8_invariant_string>>,
508 C<L<perlapi/is_utf8_string>>
512 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
513 It needn't be if its string is entirely UTF-8 invariant, and it shouldn't be if
514 it otherwise contains invalid UTF-8.
516 It is an internal function because khw thinks that XS code shouldn't be working
517 at this low a level. A valid use case could change that.
521 PERL_STATIC_INLINE bool
522 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
524 const U8 * first_variant;
526 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
528 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
532 return is_utf8_string(first_variant, len - (first_variant - s));
538 =for apidoc is_strict_utf8_string
540 Returns TRUE if the first C<len> bytes of string C<s> form a valid
541 UTF-8-encoded string that is fully interchangeable by any application using
542 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
543 calculated using C<strlen(s)> (which means if you use this option, that C<s>
544 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
545 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
547 This function returns FALSE for strings containing any
548 code points above the Unicode max of 0x10FFFF, surrogate code points, or
549 non-character code points.
552 C<L</is_utf8_invariant_string>>,
553 C<L</is_utf8_invariant_string_loc>>,
554 C<L</is_utf8_string>>,
555 C<L</is_utf8_string_flags>>,
556 C<L</is_utf8_string_loc>>,
557 C<L</is_utf8_string_loc_flags>>,
558 C<L</is_utf8_string_loclen>>,
559 C<L</is_utf8_string_loclen_flags>>,
560 C<L</is_utf8_fixed_width_buf_flags>>,
561 C<L</is_utf8_fixed_width_buf_loc_flags>>,
562 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
563 C<L</is_strict_utf8_string_loc>>,
564 C<L</is_strict_utf8_string_loclen>>,
565 C<L</is_c9strict_utf8_string>>,
566 C<L</is_c9strict_utf8_string_loc>>,
568 C<L</is_c9strict_utf8_string_loclen>>.
573 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
576 =for apidoc is_c9strict_utf8_string
578 Returns TRUE if the first C<len> bytes of string C<s> form a valid
579 UTF-8-encoded string that conforms to
580 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
581 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
582 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
583 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
584 characters being ASCII constitute 'a valid UTF-8 string'.
586 This function returns FALSE for strings containing any code points above the
587 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
589 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
592 C<L</is_utf8_invariant_string>>,
593 C<L</is_utf8_invariant_string_loc>>,
594 C<L</is_utf8_string>>,
595 C<L</is_utf8_string_flags>>,
596 C<L</is_utf8_string_loc>>,
597 C<L</is_utf8_string_loc_flags>>,
598 C<L</is_utf8_string_loclen>>,
599 C<L</is_utf8_string_loclen_flags>>,
600 C<L</is_utf8_fixed_width_buf_flags>>,
601 C<L</is_utf8_fixed_width_buf_loc_flags>>,
602 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
603 C<L</is_strict_utf8_string>>,
604 C<L</is_strict_utf8_string_loc>>,
605 C<L</is_strict_utf8_string_loclen>>,
606 C<L</is_c9strict_utf8_string_loc>>,
608 C<L</is_c9strict_utf8_string_loclen>>.
613 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
616 =for apidoc is_utf8_string_flags
618 Returns TRUE if the first C<len> bytes of string C<s> form a valid
619 UTF-8 string, subject to the restrictions imposed by C<flags>;
620 returns FALSE otherwise. If C<len> is 0, it will be calculated
621 using C<strlen(s)> (which means if you use this option, that C<s> can't have
622 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
623 that all characters being ASCII constitute 'a valid UTF-8 string'.
625 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
626 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
627 as C<L</is_strict_utf8_string>>; and if C<flags> is
628 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
629 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
630 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
631 C<L</utf8n_to_uvchr>>, with the same meanings.
634 C<L</is_utf8_invariant_string>>,
635 C<L</is_utf8_invariant_string_loc>>,
636 C<L</is_utf8_string>>,
637 C<L</is_utf8_string_loc>>,
638 C<L</is_utf8_string_loc_flags>>,
639 C<L</is_utf8_string_loclen>>,
640 C<L</is_utf8_string_loclen_flags>>,
641 C<L</is_utf8_fixed_width_buf_flags>>,
642 C<L</is_utf8_fixed_width_buf_loc_flags>>,
643 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
644 C<L</is_strict_utf8_string>>,
645 C<L</is_strict_utf8_string_loc>>,
646 C<L</is_strict_utf8_string_loclen>>,
647 C<L</is_c9strict_utf8_string>>,
648 C<L</is_c9strict_utf8_string_loc>>,
650 C<L</is_c9strict_utf8_string_loclen>>.
655 PERL_STATIC_INLINE bool
656 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
658 const U8 * first_variant;
660 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
661 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
662 |UTF8_DISALLOW_PERL_EXTENDED)));
665 len = strlen((const char *)s);
669 return is_utf8_string(s, len);
672 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
673 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
675 return is_strict_utf8_string(s, len);
678 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
679 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
681 return is_c9strict_utf8_string(s, len);
684 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
685 const U8* const send = s + len;
686 const U8* x = first_variant;
689 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
690 if (UNLIKELY(! cur_len)) {
702 =for apidoc is_utf8_string_loc
704 Like C<L</is_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_utf8_string_loclen>>.
713 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
717 =for apidoc is_utf8_string_loclen
719 Like C<L</is_utf8_string>> but stores the location of the failure (in the
720 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
721 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
722 encoded characters in the C<el> pointer.
724 See also C<L</is_utf8_string_loc>>.
729 PERL_STATIC_INLINE bool
730 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
732 const U8 * first_variant;
734 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
737 len = strlen((const char *) s);
740 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
752 const U8* const send = s + len;
753 const U8* x = first_variant;
754 STRLEN outlen = first_variant - s;
757 const STRLEN cur_len = isUTF8_CHAR(x, send);
758 if (UNLIKELY(! cur_len)) {
778 =for apidoc is_strict_utf8_string_loc
780 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
781 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
782 "utf8ness success") in the C<ep> pointer.
784 See also C<L</is_strict_utf8_string_loclen>>.
789 #define is_strict_utf8_string_loc(s, len, ep) \
790 is_strict_utf8_string_loclen(s, len, ep, 0)
794 =for apidoc is_strict_utf8_string_loclen
796 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
797 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
798 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
799 encoded characters in the C<el> pointer.
801 See also C<L</is_strict_utf8_string_loc>>.
806 PERL_STATIC_INLINE bool
807 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
809 const U8 * first_variant;
811 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
814 len = strlen((const char *) s);
817 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
829 const U8* const send = s + len;
830 const U8* x = first_variant;
831 STRLEN outlen = first_variant - s;
834 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
835 if (UNLIKELY(! cur_len)) {
855 =for apidoc is_c9strict_utf8_string_loc
857 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
858 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
859 "utf8ness success") in the C<ep> pointer.
861 See also C<L</is_c9strict_utf8_string_loclen>>.
866 #define is_c9strict_utf8_string_loc(s, len, ep) \
867 is_c9strict_utf8_string_loclen(s, len, ep, 0)
871 =for apidoc is_c9strict_utf8_string_loclen
873 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
874 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
875 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
876 characters in the C<el> pointer.
878 See also C<L</is_c9strict_utf8_string_loc>>.
883 PERL_STATIC_INLINE bool
884 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
886 const U8 * first_variant;
888 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
891 len = strlen((const char *) s);
894 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
906 const U8* const send = s + len;
907 const U8* x = first_variant;
908 STRLEN outlen = first_variant - s;
911 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
912 if (UNLIKELY(! cur_len)) {
932 =for apidoc is_utf8_string_loc_flags
934 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
935 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
936 "utf8ness success") in the C<ep> pointer.
938 See also C<L</is_utf8_string_loclen_flags>>.
943 #define is_utf8_string_loc_flags(s, len, ep, flags) \
944 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
947 /* The above 3 actual functions could have been moved into the more general one
948 * just below, and made #defines that call it with the right 'flags'. They are
949 * currently kept separate to increase their chances of getting inlined */
953 =for apidoc is_utf8_string_loclen_flags
955 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
956 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
957 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
958 encoded characters in the C<el> pointer.
960 See also C<L</is_utf8_string_loc_flags>>.
965 PERL_STATIC_INLINE bool
966 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
968 const U8 * first_variant;
970 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
971 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
972 |UTF8_DISALLOW_PERL_EXTENDED)));
975 len = strlen((const char *) s);
979 return is_utf8_string_loclen(s, len, ep, el);
982 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
983 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
985 return is_strict_utf8_string_loclen(s, len, ep, el);
988 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
989 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
991 return is_c9strict_utf8_string_loclen(s, len, ep, el);
994 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1006 const U8* send = s + len;
1007 const U8* x = first_variant;
1008 STRLEN outlen = first_variant - s;
1011 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1012 if (UNLIKELY(! cur_len)) {
1031 =for apidoc utf8_distance
1033 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1036 WARNING: use only if you *know* that the pointers point inside the
1042 PERL_STATIC_INLINE IV
1043 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1045 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1047 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1051 =for apidoc utf8_hop
1053 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1054 forward or backward.
1056 WARNING: do not use the following unless you *know* C<off> is within
1057 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1058 on the first byte of character or just after the last byte of a character.
1063 PERL_STATIC_INLINE U8 *
1064 Perl_utf8_hop(const U8 *s, SSize_t off)
1066 PERL_ARGS_ASSERT_UTF8_HOP;
1068 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1069 * the bitops (especially ~) can create illegal UTF-8.
1070 * In other words: in Perl UTF-8 is not just for Unicode. */
1079 while (UTF8_IS_CONTINUATION(*s))
1083 GCC_DIAG_IGNORE(-Wcast-qual);
1089 =for apidoc utf8_hop_forward
1091 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1094 C<off> must be non-negative.
1096 C<s> must be before or equal to C<end>.
1098 When moving forward it will not move beyond C<end>.
1100 Will not exceed this limit even if the string is not valid "UTF-8".
1105 PERL_STATIC_INLINE U8 *
1106 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1108 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1110 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1111 * the bitops (especially ~) can create illegal UTF-8.
1112 * In other words: in Perl UTF-8 is not just for Unicode. */
1118 STRLEN skip = UTF8SKIP(s);
1119 if ((STRLEN)(end - s) <= skip) {
1120 GCC_DIAG_IGNORE(-Wcast-qual);
1127 GCC_DIAG_IGNORE(-Wcast-qual);
1133 =for apidoc utf8_hop_back
1135 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1138 C<off> must be non-positive.
1140 C<s> must be after or equal to C<start>.
1142 When moving backward it will not move before C<start>.
1144 Will not exceed this limit even if the string is not valid "UTF-8".
1149 PERL_STATIC_INLINE U8 *
1150 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1152 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1154 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1155 * the bitops (especially ~) can create illegal UTF-8.
1156 * In other words: in Perl UTF-8 is not just for Unicode. */
1161 while (off++ && s > start) {
1163 while (UTF8_IS_CONTINUATION(*s) && s > start)
1167 GCC_DIAG_IGNORE(-Wcast-qual);
1173 =for apidoc utf8_hop_safe
1175 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1176 either forward or backward.
1178 When moving backward it will not move before C<start>.
1180 When moving forward it will not move beyond C<end>.
1182 Will not exceed those limits even if the string is not valid "UTF-8".
1187 PERL_STATIC_INLINE U8 *
1188 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1190 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1192 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1193 * the bitops (especially ~) can create illegal UTF-8.
1194 * In other words: in Perl UTF-8 is not just for Unicode. */
1196 assert(start <= s && s <= end);
1199 return utf8_hop_forward(s, off, end);
1202 return utf8_hop_back(s, off, start);
1208 =for apidoc is_utf8_valid_partial_char
1210 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1211 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1212 points. Otherwise, it returns 1 if there exists at least one non-empty
1213 sequence of bytes that when appended to sequence C<s>, starting at position
1214 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1215 otherwise returns 0.
1217 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1220 This is useful when a fixed-length buffer is being tested for being well-formed
1221 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1222 it is split somewhere in the middle of the final code point's UTF-8
1223 representation. (Presumably when the buffer is refreshed with the next chunk
1224 of data, the new first bytes will complete the partial code point.) This
1225 function is used to verify that the final bytes in the current buffer are in
1226 fact the legal beginning of some code point, so that if they aren't, the
1227 failure can be signalled without having to wait for the next read.
1231 #define is_utf8_valid_partial_char(s, e) \
1232 is_utf8_valid_partial_char_flags(s, e, 0)
1236 =for apidoc is_utf8_valid_partial_char_flags
1238 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1239 or not the input is a valid UTF-8 encoded partial character, but it takes an
1240 extra parameter, C<flags>, which can further restrict which code points are
1243 If C<flags> is 0, this behaves identically to
1244 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1245 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1246 there is any sequence of bytes that can complete the input partial character in
1247 such a way that a non-prohibited character is formed, the function returns
1248 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1249 partial character input. But many of the other possible excluded types can be
1250 determined from just the first one or two bytes.
1255 PERL_STATIC_INLINE bool
1256 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1258 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1260 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1261 |UTF8_DISALLOW_PERL_EXTENDED)));
1263 if (s >= e || s + UTF8SKIP(s) <= e) {
1267 return cBOOL(_is_utf8_char_helper(s, e, flags));
1272 =for apidoc is_utf8_fixed_width_buf_flags
1274 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1275 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1276 otherwise it returns FALSE.
1278 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1279 without restriction. If the final few bytes of the buffer do not form a
1280 complete code point, this will return TRUE anyway, provided that
1281 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1283 If C<flags> in non-zero, it can be any combination of the
1284 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1287 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1288 returns FALSE if the final few bytes of the string don't form a complete code
1293 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1294 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1298 =for apidoc is_utf8_fixed_width_buf_loc_flags
1300 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1301 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1302 to the beginning of any partial character at the end of the buffer; if there is
1303 no partial character C<*ep> will contain C<s>+C<len>.
1305 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1310 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1311 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1315 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1317 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1318 complete, valid characters found in the C<el> pointer.
1323 PERL_STATIC_INLINE bool
1324 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1330 const U8 * maybe_partial;
1332 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1335 ep = &maybe_partial;
1338 /* If it's entirely valid, return that; otherwise see if the only error is
1339 * that the final few bytes are for a partial character */
1340 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1341 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1344 /* ------------------------------- perl.h ----------------------------- */
1347 =head1 Miscellaneous Functions
1349 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1351 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1352 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1354 Return TRUE if the name is safe.
1356 Used by the C<IS_SAFE_SYSCALL()> macro.
1361 PERL_STATIC_INLINE bool
1362 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1363 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1364 * perl itself uses xce*() functions which accept 8-bit strings.
1367 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1371 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1372 SETERRNO(ENOENT, LIB_INVARG);
1373 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1374 "Invalid \\0 character in %s for %s: %s\\0%s",
1375 what, op_name, pv, null_at+1);
1385 Return true if the supplied filename has a newline character
1386 immediately before the first (hopefully only) NUL.
1388 My original look at this incorrectly used the len from SvPV(), but
1389 that's incorrect, since we allow for a NUL in pv[len-1].
1391 So instead, strlen() and work from there.
1393 This allow for the user reading a filename, forgetting to chomp it,
1396 open my $foo, "$file\0";
1402 PERL_STATIC_INLINE bool
1403 S_should_warn_nl(const char *pv) {
1406 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1410 return len > 0 && pv[len-1] == '\n';
1415 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1417 #define MAX_CHARSET_NAME_LENGTH 2
1419 PERL_STATIC_INLINE const char *
1420 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1422 /* Returns a string that corresponds to the name of the regex character set
1423 * given by 'flags', and *lenp is set the length of that string, which
1424 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1427 switch (get_regex_charset(flags)) {
1428 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1429 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1430 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1431 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1432 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1434 return ASCII_MORE_RESTRICT_PAT_MODS;
1436 /* The NOT_REACHED; hides an assert() which has a rather complex
1437 * definition in perl.h. */
1438 NOT_REACHED; /* NOTREACHED */
1439 return "?"; /* Unknown */
1444 Return false if any get magic is on the SV other than taint magic.
1448 PERL_STATIC_INLINE bool
1449 S_sv_only_taint_gmagic(SV *sv) {
1450 MAGIC *mg = SvMAGIC(sv);
1452 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1455 if (mg->mg_type != PERL_MAGIC_taint
1456 && !(mg->mg_flags & MGf_GSKIP)
1457 && mg->mg_virtual->svt_get) {
1460 mg = mg->mg_moremagic;
1466 /* ------------------ cop.h ------------------------------------------- */
1469 /* Enter a block. Push a new base context and return its address. */
1471 PERL_STATIC_INLINE PERL_CONTEXT *
1472 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1476 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1481 cx->blk_gimme = gimme;
1482 cx->blk_oldsaveix = saveix;
1483 cx->blk_oldsp = (I32)(sp - PL_stack_base);
1484 cx->blk_oldcop = PL_curcop;
1485 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
1486 cx->blk_oldscopesp = PL_scopestack_ix;
1487 cx->blk_oldpm = PL_curpm;
1488 cx->blk_old_tmpsfloor = PL_tmps_floor;
1490 PL_tmps_floor = PL_tmps_ix;
1491 CX_DEBUG(cx, "PUSH");
1496 /* Exit a block (RETURN and LAST). */
1498 PERL_STATIC_INLINE void
1499 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1501 PERL_ARGS_ASSERT_CX_POPBLOCK;
1503 CX_DEBUG(cx, "POP");
1504 /* these 3 are common to cx_popblock and cx_topblock */
1505 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1506 PL_scopestack_ix = cx->blk_oldscopesp;
1507 PL_curpm = cx->blk_oldpm;
1509 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1510 * and leaves a CX entry lying around for repeated use, so
1511 * skip for multicall */ \
1512 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1513 || PL_savestack_ix == cx->blk_oldsaveix);
1514 PL_curcop = cx->blk_oldcop;
1515 PL_tmps_floor = cx->blk_old_tmpsfloor;
1518 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1519 * Whereas cx_popblock() restores the state to the point just before
1520 * cx_pushblock() was called, cx_topblock() restores it to the point just
1521 * *after* cx_pushblock() was called. */
1523 PERL_STATIC_INLINE void
1524 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1526 PERL_ARGS_ASSERT_CX_TOPBLOCK;
1528 CX_DEBUG(cx, "TOP");
1529 /* these 3 are common to cx_popblock and cx_topblock */
1530 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1531 PL_scopestack_ix = cx->blk_oldscopesp;
1532 PL_curpm = cx->blk_oldpm;
1534 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1538 PERL_STATIC_INLINE void
1539 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1541 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1543 PERL_ARGS_ASSERT_CX_PUSHSUB;
1545 PERL_DTRACE_PROBE_ENTRY(cv);
1546 cx->blk_sub.cv = cv;
1547 cx->blk_sub.olddepth = CvDEPTH(cv);
1548 cx->blk_sub.prevcomppad = PL_comppad;
1549 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1550 cx->blk_sub.retop = retop;
1551 SvREFCNT_inc_simple_void_NN(cv);
1552 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1556 /* subsets of cx_popsub() */
1558 PERL_STATIC_INLINE void
1559 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1563 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1564 assert(CxTYPE(cx) == CXt_SUB);
1566 PL_comppad = cx->blk_sub.prevcomppad;
1567 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1568 cv = cx->blk_sub.cv;
1569 CvDEPTH(cv) = cx->blk_sub.olddepth;
1570 cx->blk_sub.cv = NULL;
1575 /* handle the @_ part of leaving a sub */
1577 PERL_STATIC_INLINE void
1578 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1582 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1583 assert(CxTYPE(cx) == CXt_SUB);
1584 assert(AvARRAY(MUTABLE_AV(
1585 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1586 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1588 CX_POP_SAVEARRAY(cx);
1589 av = MUTABLE_AV(PAD_SVl(0));
1590 if (UNLIKELY(AvREAL(av)))
1591 /* abandon @_ if it got reified */
1592 clear_defarray(av, 0);
1599 PERL_STATIC_INLINE void
1600 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1602 PERL_ARGS_ASSERT_CX_POPSUB;
1603 assert(CxTYPE(cx) == CXt_SUB);
1605 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1609 cx_popsub_common(cx);
1613 PERL_STATIC_INLINE void
1614 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1616 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1618 cx->blk_format.cv = cv;
1619 cx->blk_format.retop = retop;
1620 cx->blk_format.gv = gv;
1621 cx->blk_format.dfoutgv = PL_defoutgv;
1622 cx->blk_format.prevcomppad = PL_comppad;
1625 SvREFCNT_inc_simple_void_NN(cv);
1627 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1631 PERL_STATIC_INLINE void
1632 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1637 PERL_ARGS_ASSERT_CX_POPFORMAT;
1638 assert(CxTYPE(cx) == CXt_FORMAT);
1640 dfout = cx->blk_format.dfoutgv;
1642 cx->blk_format.dfoutgv = NULL;
1643 SvREFCNT_dec_NN(dfout);
1645 PL_comppad = cx->blk_format.prevcomppad;
1646 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1647 cv = cx->blk_format.cv;
1648 cx->blk_format.cv = NULL;
1650 SvREFCNT_dec_NN(cv);
1654 PERL_STATIC_INLINE void
1655 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1657 PERL_ARGS_ASSERT_CX_PUSHEVAL;
1659 cx->blk_eval.retop = retop;
1660 cx->blk_eval.old_namesv = namesv;
1661 cx->blk_eval.old_eval_root = PL_eval_root;
1662 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
1663 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
1664 cx->blk_eval.cur_top_env = PL_top_env;
1666 assert(!(PL_in_eval & ~ 0x3F));
1667 assert(!(PL_op->op_type & ~0x1FF));
1668 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1672 PERL_STATIC_INLINE void
1673 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1677 PERL_ARGS_ASSERT_CX_POPEVAL;
1678 assert(CxTYPE(cx) == CXt_EVAL);
1680 PL_in_eval = CxOLD_IN_EVAL(cx);
1681 assert(!(PL_in_eval & 0xc0));
1682 PL_eval_root = cx->blk_eval.old_eval_root;
1683 sv = cx->blk_eval.cur_text;
1684 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1685 cx->blk_eval.cur_text = NULL;
1686 SvREFCNT_dec_NN(sv);
1689 sv = cx->blk_eval.old_namesv;
1691 cx->blk_eval.old_namesv = NULL;
1692 SvREFCNT_dec_NN(sv);
1697 /* push a plain loop, i.e.
1699 * while (cond) { block }
1700 * for (init;cond;continue) { block }
1701 * This loop can be last/redo'ed etc.
1704 PERL_STATIC_INLINE void
1705 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1707 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1708 cx->blk_loop.my_op = cLOOP;
1712 /* push a true for loop, i.e.
1713 * for var (list) { block }
1716 PERL_STATIC_INLINE void
1717 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1719 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1721 /* this one line is common with cx_pushloop_plain */
1722 cx->blk_loop.my_op = cLOOP;
1724 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1725 cx->blk_loop.itersave = itersave;
1727 cx->blk_loop.oldcomppad = PL_comppad;
1732 /* pop all loop types, including plain */
1734 PERL_STATIC_INLINE void
1735 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1737 PERL_ARGS_ASSERT_CX_POPLOOP;
1739 assert(CxTYPE_is_LOOP(cx));
1740 if ( CxTYPE(cx) == CXt_LOOP_ARY
1741 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1743 /* Free ary or cur. This assumes that state_u.ary.ary
1744 * aligns with state_u.lazysv.cur. See cx_dup() */
1745 SV *sv = cx->blk_loop.state_u.lazysv.cur;
1746 cx->blk_loop.state_u.lazysv.cur = NULL;
1747 SvREFCNT_dec_NN(sv);
1748 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1749 sv = cx->blk_loop.state_u.lazysv.end;
1750 cx->blk_loop.state_u.lazysv.end = NULL;
1751 SvREFCNT_dec_NN(sv);
1754 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1756 SV **svp = (cx)->blk_loop.itervar_u.svp;
1757 if ((cx->cx_type & CXp_FOR_GV))
1758 svp = &GvSV((GV*)svp);
1760 *svp = cx->blk_loop.itersave;
1761 cx->blk_loop.itersave = NULL;
1762 SvREFCNT_dec(cursv);
1767 PERL_STATIC_INLINE void
1768 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1770 PERL_ARGS_ASSERT_CX_PUSHWHEN;
1772 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1776 PERL_STATIC_INLINE void
1777 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1779 PERL_ARGS_ASSERT_CX_POPWHEN;
1780 assert(CxTYPE(cx) == CXt_WHEN);
1782 PERL_UNUSED_ARG(cx);
1783 PERL_UNUSED_CONTEXT;
1784 /* currently NOOP */
1788 PERL_STATIC_INLINE void
1789 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1791 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1793 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1794 cx->blk_givwhen.defsv_save = orig_defsv;
1798 PERL_STATIC_INLINE void
1799 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1803 PERL_ARGS_ASSERT_CX_POPGIVEN;
1804 assert(CxTYPE(cx) == CXt_GIVEN);
1806 sv = GvSV(PL_defgv);
1807 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1808 cx->blk_givwhen.defsv_save = NULL;
1812 /* ------------------ util.h ------------------------------------------- */
1815 =head1 Miscellaneous Functions
1819 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1821 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1822 match themselves and their opposite case counterparts. Non-cased and non-ASCII
1823 range bytes match only themselves.
1828 PERL_STATIC_INLINE I32
1829 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1831 const U8 *a = (const U8 *)s1;
1832 const U8 *b = (const U8 *)s2;
1834 PERL_ARGS_ASSERT_FOLDEQ;
1839 if (*a != *b && *a != PL_fold[*b])
1846 PERL_STATIC_INLINE I32
1847 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1849 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1850 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1851 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1852 * does it check that the strings each have at least 'len' characters */
1854 const U8 *a = (const U8 *)s1;
1855 const U8 *b = (const U8 *)s2;
1857 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1862 if (*a != *b && *a != PL_fold_latin1[*b]) {
1871 =for apidoc foldEQ_locale
1873 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1874 same case-insensitively in the current locale; false otherwise.
1879 PERL_STATIC_INLINE I32
1880 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1883 const U8 *a = (const U8 *)s1;
1884 const U8 *b = (const U8 *)s2;
1886 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1891 if (*a != *b && *a != PL_fold_locale[*b])
1898 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1900 PERL_STATIC_INLINE void *
1901 S_my_memrchr(const char * s, const char c, const STRLEN len)
1903 /* memrchr(), since many platforms lack it */
1905 const char * t = s + len - 1;
1907 PERL_ARGS_ASSERT_MY_MEMRCHR;
1922 * ex: set ts=8 sts=4 sw=4 et: