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 GCC_DIAG_IGNORE_DECL(-Wunused-function);
249 S_croak_memory_wrap(void)
251 Perl_croak_nocontext("%s",PL_memory_wrap);
253 GCC_DIAG_RESTORE_DECL;
255 /* ------------------------------- utf8.h ------------------------------- */
258 =head1 Unicode Support
261 PERL_STATIC_INLINE void
262 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
264 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
265 * encoded string at '*dest', updating '*dest' to include it */
267 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
269 if (NATIVE_BYTE_IS_INVARIANT(byte))
272 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
273 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
278 =for apidoc valid_utf8_to_uvchr
279 Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
280 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
281 it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
282 non-Unicode code points are allowed.
288 PERL_STATIC_INLINE UV
289 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
291 const UV expectlen = UTF8SKIP(s);
292 const U8* send = s + expectlen;
295 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
301 /* An invariant is trivially returned */
302 if (expectlen == 1) {
306 /* Remove the leading bits that indicate the number of bytes, leaving just
307 * the bits that are part of the value */
308 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
310 /* Now, loop through the remaining bytes, accumulating each into the
311 * working total as we go. (I khw tried unrolling the loop for up to 4
312 * bytes, but there was no performance improvement) */
313 for (++s; s < send; s++) {
314 uv = UTF8_ACCUMULATE(uv, *s);
317 return UNI_TO_NATIVE(uv);
322 =for apidoc is_utf8_invariant_string
324 Returns TRUE if the first C<len> bytes of the string C<s> are the same
325 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
326 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
327 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
328 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
329 characters are invariant, but so also are the C1 controls.
331 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
332 use this option, that C<s> can't have embedded C<NUL> characters and has to
333 have a terminating C<NUL> byte).
336 C<L</is_utf8_string>>,
337 C<L</is_utf8_string_flags>>,
338 C<L</is_utf8_string_loc>>,
339 C<L</is_utf8_string_loc_flags>>,
340 C<L</is_utf8_string_loclen>>,
341 C<L</is_utf8_string_loclen_flags>>,
342 C<L</is_utf8_fixed_width_buf_flags>>,
343 C<L</is_utf8_fixed_width_buf_loc_flags>>,
344 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
345 C<L</is_strict_utf8_string>>,
346 C<L</is_strict_utf8_string_loc>>,
347 C<L</is_strict_utf8_string_loclen>>,
348 C<L</is_c9strict_utf8_string>>,
349 C<L</is_c9strict_utf8_string_loc>>,
351 C<L</is_c9strict_utf8_string_loclen>>.
357 #define is_utf8_invariant_string(s, len) \
358 is_utf8_invariant_string_loc(s, len, NULL)
361 =for apidoc is_utf8_invariant_string_loc
363 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
364 the first UTF-8 variant character in the C<ep> pointer; if all characters are
365 UTF-8 invariant, this function does not change the contents of C<*ep>.
371 PERL_STATIC_INLINE bool
372 S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
377 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
380 len = strlen((const char *)s);
387 /* This looks like 0x010101... */
388 #define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
390 /* This looks like 0x808080... */
391 #define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
392 #define PERL_WORDSIZE sizeof(PERL_COUNT_MULTIPLIER)
393 #define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
395 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
396 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
397 * optimized out completely on a 32-bit system, and its mask gets optimized out
398 * on a 64-bit system */
399 #define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
400 | ( PTR2nat(x) >> 1) \
402 & PERL_WORD_BOUNDARY_MASK) >> 2))))
404 /* Do the word-at-a-time iff there is at least one usable full word. That
405 * means that after advancing to a word boundary, there still is at least a
406 * full word left. The number of bytes needed to advance is 'wordsize -
407 * offset' unless offset is 0. */
408 if ((STRLEN) (send - x) >= PERL_WORDSIZE
410 /* This term is wordsize if subword; 0 if not */
411 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
414 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
417 /* Process per-byte until reach word boundary. XXX This loop could be
418 * eliminated if we knew that this platform had fast unaligned reads */
419 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
420 if (! UTF8_IS_INVARIANT(*x)) {
430 /* Here, we know we have at least one full word to process. Process
431 * per-word as long as we have at least a full word left */
433 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
435 /* Found a variant. Just return if caller doesn't want its
441 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
442 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
444 *ep = x + _variant_byte_number(* (PERL_UINTMAX_T *) x);
445 assert(*ep >= s && *ep < send);
449 #else /* If weird byte order, drop into next loop to do byte-at-a-time
458 } while (x + PERL_WORDSIZE <= send);
461 #endif /* End of ! EBCDIC */
463 /* Process per-byte */
465 if (! UTF8_IS_INVARIANT(*x)) {
479 PERL_STATIC_INLINE unsigned int
480 S__variant_byte_number(PERL_UINTMAX_T word)
483 /* This returns the position in a word (0..7) of the first variant byte in
484 * it. This is a helper function. Note that there are no branches */
488 /* Get just the msb bits of each byte */
489 word &= PERL_VARIANTS_WORD_MASK;
491 # ifdef USING_MSVC6 /* VC6 has some issues with the normal code, and the
492 easiest thing is to hide that from the callers */
495 const U8 * s = (U8 *) &word;
498 for (i = 0; i < sizeof(word); i++ ) {
504 Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
508 # elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
510 /* Bytes are stored like
511 * Byte8 ... Byte2 Byte1
512 * 63..56...15...8 7...0
515 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
517 * The word will look this this, with a rightmost set bit in position 's':
518 * ('x's are don't cares)
521 * x..xx10..0 Right shift (rightmost 0 is shifted off)
522 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
523 * the 1 just to their left into a 0; the remainder is
525 * 0..0011..1 The xor with x..xx10..0 clears that remainder, sets
527 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
529 * Another method is to do 'word &= -word'; but it generates a compiler
530 * message on some platforms about taking the negative of an unsigned */
533 word = 1 + (word ^ (word - 1));
535 # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
537 /* Bytes are stored like
538 * Byte1 Byte2 ... Byte8
539 * 63..56 55..47 ... 7...0
541 * Isolate the msb; http://codeforces.com/blog/entry/10330
543 * Only the most significant set bit matters. Or'ing word with its right
544 * shift of 1 makes that bit and the next one to its right both 1. Then
545 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
546 * msb and all to the right being 1. */
552 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
554 /* Then subtracting the right shift by 1 clears all but the left-most of
555 * the 1 bits, which is our desired result */
559 # error Unexpected byte order
562 /* Here 'word' has a single bit set: the msb of the first byte in which it
563 * is set. Calculate that position in the word. We can use this
564 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
565 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
566 * just get shifted off at compile time) */
567 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
568 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
569 | (39 << 24) | (47 << 16)
570 | (55 << 8) | (63 << 0));
571 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
573 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
574 word = ((word + 1) >> 3) - 1;
576 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
578 /* And invert the result */
579 word = CHARBITS - word - 1;
583 return (unsigned int) word;
586 #if defined(PERL_CORE) || defined(PERL_EXT)
589 =for apidoc variant_under_utf8_count
591 This function looks at the sequence of bytes between C<s> and C<e>, which are
592 assumed to be encoded in ASCII/Latin1, and returns how many of them would
593 change should the string be translated into UTF-8. Due to the nature of UTF-8,
594 each of these would occupy two bytes instead of the single one in the input
595 string. Thus, this function returns the precise number of bytes the string
596 would expand by when translated to UTF-8.
598 Unlike most of the other functions that have C<utf8> in their name, the input
599 to this function is NOT a UTF-8-encoded string. The function name is slightly
600 I<odd> to emphasize this.
602 This function is internal to Perl because khw thinks that any XS code that
603 would want this is probably operating too close to the internals. Presenting a
604 valid use case could change that.
607 C<L<perlapi/is_utf8_invariant_string>>
609 C<L<perlapi/is_utf8_invariant_string_loc>>,
615 PERL_STATIC_INLINE Size_t
616 S_variant_under_utf8_count(const U8* const s, const U8* const e)
621 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
625 /* Test if the string is long enough to use word-at-a-time. (Logic is the
626 * same as for is_utf8_invariant_string()) */
627 if ((STRLEN) (e - x) >= PERL_WORDSIZE
628 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
629 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
632 /* Process per-byte until reach word boundary. XXX This loop could be
633 * eliminated if we knew that this platform had fast unaligned reads */
634 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
635 count += ! UTF8_IS_INVARIANT(*x++);
638 /* Process per-word as long as we have at least a full word left */
639 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
640 explanation of how this works */
641 count += ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
642 * PERL_COUNT_MULTIPLIER)
643 >> ((PERL_WORDSIZE - 1) * CHARBITS);
645 } while (x + PERL_WORDSIZE <= e);
650 /* Process per-byte */
652 if (! UTF8_IS_INVARIANT(*x)) {
664 #ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
665 # undef PERL_WORDSIZE
666 # undef PERL_COUNT_MULTIPLIER
667 # undef PERL_WORD_BOUNDARY_MASK
668 # undef PERL_VARIANTS_WORD_MASK
672 =for apidoc is_utf8_string
674 Returns TRUE if the first C<len> bytes of string C<s> form a valid
675 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
676 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
677 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
678 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
680 This function considers Perl's extended UTF-8 to be valid. That means that
681 code points above Unicode, surrogates, and non-character code points are
682 considered valid by this function. Use C<L</is_strict_utf8_string>>,
683 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
684 code points are considered valid.
687 C<L</is_utf8_invariant_string>>,
688 C<L</is_utf8_invariant_string_loc>>,
689 C<L</is_utf8_string_loc>>,
690 C<L</is_utf8_string_loclen>>,
691 C<L</is_utf8_fixed_width_buf_flags>>,
692 C<L</is_utf8_fixed_width_buf_loc_flags>>,
693 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
698 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
700 #if defined(PERL_CORE) || defined (PERL_EXT)
703 =for apidoc is_utf8_non_invariant_string
705 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
706 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
707 UTF-8; otherwise returns FALSE.
709 A TRUE return means that at least one code point represented by the sequence
710 either is a wide character not representable as a single byte, or the
711 representation differs depending on whether the sequence is encoded in UTF-8 or
715 C<L<perlapi/is_utf8_invariant_string>>,
716 C<L<perlapi/is_utf8_string>>
720 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
721 It generally needn't be if its string is entirely UTF-8 invariant, and it
722 shouldn't be if it otherwise contains invalid UTF-8.
724 It is an internal function because khw thinks that XS code shouldn't be working
725 at this low a level. A valid use case could change that.
729 PERL_STATIC_INLINE bool
730 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
732 const U8 * first_variant;
734 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
736 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
740 return is_utf8_string(first_variant, len - (first_variant - s));
746 =for apidoc is_strict_utf8_string
748 Returns TRUE if the first C<len> bytes of string C<s> form a valid
749 UTF-8-encoded string that is fully interchangeable by any application using
750 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
751 calculated using C<strlen(s)> (which means if you use this option, that C<s>
752 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
753 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
755 This function returns FALSE for strings containing any
756 code points above the Unicode max of 0x10FFFF, surrogate code points, or
757 non-character code points.
760 C<L</is_utf8_invariant_string>>,
761 C<L</is_utf8_invariant_string_loc>>,
762 C<L</is_utf8_string>>,
763 C<L</is_utf8_string_flags>>,
764 C<L</is_utf8_string_loc>>,
765 C<L</is_utf8_string_loc_flags>>,
766 C<L</is_utf8_string_loclen>>,
767 C<L</is_utf8_string_loclen_flags>>,
768 C<L</is_utf8_fixed_width_buf_flags>>,
769 C<L</is_utf8_fixed_width_buf_loc_flags>>,
770 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
771 C<L</is_strict_utf8_string_loc>>,
772 C<L</is_strict_utf8_string_loclen>>,
773 C<L</is_c9strict_utf8_string>>,
774 C<L</is_c9strict_utf8_string_loc>>,
776 C<L</is_c9strict_utf8_string_loclen>>.
781 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
784 =for apidoc is_c9strict_utf8_string
786 Returns TRUE if the first C<len> bytes of string C<s> form a valid
787 UTF-8-encoded string that conforms to
788 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
789 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
790 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
791 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
792 characters being ASCII constitute 'a valid UTF-8 string'.
794 This function returns FALSE for strings containing any code points above the
795 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
797 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
800 C<L</is_utf8_invariant_string>>,
801 C<L</is_utf8_invariant_string_loc>>,
802 C<L</is_utf8_string>>,
803 C<L</is_utf8_string_flags>>,
804 C<L</is_utf8_string_loc>>,
805 C<L</is_utf8_string_loc_flags>>,
806 C<L</is_utf8_string_loclen>>,
807 C<L</is_utf8_string_loclen_flags>>,
808 C<L</is_utf8_fixed_width_buf_flags>>,
809 C<L</is_utf8_fixed_width_buf_loc_flags>>,
810 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
811 C<L</is_strict_utf8_string>>,
812 C<L</is_strict_utf8_string_loc>>,
813 C<L</is_strict_utf8_string_loclen>>,
814 C<L</is_c9strict_utf8_string_loc>>,
816 C<L</is_c9strict_utf8_string_loclen>>.
821 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
824 =for apidoc is_utf8_string_flags
826 Returns TRUE if the first C<len> bytes of string C<s> form a valid
827 UTF-8 string, subject to the restrictions imposed by C<flags>;
828 returns FALSE otherwise. If C<len> is 0, it will be calculated
829 using C<strlen(s)> (which means if you use this option, that C<s> can't have
830 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
831 that all characters being ASCII constitute 'a valid UTF-8 string'.
833 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
834 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
835 as C<L</is_strict_utf8_string>>; and if C<flags> is
836 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
837 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
838 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
839 C<L</utf8n_to_uvchr>>, with the same meanings.
842 C<L</is_utf8_invariant_string>>,
843 C<L</is_utf8_invariant_string_loc>>,
844 C<L</is_utf8_string>>,
845 C<L</is_utf8_string_loc>>,
846 C<L</is_utf8_string_loc_flags>>,
847 C<L</is_utf8_string_loclen>>,
848 C<L</is_utf8_string_loclen_flags>>,
849 C<L</is_utf8_fixed_width_buf_flags>>,
850 C<L</is_utf8_fixed_width_buf_loc_flags>>,
851 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
852 C<L</is_strict_utf8_string>>,
853 C<L</is_strict_utf8_string_loc>>,
854 C<L</is_strict_utf8_string_loclen>>,
855 C<L</is_c9strict_utf8_string>>,
856 C<L</is_c9strict_utf8_string_loc>>,
858 C<L</is_c9strict_utf8_string_loclen>>.
863 PERL_STATIC_INLINE bool
864 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
866 const U8 * first_variant;
868 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
869 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
870 |UTF8_DISALLOW_PERL_EXTENDED)));
873 len = strlen((const char *)s);
877 return is_utf8_string(s, len);
880 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
881 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
883 return is_strict_utf8_string(s, len);
886 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
887 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
889 return is_c9strict_utf8_string(s, len);
892 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
893 const U8* const send = s + len;
894 const U8* x = first_variant;
897 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
898 if (UNLIKELY(! cur_len)) {
910 =for apidoc is_utf8_string_loc
912 Like C<L</is_utf8_string>> but stores the location of the failure (in the
913 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
914 "utf8ness success") in the C<ep> pointer.
916 See also C<L</is_utf8_string_loclen>>.
921 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
925 =for apidoc is_utf8_string_loclen
927 Like C<L</is_utf8_string>> but stores the location of the failure (in the
928 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
929 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
930 encoded characters in the C<el> pointer.
932 See also C<L</is_utf8_string_loc>>.
937 PERL_STATIC_INLINE bool
938 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
940 const U8 * first_variant;
942 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
945 len = strlen((const char *) s);
948 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
960 const U8* const send = s + len;
961 const U8* x = first_variant;
962 STRLEN outlen = first_variant - s;
965 const STRLEN cur_len = isUTF8_CHAR(x, send);
966 if (UNLIKELY(! cur_len)) {
986 =for apidoc is_strict_utf8_string_loc
988 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
989 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
990 "utf8ness success") in the C<ep> pointer.
992 See also C<L</is_strict_utf8_string_loclen>>.
997 #define is_strict_utf8_string_loc(s, len, ep) \
998 is_strict_utf8_string_loclen(s, len, ep, 0)
1002 =for apidoc is_strict_utf8_string_loclen
1004 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1005 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1006 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1007 encoded characters in the C<el> pointer.
1009 See also C<L</is_strict_utf8_string_loc>>.
1014 PERL_STATIC_INLINE bool
1015 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1017 const U8 * first_variant;
1019 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1022 len = strlen((const char *) s);
1025 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1037 const U8* const send = s + len;
1038 const U8* x = first_variant;
1039 STRLEN outlen = first_variant - s;
1042 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1043 if (UNLIKELY(! cur_len)) {
1063 =for apidoc is_c9strict_utf8_string_loc
1065 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1066 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1067 "utf8ness success") in the C<ep> pointer.
1069 See also C<L</is_c9strict_utf8_string_loclen>>.
1074 #define is_c9strict_utf8_string_loc(s, len, ep) \
1075 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1079 =for apidoc is_c9strict_utf8_string_loclen
1081 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1082 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1083 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1084 characters in the C<el> pointer.
1086 See also C<L</is_c9strict_utf8_string_loc>>.
1091 PERL_STATIC_INLINE bool
1092 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1094 const U8 * first_variant;
1096 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1099 len = strlen((const char *) s);
1102 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1114 const U8* const send = s + len;
1115 const U8* x = first_variant;
1116 STRLEN outlen = first_variant - s;
1119 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1120 if (UNLIKELY(! cur_len)) {
1140 =for apidoc is_utf8_string_loc_flags
1142 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1143 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1144 "utf8ness success") in the C<ep> pointer.
1146 See also C<L</is_utf8_string_loclen_flags>>.
1151 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1152 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1155 /* The above 3 actual functions could have been moved into the more general one
1156 * just below, and made #defines that call it with the right 'flags'. They are
1157 * currently kept separate to increase their chances of getting inlined */
1161 =for apidoc is_utf8_string_loclen_flags
1163 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1164 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1165 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1166 encoded characters in the C<el> pointer.
1168 See also C<L</is_utf8_string_loc_flags>>.
1173 PERL_STATIC_INLINE bool
1174 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1176 const U8 * first_variant;
1178 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1179 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1180 |UTF8_DISALLOW_PERL_EXTENDED)));
1183 len = strlen((const char *) s);
1187 return is_utf8_string_loclen(s, len, ep, el);
1190 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1191 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1193 return is_strict_utf8_string_loclen(s, len, ep, el);
1196 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1197 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1199 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1202 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1214 const U8* send = s + len;
1215 const U8* x = first_variant;
1216 STRLEN outlen = first_variant - s;
1219 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1220 if (UNLIKELY(! cur_len)) {
1239 =for apidoc utf8_distance
1241 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1244 WARNING: use only if you *know* that the pointers point inside the
1250 PERL_STATIC_INLINE IV
1251 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1253 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1255 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1259 =for apidoc utf8_hop
1261 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1262 forward or backward.
1264 WARNING: do not use the following unless you *know* C<off> is within
1265 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1266 on the first byte of character or just after the last byte of a character.
1271 PERL_STATIC_INLINE U8 *
1272 Perl_utf8_hop(const U8 *s, SSize_t off)
1274 PERL_ARGS_ASSERT_UTF8_HOP;
1276 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1277 * the bitops (especially ~) can create illegal UTF-8.
1278 * In other words: in Perl UTF-8 is not just for Unicode. */
1287 while (UTF8_IS_CONTINUATION(*s))
1291 GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1293 GCC_DIAG_RESTORE_STMT;
1297 =for apidoc utf8_hop_forward
1299 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1302 C<off> must be non-negative.
1304 C<s> must be before or equal to C<end>.
1306 When moving forward it will not move beyond C<end>.
1308 Will not exceed this limit even if the string is not valid "UTF-8".
1313 PERL_STATIC_INLINE U8 *
1314 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1316 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1318 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1319 * the bitops (especially ~) can create illegal UTF-8.
1320 * In other words: in Perl UTF-8 is not just for Unicode. */
1326 STRLEN skip = UTF8SKIP(s);
1327 if ((STRLEN)(end - s) <= skip) {
1328 GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1330 GCC_DIAG_RESTORE_STMT;
1335 GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1337 GCC_DIAG_RESTORE_STMT;
1341 =for apidoc utf8_hop_back
1343 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1346 C<off> must be non-positive.
1348 C<s> must be after or equal to C<start>.
1350 When moving backward it will not move before C<start>.
1352 Will not exceed this limit even if the string is not valid "UTF-8".
1357 PERL_STATIC_INLINE U8 *
1358 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1360 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1362 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1363 * the bitops (especially ~) can create illegal UTF-8.
1364 * In other words: in Perl UTF-8 is not just for Unicode. */
1369 while (off++ && s > start) {
1371 while (UTF8_IS_CONTINUATION(*s) && s > start)
1375 GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1377 GCC_DIAG_RESTORE_STMT;
1381 =for apidoc utf8_hop_safe
1383 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1384 either forward or backward.
1386 When moving backward it will not move before C<start>.
1388 When moving forward it will not move beyond C<end>.
1390 Will not exceed those limits even if the string is not valid "UTF-8".
1395 PERL_STATIC_INLINE U8 *
1396 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1398 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1400 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1401 * the bitops (especially ~) can create illegal UTF-8.
1402 * In other words: in Perl UTF-8 is not just for Unicode. */
1404 assert(start <= s && s <= end);
1407 return utf8_hop_forward(s, off, end);
1410 return utf8_hop_back(s, off, start);
1416 =for apidoc is_utf8_valid_partial_char
1418 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1419 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1420 points. Otherwise, it returns 1 if there exists at least one non-empty
1421 sequence of bytes that when appended to sequence C<s>, starting at position
1422 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1423 otherwise returns 0.
1425 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1428 This is useful when a fixed-length buffer is being tested for being well-formed
1429 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1430 it is split somewhere in the middle of the final code point's UTF-8
1431 representation. (Presumably when the buffer is refreshed with the next chunk
1432 of data, the new first bytes will complete the partial code point.) This
1433 function is used to verify that the final bytes in the current buffer are in
1434 fact the legal beginning of some code point, so that if they aren't, the
1435 failure can be signalled without having to wait for the next read.
1439 #define is_utf8_valid_partial_char(s, e) \
1440 is_utf8_valid_partial_char_flags(s, e, 0)
1444 =for apidoc is_utf8_valid_partial_char_flags
1446 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1447 or not the input is a valid UTF-8 encoded partial character, but it takes an
1448 extra parameter, C<flags>, which can further restrict which code points are
1451 If C<flags> is 0, this behaves identically to
1452 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1453 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1454 there is any sequence of bytes that can complete the input partial character in
1455 such a way that a non-prohibited character is formed, the function returns
1456 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1457 partial character input. But many of the other possible excluded types can be
1458 determined from just the first one or two bytes.
1463 PERL_STATIC_INLINE bool
1464 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1466 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1468 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1469 |UTF8_DISALLOW_PERL_EXTENDED)));
1471 if (s >= e || s + UTF8SKIP(s) <= e) {
1475 return cBOOL(_is_utf8_char_helper(s, e, flags));
1480 =for apidoc is_utf8_fixed_width_buf_flags
1482 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1483 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1484 otherwise it returns FALSE.
1486 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1487 without restriction. If the final few bytes of the buffer do not form a
1488 complete code point, this will return TRUE anyway, provided that
1489 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1491 If C<flags> in non-zero, it can be any combination of the
1492 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1495 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1496 returns FALSE if the final few bytes of the string don't form a complete code
1501 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1502 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1506 =for apidoc is_utf8_fixed_width_buf_loc_flags
1508 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1509 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1510 to the beginning of any partial character at the end of the buffer; if there is
1511 no partial character C<*ep> will contain C<s>+C<len>.
1513 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1518 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1519 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1523 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1525 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1526 complete, valid characters found in the C<el> pointer.
1531 PERL_STATIC_INLINE bool
1532 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1538 const U8 * maybe_partial;
1540 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1543 ep = &maybe_partial;
1546 /* If it's entirely valid, return that; otherwise see if the only error is
1547 * that the final few bytes are for a partial character */
1548 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1549 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1552 /* ------------------------------- perl.h ----------------------------- */
1555 =head1 Miscellaneous Functions
1557 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1559 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1560 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1562 Return TRUE if the name is safe.
1564 Used by the C<IS_SAFE_SYSCALL()> macro.
1569 PERL_STATIC_INLINE bool
1570 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1571 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1572 * perl itself uses xce*() functions which accept 8-bit strings.
1575 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1579 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1580 SETERRNO(ENOENT, LIB_INVARG);
1581 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1582 "Invalid \\0 character in %s for %s: %s\\0%s",
1583 what, op_name, pv, null_at+1);
1593 Return true if the supplied filename has a newline character
1594 immediately before the first (hopefully only) NUL.
1596 My original look at this incorrectly used the len from SvPV(), but
1597 that's incorrect, since we allow for a NUL in pv[len-1].
1599 So instead, strlen() and work from there.
1601 This allow for the user reading a filename, forgetting to chomp it,
1604 open my $foo, "$file\0";
1610 PERL_STATIC_INLINE bool
1611 S_should_warn_nl(const char *pv) {
1614 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1618 return len > 0 && pv[len-1] == '\n';
1623 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1625 #define MAX_CHARSET_NAME_LENGTH 2
1627 PERL_STATIC_INLINE const char *
1628 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1630 /* Returns a string that corresponds to the name of the regex character set
1631 * given by 'flags', and *lenp is set the length of that string, which
1632 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1635 switch (get_regex_charset(flags)) {
1636 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1637 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1638 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1639 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1640 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1642 return ASCII_MORE_RESTRICT_PAT_MODS;
1644 /* The NOT_REACHED; hides an assert() which has a rather complex
1645 * definition in perl.h. */
1646 NOT_REACHED; /* NOTREACHED */
1647 return "?"; /* Unknown */
1652 Return false if any get magic is on the SV other than taint magic.
1656 PERL_STATIC_INLINE bool
1657 S_sv_only_taint_gmagic(SV *sv) {
1658 MAGIC *mg = SvMAGIC(sv);
1660 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1663 if (mg->mg_type != PERL_MAGIC_taint
1664 && !(mg->mg_flags & MGf_GSKIP)
1665 && mg->mg_virtual->svt_get) {
1668 mg = mg->mg_moremagic;
1674 /* ------------------ cop.h ------------------------------------------- */
1677 /* Enter a block. Push a new base context and return its address. */
1679 PERL_STATIC_INLINE PERL_CONTEXT *
1680 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1684 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1689 cx->blk_gimme = gimme;
1690 cx->blk_oldsaveix = saveix;
1691 cx->blk_oldsp = (I32)(sp - PL_stack_base);
1692 cx->blk_oldcop = PL_curcop;
1693 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
1694 cx->blk_oldscopesp = PL_scopestack_ix;
1695 cx->blk_oldpm = PL_curpm;
1696 cx->blk_old_tmpsfloor = PL_tmps_floor;
1698 PL_tmps_floor = PL_tmps_ix;
1699 CX_DEBUG(cx, "PUSH");
1704 /* Exit a block (RETURN and LAST). */
1706 PERL_STATIC_INLINE void
1707 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1709 PERL_ARGS_ASSERT_CX_POPBLOCK;
1711 CX_DEBUG(cx, "POP");
1712 /* these 3 are common to cx_popblock and cx_topblock */
1713 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1714 PL_scopestack_ix = cx->blk_oldscopesp;
1715 PL_curpm = cx->blk_oldpm;
1717 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1718 * and leaves a CX entry lying around for repeated use, so
1719 * skip for multicall */ \
1720 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1721 || PL_savestack_ix == cx->blk_oldsaveix);
1722 PL_curcop = cx->blk_oldcop;
1723 PL_tmps_floor = cx->blk_old_tmpsfloor;
1726 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1727 * Whereas cx_popblock() restores the state to the point just before
1728 * cx_pushblock() was called, cx_topblock() restores it to the point just
1729 * *after* cx_pushblock() was called. */
1731 PERL_STATIC_INLINE void
1732 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1734 PERL_ARGS_ASSERT_CX_TOPBLOCK;
1736 CX_DEBUG(cx, "TOP");
1737 /* these 3 are common to cx_popblock and cx_topblock */
1738 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1739 PL_scopestack_ix = cx->blk_oldscopesp;
1740 PL_curpm = cx->blk_oldpm;
1742 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1746 PERL_STATIC_INLINE void
1747 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1749 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1751 PERL_ARGS_ASSERT_CX_PUSHSUB;
1753 PERL_DTRACE_PROBE_ENTRY(cv);
1754 cx->blk_sub.cv = cv;
1755 cx->blk_sub.olddepth = CvDEPTH(cv);
1756 cx->blk_sub.prevcomppad = PL_comppad;
1757 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1758 cx->blk_sub.retop = retop;
1759 SvREFCNT_inc_simple_void_NN(cv);
1760 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1764 /* subsets of cx_popsub() */
1766 PERL_STATIC_INLINE void
1767 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1771 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1772 assert(CxTYPE(cx) == CXt_SUB);
1774 PL_comppad = cx->blk_sub.prevcomppad;
1775 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1776 cv = cx->blk_sub.cv;
1777 CvDEPTH(cv) = cx->blk_sub.olddepth;
1778 cx->blk_sub.cv = NULL;
1783 /* handle the @_ part of leaving a sub */
1785 PERL_STATIC_INLINE void
1786 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1790 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1791 assert(CxTYPE(cx) == CXt_SUB);
1792 assert(AvARRAY(MUTABLE_AV(
1793 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1794 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1796 CX_POP_SAVEARRAY(cx);
1797 av = MUTABLE_AV(PAD_SVl(0));
1798 if (UNLIKELY(AvREAL(av)))
1799 /* abandon @_ if it got reified */
1800 clear_defarray(av, 0);
1807 PERL_STATIC_INLINE void
1808 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1810 PERL_ARGS_ASSERT_CX_POPSUB;
1811 assert(CxTYPE(cx) == CXt_SUB);
1813 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1817 cx_popsub_common(cx);
1821 PERL_STATIC_INLINE void
1822 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1824 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1826 cx->blk_format.cv = cv;
1827 cx->blk_format.retop = retop;
1828 cx->blk_format.gv = gv;
1829 cx->blk_format.dfoutgv = PL_defoutgv;
1830 cx->blk_format.prevcomppad = PL_comppad;
1833 SvREFCNT_inc_simple_void_NN(cv);
1835 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1839 PERL_STATIC_INLINE void
1840 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1845 PERL_ARGS_ASSERT_CX_POPFORMAT;
1846 assert(CxTYPE(cx) == CXt_FORMAT);
1848 dfout = cx->blk_format.dfoutgv;
1850 cx->blk_format.dfoutgv = NULL;
1851 SvREFCNT_dec_NN(dfout);
1853 PL_comppad = cx->blk_format.prevcomppad;
1854 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1855 cv = cx->blk_format.cv;
1856 cx->blk_format.cv = NULL;
1858 SvREFCNT_dec_NN(cv);
1862 PERL_STATIC_INLINE void
1863 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1865 PERL_ARGS_ASSERT_CX_PUSHEVAL;
1867 cx->blk_eval.retop = retop;
1868 cx->blk_eval.old_namesv = namesv;
1869 cx->blk_eval.old_eval_root = PL_eval_root;
1870 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
1871 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
1872 cx->blk_eval.cur_top_env = PL_top_env;
1874 assert(!(PL_in_eval & ~ 0x3F));
1875 assert(!(PL_op->op_type & ~0x1FF));
1876 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1880 PERL_STATIC_INLINE void
1881 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1885 PERL_ARGS_ASSERT_CX_POPEVAL;
1886 assert(CxTYPE(cx) == CXt_EVAL);
1888 PL_in_eval = CxOLD_IN_EVAL(cx);
1889 assert(!(PL_in_eval & 0xc0));
1890 PL_eval_root = cx->blk_eval.old_eval_root;
1891 sv = cx->blk_eval.cur_text;
1892 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1893 cx->blk_eval.cur_text = NULL;
1894 SvREFCNT_dec_NN(sv);
1897 sv = cx->blk_eval.old_namesv;
1899 cx->blk_eval.old_namesv = NULL;
1900 SvREFCNT_dec_NN(sv);
1905 /* push a plain loop, i.e.
1907 * while (cond) { block }
1908 * for (init;cond;continue) { block }
1909 * This loop can be last/redo'ed etc.
1912 PERL_STATIC_INLINE void
1913 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1915 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1916 cx->blk_loop.my_op = cLOOP;
1920 /* push a true for loop, i.e.
1921 * for var (list) { block }
1924 PERL_STATIC_INLINE void
1925 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1927 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1929 /* this one line is common with cx_pushloop_plain */
1930 cx->blk_loop.my_op = cLOOP;
1932 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1933 cx->blk_loop.itersave = itersave;
1935 cx->blk_loop.oldcomppad = PL_comppad;
1940 /* pop all loop types, including plain */
1942 PERL_STATIC_INLINE void
1943 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1945 PERL_ARGS_ASSERT_CX_POPLOOP;
1947 assert(CxTYPE_is_LOOP(cx));
1948 if ( CxTYPE(cx) == CXt_LOOP_ARY
1949 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1951 /* Free ary or cur. This assumes that state_u.ary.ary
1952 * aligns with state_u.lazysv.cur. See cx_dup() */
1953 SV *sv = cx->blk_loop.state_u.lazysv.cur;
1954 cx->blk_loop.state_u.lazysv.cur = NULL;
1955 SvREFCNT_dec_NN(sv);
1956 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1957 sv = cx->blk_loop.state_u.lazysv.end;
1958 cx->blk_loop.state_u.lazysv.end = NULL;
1959 SvREFCNT_dec_NN(sv);
1962 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1964 SV **svp = (cx)->blk_loop.itervar_u.svp;
1965 if ((cx->cx_type & CXp_FOR_GV))
1966 svp = &GvSV((GV*)svp);
1968 *svp = cx->blk_loop.itersave;
1969 cx->blk_loop.itersave = NULL;
1970 SvREFCNT_dec(cursv);
1975 PERL_STATIC_INLINE void
1976 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1978 PERL_ARGS_ASSERT_CX_PUSHWHEN;
1980 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1984 PERL_STATIC_INLINE void
1985 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1987 PERL_ARGS_ASSERT_CX_POPWHEN;
1988 assert(CxTYPE(cx) == CXt_WHEN);
1990 PERL_UNUSED_ARG(cx);
1991 PERL_UNUSED_CONTEXT;
1992 /* currently NOOP */
1996 PERL_STATIC_INLINE void
1997 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1999 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2001 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2002 cx->blk_givwhen.defsv_save = orig_defsv;
2006 PERL_STATIC_INLINE void
2007 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2011 PERL_ARGS_ASSERT_CX_POPGIVEN;
2012 assert(CxTYPE(cx) == CXt_GIVEN);
2014 sv = GvSV(PL_defgv);
2015 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2016 cx->blk_givwhen.defsv_save = NULL;
2020 /* ------------------ util.h ------------------------------------------- */
2023 =head1 Miscellaneous Functions
2027 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2029 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2030 match themselves and their opposite case counterparts. Non-cased and non-ASCII
2031 range bytes match only themselves.
2036 PERL_STATIC_INLINE I32
2037 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2039 const U8 *a = (const U8 *)s1;
2040 const U8 *b = (const U8 *)s2;
2042 PERL_ARGS_ASSERT_FOLDEQ;
2047 if (*a != *b && *a != PL_fold[*b])
2054 PERL_STATIC_INLINE I32
2055 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2057 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
2058 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
2059 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
2060 * does it check that the strings each have at least 'len' characters */
2062 const U8 *a = (const U8 *)s1;
2063 const U8 *b = (const U8 *)s2;
2065 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2070 if (*a != *b && *a != PL_fold_latin1[*b]) {
2079 =for apidoc foldEQ_locale
2081 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2082 same case-insensitively in the current locale; false otherwise.
2087 PERL_STATIC_INLINE I32
2088 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2091 const U8 *a = (const U8 *)s1;
2092 const U8 *b = (const U8 *)s2;
2094 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2099 if (*a != *b && *a != PL_fold_locale[*b])
2106 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2108 PERL_STATIC_INLINE void *
2109 S_my_memrchr(const char * s, const char c, const STRLEN len)
2111 /* memrchr(), since many platforms lack it */
2113 const char * t = s + len - 1;
2115 PERL_ARGS_ASSERT_MY_MEMRCHR;
2130 * ex: set ts=8 sts=4 sw=4 et: