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);
391 /* This looks like 0x010101... */
392 #define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
394 /* This looks like 0x808080... */
395 #define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
396 #define PERL_WORDSIZE sizeof(PERL_COUNT_MULTIPLIER)
397 #define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
399 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
400 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
401 * optimized out completely on a 32-bit system, and its mask gets optimized out
402 * on a 64-bit system */
403 #define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
404 | ( PTR2nat(x) >> 1) \
406 & PERL_WORD_BOUNDARY_MASK) >> 2))))
408 /* Do the word-at-a-time iff there is at least one usable full word. That
409 * means that after advancing to a word boundary, there still is at least a
410 * full word left. The number of bytes needed to advance is 'wordsize -
411 * offset' unless offset is 0. */
412 if ((STRLEN) (send - x) >= PERL_WORDSIZE
414 /* This term is wordsize if subword; 0 if not */
415 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
418 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
421 /* Process per-byte until reach word boundary. XXX This loop could be
422 * eliminated if we knew that this platform had fast unaligned reads */
423 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
424 if (! UTF8_IS_INVARIANT(*x)) {
434 /* Here, we know we have at least one full word to process. Process
435 * per-word as long as we have at least a full word left */
437 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
439 /* Found a variant. Just return if caller doesn't want its
445 /* Otherwise fall into final loop to find which byte it is */
449 } while (x + PERL_WORDSIZE <= send);
454 /* Process per-byte */
456 if (! UTF8_IS_INVARIANT(*x)) {
470 #if defined(PERL_CORE) || defined(PERL_EXT)
473 =for apidoc variant_under_utf8_count
475 This function looks at the sequence of bytes between C<s> and C<e>, which are
476 assumed to be encoded in ASCII/Latin1, and returns how many of them would
477 change should the string be translated into UTF-8. Due to the nature of UTF-8,
478 each of these would occupy two bytes instead of the single one in the input
479 string. Thus, this function returns the precise number of bytes the string
480 would expand by when translated to UTF-8.
482 Unlike most of the other functions that have C<utf8> in their name, the input
483 to this function is NOT a UTF-8-encoded string. The function name is slightly
484 I<odd> to emphasize this.
486 This function is internal to Perl because khw thinks that any XS code that
487 would want this is probably operating too close to the internals. Presenting a
488 valid use case could change that.
491 C<L<perlapi/is_utf8_invariant_string>>
493 C<L<perlapi/is_utf8_invariant_string_loc>>,
499 PERL_STATIC_INLINE Size_t
500 S_variant_under_utf8_count(const U8* const s, const U8* const e)
505 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
509 if ((STRLEN) (e - x) >= PERL_WORDSIZE
510 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
511 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
514 /* Process per-byte until reach word boundary. XXX This loop could be
515 * eliminated if we knew that this platform had fast unaligned reads */
516 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
517 count += ! UTF8_IS_INVARIANT(*x++);
520 /* Process per-word as long as we have at least a full word left */
521 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
522 explanation of how this works */
523 count += ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
524 * PERL_COUNT_MULTIPLIER)
525 >> ((PERL_WORDSIZE - 1) * CHARBITS);
527 } while (x + PERL_WORDSIZE <= e);
532 /* Process per-byte */
534 if (! UTF8_IS_INVARIANT(*x)) {
547 #undef PERL_COUNT_MULTIPLIER
548 #undef PERL_WORD_BOUNDARY_MASK
549 #undef PERL_VARIANTS_WORD_MASK
552 =for apidoc is_utf8_string
554 Returns TRUE if the first C<len> bytes of string C<s> form a valid
555 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
556 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
557 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
558 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
560 This function considers Perl's extended UTF-8 to be valid. That means that
561 code points above Unicode, surrogates, and non-character code points are
562 considered valid by this function. Use C<L</is_strict_utf8_string>>,
563 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
564 code points are considered valid.
567 C<L</is_utf8_invariant_string>>,
568 C<L</is_utf8_invariant_string_loc>>,
569 C<L</is_utf8_string_loc>>,
570 C<L</is_utf8_string_loclen>>,
571 C<L</is_utf8_fixed_width_buf_flags>>,
572 C<L</is_utf8_fixed_width_buf_loc_flags>>,
573 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
578 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
580 #if defined(PERL_CORE) || defined (PERL_EXT)
583 =for apidoc is_utf8_non_invariant_string
585 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
586 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
587 UTF-8; otherwise returns FALSE.
589 A TRUE return means that at least one code point represented by the sequence
590 either is a wide character not representable as a single byte, or the
591 representation differs depending on whether the sequence is encoded in UTF-8 or
595 C<L<perlapi/is_utf8_invariant_string>>,
596 C<L<perlapi/is_utf8_string>>
600 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
601 It needn't be if its string is entirely UTF-8 invariant, and it shouldn't be if
602 it otherwise contains invalid UTF-8.
604 It is an internal function because khw thinks that XS code shouldn't be working
605 at this low a level. A valid use case could change that.
609 PERL_STATIC_INLINE bool
610 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
612 const U8 * first_variant;
614 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
616 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
620 return is_utf8_string(first_variant, len - (first_variant - s));
626 =for apidoc is_strict_utf8_string
628 Returns TRUE if the first C<len> bytes of string C<s> form a valid
629 UTF-8-encoded string that is fully interchangeable by any application using
630 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
631 calculated using C<strlen(s)> (which means if you use this option, that C<s>
632 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
633 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
635 This function returns FALSE for strings containing any
636 code points above the Unicode max of 0x10FFFF, surrogate code points, or
637 non-character code points.
640 C<L</is_utf8_invariant_string>>,
641 C<L</is_utf8_invariant_string_loc>>,
642 C<L</is_utf8_string>>,
643 C<L</is_utf8_string_flags>>,
644 C<L</is_utf8_string_loc>>,
645 C<L</is_utf8_string_loc_flags>>,
646 C<L</is_utf8_string_loclen>>,
647 C<L</is_utf8_string_loclen_flags>>,
648 C<L</is_utf8_fixed_width_buf_flags>>,
649 C<L</is_utf8_fixed_width_buf_loc_flags>>,
650 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
651 C<L</is_strict_utf8_string_loc>>,
652 C<L</is_strict_utf8_string_loclen>>,
653 C<L</is_c9strict_utf8_string>>,
654 C<L</is_c9strict_utf8_string_loc>>,
656 C<L</is_c9strict_utf8_string_loclen>>.
661 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
664 =for apidoc is_c9strict_utf8_string
666 Returns TRUE if the first C<len> bytes of string C<s> form a valid
667 UTF-8-encoded string that conforms to
668 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
669 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
670 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
671 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
672 characters being ASCII constitute 'a valid UTF-8 string'.
674 This function returns FALSE for strings containing any code points above the
675 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
677 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
680 C<L</is_utf8_invariant_string>>,
681 C<L</is_utf8_invariant_string_loc>>,
682 C<L</is_utf8_string>>,
683 C<L</is_utf8_string_flags>>,
684 C<L</is_utf8_string_loc>>,
685 C<L</is_utf8_string_loc_flags>>,
686 C<L</is_utf8_string_loclen>>,
687 C<L</is_utf8_string_loclen_flags>>,
688 C<L</is_utf8_fixed_width_buf_flags>>,
689 C<L</is_utf8_fixed_width_buf_loc_flags>>,
690 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
691 C<L</is_strict_utf8_string>>,
692 C<L</is_strict_utf8_string_loc>>,
693 C<L</is_strict_utf8_string_loclen>>,
694 C<L</is_c9strict_utf8_string_loc>>,
696 C<L</is_c9strict_utf8_string_loclen>>.
701 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
704 =for apidoc is_utf8_string_flags
706 Returns TRUE if the first C<len> bytes of string C<s> form a valid
707 UTF-8 string, subject to the restrictions imposed by C<flags>;
708 returns FALSE otherwise. If C<len> is 0, it will be calculated
709 using C<strlen(s)> (which means if you use this option, that C<s> can't have
710 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
711 that all characters being ASCII constitute 'a valid UTF-8 string'.
713 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
714 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
715 as C<L</is_strict_utf8_string>>; and if C<flags> is
716 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
717 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
718 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
719 C<L</utf8n_to_uvchr>>, with the same meanings.
722 C<L</is_utf8_invariant_string>>,
723 C<L</is_utf8_invariant_string_loc>>,
724 C<L</is_utf8_string>>,
725 C<L</is_utf8_string_loc>>,
726 C<L</is_utf8_string_loc_flags>>,
727 C<L</is_utf8_string_loclen>>,
728 C<L</is_utf8_string_loclen_flags>>,
729 C<L</is_utf8_fixed_width_buf_flags>>,
730 C<L</is_utf8_fixed_width_buf_loc_flags>>,
731 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
732 C<L</is_strict_utf8_string>>,
733 C<L</is_strict_utf8_string_loc>>,
734 C<L</is_strict_utf8_string_loclen>>,
735 C<L</is_c9strict_utf8_string>>,
736 C<L</is_c9strict_utf8_string_loc>>,
738 C<L</is_c9strict_utf8_string_loclen>>.
743 PERL_STATIC_INLINE bool
744 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
746 const U8 * first_variant;
748 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
749 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
750 |UTF8_DISALLOW_PERL_EXTENDED)));
753 len = strlen((const char *)s);
757 return is_utf8_string(s, len);
760 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
761 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
763 return is_strict_utf8_string(s, len);
766 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
767 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
769 return is_c9strict_utf8_string(s, len);
772 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
773 const U8* const send = s + len;
774 const U8* x = first_variant;
777 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
778 if (UNLIKELY(! cur_len)) {
790 =for apidoc is_utf8_string_loc
792 Like C<L</is_utf8_string>> but stores the location of the failure (in the
793 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
794 "utf8ness success") in the C<ep> pointer.
796 See also C<L</is_utf8_string_loclen>>.
801 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
805 =for apidoc is_utf8_string_loclen
807 Like C<L</is_utf8_string>> but stores the location of the failure (in the
808 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
809 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
810 encoded characters in the C<el> pointer.
812 See also C<L</is_utf8_string_loc>>.
817 PERL_STATIC_INLINE bool
818 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
820 const U8 * first_variant;
822 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
825 len = strlen((const char *) s);
828 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
840 const U8* const send = s + len;
841 const U8* x = first_variant;
842 STRLEN outlen = first_variant - s;
845 const STRLEN cur_len = isUTF8_CHAR(x, send);
846 if (UNLIKELY(! cur_len)) {
866 =for apidoc is_strict_utf8_string_loc
868 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
869 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
870 "utf8ness success") in the C<ep> pointer.
872 See also C<L</is_strict_utf8_string_loclen>>.
877 #define is_strict_utf8_string_loc(s, len, ep) \
878 is_strict_utf8_string_loclen(s, len, ep, 0)
882 =for apidoc is_strict_utf8_string_loclen
884 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
885 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
886 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
887 encoded characters in the C<el> pointer.
889 See also C<L</is_strict_utf8_string_loc>>.
894 PERL_STATIC_INLINE bool
895 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
897 const U8 * first_variant;
899 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
902 len = strlen((const char *) s);
905 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
917 const U8* const send = s + len;
918 const U8* x = first_variant;
919 STRLEN outlen = first_variant - s;
922 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
923 if (UNLIKELY(! cur_len)) {
943 =for apidoc is_c9strict_utf8_string_loc
945 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
946 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
947 "utf8ness success") in the C<ep> pointer.
949 See also C<L</is_c9strict_utf8_string_loclen>>.
954 #define is_c9strict_utf8_string_loc(s, len, ep) \
955 is_c9strict_utf8_string_loclen(s, len, ep, 0)
959 =for apidoc is_c9strict_utf8_string_loclen
961 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
962 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
963 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
964 characters in the C<el> pointer.
966 See also C<L</is_c9strict_utf8_string_loc>>.
971 PERL_STATIC_INLINE bool
972 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
974 const U8 * first_variant;
976 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
979 len = strlen((const char *) s);
982 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
994 const U8* const send = s + len;
995 const U8* x = first_variant;
996 STRLEN outlen = first_variant - s;
999 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1000 if (UNLIKELY(! cur_len)) {
1020 =for apidoc is_utf8_string_loc_flags
1022 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1023 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1024 "utf8ness success") in the C<ep> pointer.
1026 See also C<L</is_utf8_string_loclen_flags>>.
1031 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1032 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1035 /* The above 3 actual functions could have been moved into the more general one
1036 * just below, and made #defines that call it with the right 'flags'. They are
1037 * currently kept separate to increase their chances of getting inlined */
1041 =for apidoc is_utf8_string_loclen_flags
1043 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1044 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1045 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1046 encoded characters in the C<el> pointer.
1048 See also C<L</is_utf8_string_loc_flags>>.
1053 PERL_STATIC_INLINE bool
1054 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1056 const U8 * first_variant;
1058 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1059 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1060 |UTF8_DISALLOW_PERL_EXTENDED)));
1063 len = strlen((const char *) s);
1067 return is_utf8_string_loclen(s, len, ep, el);
1070 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1071 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1073 return is_strict_utf8_string_loclen(s, len, ep, el);
1076 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1077 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1079 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1082 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1094 const U8* send = s + len;
1095 const U8* x = first_variant;
1096 STRLEN outlen = first_variant - s;
1099 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1100 if (UNLIKELY(! cur_len)) {
1119 =for apidoc utf8_distance
1121 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1124 WARNING: use only if you *know* that the pointers point inside the
1130 PERL_STATIC_INLINE IV
1131 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1133 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1135 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1139 =for apidoc utf8_hop
1141 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1142 forward or backward.
1144 WARNING: do not use the following unless you *know* C<off> is within
1145 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1146 on the first byte of character or just after the last byte of a character.
1151 PERL_STATIC_INLINE U8 *
1152 Perl_utf8_hop(const U8 *s, SSize_t off)
1154 PERL_ARGS_ASSERT_UTF8_HOP;
1156 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1157 * the bitops (especially ~) can create illegal UTF-8.
1158 * In other words: in Perl UTF-8 is not just for Unicode. */
1167 while (UTF8_IS_CONTINUATION(*s))
1171 GCC_DIAG_IGNORE(-Wcast-qual);
1177 =for apidoc utf8_hop_forward
1179 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1182 C<off> must be non-negative.
1184 C<s> must be before or equal to C<end>.
1186 When moving forward it will not move beyond C<end>.
1188 Will not exceed this limit even if the string is not valid "UTF-8".
1193 PERL_STATIC_INLINE U8 *
1194 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1196 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1198 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1199 * the bitops (especially ~) can create illegal UTF-8.
1200 * In other words: in Perl UTF-8 is not just for Unicode. */
1206 STRLEN skip = UTF8SKIP(s);
1207 if ((STRLEN)(end - s) <= skip) {
1208 GCC_DIAG_IGNORE(-Wcast-qual);
1215 GCC_DIAG_IGNORE(-Wcast-qual);
1221 =for apidoc utf8_hop_back
1223 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1226 C<off> must be non-positive.
1228 C<s> must be after or equal to C<start>.
1230 When moving backward it will not move before C<start>.
1232 Will not exceed this limit even if the string is not valid "UTF-8".
1237 PERL_STATIC_INLINE U8 *
1238 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1240 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1242 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1243 * the bitops (especially ~) can create illegal UTF-8.
1244 * In other words: in Perl UTF-8 is not just for Unicode. */
1249 while (off++ && s > start) {
1251 while (UTF8_IS_CONTINUATION(*s) && s > start)
1255 GCC_DIAG_IGNORE(-Wcast-qual);
1261 =for apidoc utf8_hop_safe
1263 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1264 either forward or backward.
1266 When moving backward it will not move before C<start>.
1268 When moving forward it will not move beyond C<end>.
1270 Will not exceed those limits even if the string is not valid "UTF-8".
1275 PERL_STATIC_INLINE U8 *
1276 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1278 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1280 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1281 * the bitops (especially ~) can create illegal UTF-8.
1282 * In other words: in Perl UTF-8 is not just for Unicode. */
1284 assert(start <= s && s <= end);
1287 return utf8_hop_forward(s, off, end);
1290 return utf8_hop_back(s, off, start);
1296 =for apidoc is_utf8_valid_partial_char
1298 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1299 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1300 points. Otherwise, it returns 1 if there exists at least one non-empty
1301 sequence of bytes that when appended to sequence C<s>, starting at position
1302 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1303 otherwise returns 0.
1305 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1308 This is useful when a fixed-length buffer is being tested for being well-formed
1309 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1310 it is split somewhere in the middle of the final code point's UTF-8
1311 representation. (Presumably when the buffer is refreshed with the next chunk
1312 of data, the new first bytes will complete the partial code point.) This
1313 function is used to verify that the final bytes in the current buffer are in
1314 fact the legal beginning of some code point, so that if they aren't, the
1315 failure can be signalled without having to wait for the next read.
1319 #define is_utf8_valid_partial_char(s, e) \
1320 is_utf8_valid_partial_char_flags(s, e, 0)
1324 =for apidoc is_utf8_valid_partial_char_flags
1326 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1327 or not the input is a valid UTF-8 encoded partial character, but it takes an
1328 extra parameter, C<flags>, which can further restrict which code points are
1331 If C<flags> is 0, this behaves identically to
1332 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1333 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1334 there is any sequence of bytes that can complete the input partial character in
1335 such a way that a non-prohibited character is formed, the function returns
1336 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1337 partial character input. But many of the other possible excluded types can be
1338 determined from just the first one or two bytes.
1343 PERL_STATIC_INLINE bool
1344 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1346 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1348 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1349 |UTF8_DISALLOW_PERL_EXTENDED)));
1351 if (s >= e || s + UTF8SKIP(s) <= e) {
1355 return cBOOL(_is_utf8_char_helper(s, e, flags));
1360 =for apidoc is_utf8_fixed_width_buf_flags
1362 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1363 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1364 otherwise it returns FALSE.
1366 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1367 without restriction. If the final few bytes of the buffer do not form a
1368 complete code point, this will return TRUE anyway, provided that
1369 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1371 If C<flags> in non-zero, it can be any combination of the
1372 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1375 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1376 returns FALSE if the final few bytes of the string don't form a complete code
1381 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1382 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1386 =for apidoc is_utf8_fixed_width_buf_loc_flags
1388 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1389 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1390 to the beginning of any partial character at the end of the buffer; if there is
1391 no partial character C<*ep> will contain C<s>+C<len>.
1393 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1398 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1399 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1403 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1405 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1406 complete, valid characters found in the C<el> pointer.
1411 PERL_STATIC_INLINE bool
1412 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1418 const U8 * maybe_partial;
1420 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1423 ep = &maybe_partial;
1426 /* If it's entirely valid, return that; otherwise see if the only error is
1427 * that the final few bytes are for a partial character */
1428 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1429 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1432 /* ------------------------------- perl.h ----------------------------- */
1435 =head1 Miscellaneous Functions
1437 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1439 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1440 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1442 Return TRUE if the name is safe.
1444 Used by the C<IS_SAFE_SYSCALL()> macro.
1449 PERL_STATIC_INLINE bool
1450 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1451 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1452 * perl itself uses xce*() functions which accept 8-bit strings.
1455 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1459 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1460 SETERRNO(ENOENT, LIB_INVARG);
1461 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1462 "Invalid \\0 character in %s for %s: %s\\0%s",
1463 what, op_name, pv, null_at+1);
1473 Return true if the supplied filename has a newline character
1474 immediately before the first (hopefully only) NUL.
1476 My original look at this incorrectly used the len from SvPV(), but
1477 that's incorrect, since we allow for a NUL in pv[len-1].
1479 So instead, strlen() and work from there.
1481 This allow for the user reading a filename, forgetting to chomp it,
1484 open my $foo, "$file\0";
1490 PERL_STATIC_INLINE bool
1491 S_should_warn_nl(const char *pv) {
1494 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1498 return len > 0 && pv[len-1] == '\n';
1503 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1505 #define MAX_CHARSET_NAME_LENGTH 2
1507 PERL_STATIC_INLINE const char *
1508 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1510 /* Returns a string that corresponds to the name of the regex character set
1511 * given by 'flags', and *lenp is set the length of that string, which
1512 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1515 switch (get_regex_charset(flags)) {
1516 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1517 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1518 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1519 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1520 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1522 return ASCII_MORE_RESTRICT_PAT_MODS;
1524 /* The NOT_REACHED; hides an assert() which has a rather complex
1525 * definition in perl.h. */
1526 NOT_REACHED; /* NOTREACHED */
1527 return "?"; /* Unknown */
1532 Return false if any get magic is on the SV other than taint magic.
1536 PERL_STATIC_INLINE bool
1537 S_sv_only_taint_gmagic(SV *sv) {
1538 MAGIC *mg = SvMAGIC(sv);
1540 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1543 if (mg->mg_type != PERL_MAGIC_taint
1544 && !(mg->mg_flags & MGf_GSKIP)
1545 && mg->mg_virtual->svt_get) {
1548 mg = mg->mg_moremagic;
1554 /* ------------------ cop.h ------------------------------------------- */
1557 /* Enter a block. Push a new base context and return its address. */
1559 PERL_STATIC_INLINE PERL_CONTEXT *
1560 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1564 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1569 cx->blk_gimme = gimme;
1570 cx->blk_oldsaveix = saveix;
1571 cx->blk_oldsp = (I32)(sp - PL_stack_base);
1572 cx->blk_oldcop = PL_curcop;
1573 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
1574 cx->blk_oldscopesp = PL_scopestack_ix;
1575 cx->blk_oldpm = PL_curpm;
1576 cx->blk_old_tmpsfloor = PL_tmps_floor;
1578 PL_tmps_floor = PL_tmps_ix;
1579 CX_DEBUG(cx, "PUSH");
1584 /* Exit a block (RETURN and LAST). */
1586 PERL_STATIC_INLINE void
1587 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1589 PERL_ARGS_ASSERT_CX_POPBLOCK;
1591 CX_DEBUG(cx, "POP");
1592 /* these 3 are common to cx_popblock and cx_topblock */
1593 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1594 PL_scopestack_ix = cx->blk_oldscopesp;
1595 PL_curpm = cx->blk_oldpm;
1597 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1598 * and leaves a CX entry lying around for repeated use, so
1599 * skip for multicall */ \
1600 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1601 || PL_savestack_ix == cx->blk_oldsaveix);
1602 PL_curcop = cx->blk_oldcop;
1603 PL_tmps_floor = cx->blk_old_tmpsfloor;
1606 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1607 * Whereas cx_popblock() restores the state to the point just before
1608 * cx_pushblock() was called, cx_topblock() restores it to the point just
1609 * *after* cx_pushblock() was called. */
1611 PERL_STATIC_INLINE void
1612 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1614 PERL_ARGS_ASSERT_CX_TOPBLOCK;
1616 CX_DEBUG(cx, "TOP");
1617 /* these 3 are common to cx_popblock and cx_topblock */
1618 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1619 PL_scopestack_ix = cx->blk_oldscopesp;
1620 PL_curpm = cx->blk_oldpm;
1622 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1626 PERL_STATIC_INLINE void
1627 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1629 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1631 PERL_ARGS_ASSERT_CX_PUSHSUB;
1633 PERL_DTRACE_PROBE_ENTRY(cv);
1634 cx->blk_sub.cv = cv;
1635 cx->blk_sub.olddepth = CvDEPTH(cv);
1636 cx->blk_sub.prevcomppad = PL_comppad;
1637 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1638 cx->blk_sub.retop = retop;
1639 SvREFCNT_inc_simple_void_NN(cv);
1640 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1644 /* subsets of cx_popsub() */
1646 PERL_STATIC_INLINE void
1647 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1651 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1652 assert(CxTYPE(cx) == CXt_SUB);
1654 PL_comppad = cx->blk_sub.prevcomppad;
1655 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1656 cv = cx->blk_sub.cv;
1657 CvDEPTH(cv) = cx->blk_sub.olddepth;
1658 cx->blk_sub.cv = NULL;
1663 /* handle the @_ part of leaving a sub */
1665 PERL_STATIC_INLINE void
1666 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1670 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1671 assert(CxTYPE(cx) == CXt_SUB);
1672 assert(AvARRAY(MUTABLE_AV(
1673 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1674 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1676 CX_POP_SAVEARRAY(cx);
1677 av = MUTABLE_AV(PAD_SVl(0));
1678 if (UNLIKELY(AvREAL(av)))
1679 /* abandon @_ if it got reified */
1680 clear_defarray(av, 0);
1687 PERL_STATIC_INLINE void
1688 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1690 PERL_ARGS_ASSERT_CX_POPSUB;
1691 assert(CxTYPE(cx) == CXt_SUB);
1693 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1697 cx_popsub_common(cx);
1701 PERL_STATIC_INLINE void
1702 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1704 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1706 cx->blk_format.cv = cv;
1707 cx->blk_format.retop = retop;
1708 cx->blk_format.gv = gv;
1709 cx->blk_format.dfoutgv = PL_defoutgv;
1710 cx->blk_format.prevcomppad = PL_comppad;
1713 SvREFCNT_inc_simple_void_NN(cv);
1715 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1719 PERL_STATIC_INLINE void
1720 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1725 PERL_ARGS_ASSERT_CX_POPFORMAT;
1726 assert(CxTYPE(cx) == CXt_FORMAT);
1728 dfout = cx->blk_format.dfoutgv;
1730 cx->blk_format.dfoutgv = NULL;
1731 SvREFCNT_dec_NN(dfout);
1733 PL_comppad = cx->blk_format.prevcomppad;
1734 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1735 cv = cx->blk_format.cv;
1736 cx->blk_format.cv = NULL;
1738 SvREFCNT_dec_NN(cv);
1742 PERL_STATIC_INLINE void
1743 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1745 PERL_ARGS_ASSERT_CX_PUSHEVAL;
1747 cx->blk_eval.retop = retop;
1748 cx->blk_eval.old_namesv = namesv;
1749 cx->blk_eval.old_eval_root = PL_eval_root;
1750 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
1751 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
1752 cx->blk_eval.cur_top_env = PL_top_env;
1754 assert(!(PL_in_eval & ~ 0x3F));
1755 assert(!(PL_op->op_type & ~0x1FF));
1756 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1760 PERL_STATIC_INLINE void
1761 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1765 PERL_ARGS_ASSERT_CX_POPEVAL;
1766 assert(CxTYPE(cx) == CXt_EVAL);
1768 PL_in_eval = CxOLD_IN_EVAL(cx);
1769 assert(!(PL_in_eval & 0xc0));
1770 PL_eval_root = cx->blk_eval.old_eval_root;
1771 sv = cx->blk_eval.cur_text;
1772 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1773 cx->blk_eval.cur_text = NULL;
1774 SvREFCNT_dec_NN(sv);
1777 sv = cx->blk_eval.old_namesv;
1779 cx->blk_eval.old_namesv = NULL;
1780 SvREFCNT_dec_NN(sv);
1785 /* push a plain loop, i.e.
1787 * while (cond) { block }
1788 * for (init;cond;continue) { block }
1789 * This loop can be last/redo'ed etc.
1792 PERL_STATIC_INLINE void
1793 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1795 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1796 cx->blk_loop.my_op = cLOOP;
1800 /* push a true for loop, i.e.
1801 * for var (list) { block }
1804 PERL_STATIC_INLINE void
1805 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1807 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1809 /* this one line is common with cx_pushloop_plain */
1810 cx->blk_loop.my_op = cLOOP;
1812 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1813 cx->blk_loop.itersave = itersave;
1815 cx->blk_loop.oldcomppad = PL_comppad;
1820 /* pop all loop types, including plain */
1822 PERL_STATIC_INLINE void
1823 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1825 PERL_ARGS_ASSERT_CX_POPLOOP;
1827 assert(CxTYPE_is_LOOP(cx));
1828 if ( CxTYPE(cx) == CXt_LOOP_ARY
1829 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1831 /* Free ary or cur. This assumes that state_u.ary.ary
1832 * aligns with state_u.lazysv.cur. See cx_dup() */
1833 SV *sv = cx->blk_loop.state_u.lazysv.cur;
1834 cx->blk_loop.state_u.lazysv.cur = NULL;
1835 SvREFCNT_dec_NN(sv);
1836 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1837 sv = cx->blk_loop.state_u.lazysv.end;
1838 cx->blk_loop.state_u.lazysv.end = NULL;
1839 SvREFCNT_dec_NN(sv);
1842 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1844 SV **svp = (cx)->blk_loop.itervar_u.svp;
1845 if ((cx->cx_type & CXp_FOR_GV))
1846 svp = &GvSV((GV*)svp);
1848 *svp = cx->blk_loop.itersave;
1849 cx->blk_loop.itersave = NULL;
1850 SvREFCNT_dec(cursv);
1855 PERL_STATIC_INLINE void
1856 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1858 PERL_ARGS_ASSERT_CX_PUSHWHEN;
1860 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1864 PERL_STATIC_INLINE void
1865 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1867 PERL_ARGS_ASSERT_CX_POPWHEN;
1868 assert(CxTYPE(cx) == CXt_WHEN);
1870 PERL_UNUSED_ARG(cx);
1871 PERL_UNUSED_CONTEXT;
1872 /* currently NOOP */
1876 PERL_STATIC_INLINE void
1877 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1879 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1881 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1882 cx->blk_givwhen.defsv_save = orig_defsv;
1886 PERL_STATIC_INLINE void
1887 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1891 PERL_ARGS_ASSERT_CX_POPGIVEN;
1892 assert(CxTYPE(cx) == CXt_GIVEN);
1894 sv = GvSV(PL_defgv);
1895 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1896 cx->blk_givwhen.defsv_save = NULL;
1900 /* ------------------ util.h ------------------------------------------- */
1903 =head1 Miscellaneous Functions
1907 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1909 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1910 match themselves and their opposite case counterparts. Non-cased and non-ASCII
1911 range bytes match only themselves.
1916 PERL_STATIC_INLINE I32
1917 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1919 const U8 *a = (const U8 *)s1;
1920 const U8 *b = (const U8 *)s2;
1922 PERL_ARGS_ASSERT_FOLDEQ;
1927 if (*a != *b && *a != PL_fold[*b])
1934 PERL_STATIC_INLINE I32
1935 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1937 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1938 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1939 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1940 * does it check that the strings each have at least 'len' characters */
1942 const U8 *a = (const U8 *)s1;
1943 const U8 *b = (const U8 *)s2;
1945 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1950 if (*a != *b && *a != PL_fold_latin1[*b]) {
1959 =for apidoc foldEQ_locale
1961 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1962 same case-insensitively in the current locale; false otherwise.
1967 PERL_STATIC_INLINE I32
1968 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1971 const U8 *a = (const U8 *)s1;
1972 const U8 *b = (const U8 *)s2;
1974 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1979 if (*a != *b && *a != PL_fold_locale[*b])
1986 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1988 PERL_STATIC_INLINE void *
1989 S_my_memrchr(const char * s, const char c, const STRLEN len)
1991 /* memrchr(), since many platforms lack it */
1993 const char * t = s + len - 1;
1995 PERL_ARGS_ASSERT_MY_MEMRCHR;
2010 * ex: set ts=8 sts=4 sw=4 et: