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 contains tables and code adapted from
9 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
12 Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
14 Permission is hereby granted, free of charge, to any person obtaining a copy of
15 this software and associated documentation files (the "Software"), to deal in
16 the Software without restriction, including without limitation the rights to
17 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
18 of the Software, and to permit persons to whom the Software is furnished to do
19 so, subject to the following conditions:
21 The above copyright notice and this permission notice shall be included in all
22 copies or substantial portions of the Software.
24 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
25 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
26 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
27 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
29 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
33 * This file is a home for static inline functions that cannot go in other
34 * header files, because they depend on proto.h (included after most other
35 * headers) or struct definitions.
37 * Each section names the header file that the functions "belong" to.
40 /* ------------------------------- av.h ------------------------------- */
44 Returns the number of elements in the array C<av>. This is the true length of
45 the array, including any undefined elements. It is always the same as
46 S<C<av_top_index(av) + 1>>.
50 PERL_STATIC_INLINE Size_t
51 Perl_av_count(pTHX_ AV *av)
53 PERL_ARGS_ASSERT_AV_COUNT;
54 assert(SvTYPE(av) == SVt_PVAV);
56 return AvFILL(av) + 1;
59 /* ------------------------------- cv.h ------------------------------- */
61 PERL_STATIC_INLINE GV *
62 Perl_CvGV(pTHX_ CV *sv)
64 PERL_ARGS_ASSERT_CVGV;
67 ? Perl_cvgv_from_hek(aTHX_ sv)
68 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
71 PERL_STATIC_INLINE I32 *
72 Perl_CvDEPTH(const CV * const sv)
74 PERL_ARGS_ASSERT_CVDEPTH;
75 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
77 return &((XPVCV*)SvANY(sv))->xcv_depth;
81 CvPROTO returns the prototype as stored, which is not necessarily what
82 the interpreter should be using. Specifically, the interpreter assumes
83 that spaces have been stripped, which has been the case if the prototype
84 was added by toke.c, but is generally not the case if it was added elsewhere.
85 Since we can't enforce the spacelessness at assignment time, this routine
86 provides a temporary copy at parse time with spaces removed.
87 I<orig> is the start of the original buffer, I<len> is the length of the
88 prototype and will be updated when this returns.
92 PERL_STATIC_INLINE char *
93 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
97 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
105 *len = tmps - SvPVX(tmpsv);
110 /* ------------------------------- mg.h ------------------------------- */
112 #if defined(PERL_CORE) || defined(PERL_EXT)
113 /* assumes get-magic and stringification have already occurred */
114 PERL_STATIC_INLINE STRLEN
115 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
117 assert(mg->mg_type == PERL_MAGIC_regex_global);
118 assert(mg->mg_len != -1);
119 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
120 return (STRLEN)mg->mg_len;
122 const STRLEN pos = (STRLEN)mg->mg_len;
123 /* Without this check, we may read past the end of the buffer: */
124 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
125 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
130 /* ------------------------------- pad.h ------------------------------ */
132 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
133 PERL_STATIC_INLINE bool
134 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
136 PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
138 /* is seq within the range _LOW to _HIGH ?
139 * This is complicated by the fact that PL_cop_seqmax
140 * may have wrapped around at some point */
141 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
142 return FALSE; /* not yet introduced */
144 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
145 /* in compiling scope */
147 (seq > COP_SEQ_RANGE_LOW(pn))
148 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
149 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
154 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
156 ( seq > COP_SEQ_RANGE_LOW(pn)
157 || seq <= COP_SEQ_RANGE_HIGH(pn))
159 : ( seq > COP_SEQ_RANGE_LOW(pn)
160 && seq <= COP_SEQ_RANGE_HIGH(pn))
167 /* ------------------------------- pp.h ------------------------------- */
169 PERL_STATIC_INLINE I32
172 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
173 "MARK top %p %" IVdf "\n",
175 (IV)*PL_markstack_ptr)));
176 return *PL_markstack_ptr;
179 PERL_STATIC_INLINE I32
182 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
183 "MARK pop %p %" IVdf "\n",
184 (PL_markstack_ptr-1),
185 (IV)*(PL_markstack_ptr-1))));
186 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
187 return *PL_markstack_ptr--;
190 /* ----------------------------- regexp.h ----------------------------- */
192 PERL_STATIC_INLINE struct regexp *
193 Perl_ReANY(const REGEXP * const re)
195 XPV* const p = (XPV*)SvANY(re);
197 PERL_ARGS_ASSERT_REANY;
198 assert(isREGEXP(re));
200 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
201 : (struct regexp *)p;
204 /* ------------------------------- sv.h ------------------------------- */
206 PERL_STATIC_INLINE bool
207 Perl_SvTRUE(pTHX_ SV *sv) {
211 return SvTRUE_nomg_NN(sv);
214 PERL_STATIC_INLINE SV *
215 Perl_SvREFCNT_inc(SV *sv)
217 if (LIKELY(sv != NULL))
221 PERL_STATIC_INLINE SV *
222 Perl_SvREFCNT_inc_NN(SV *sv)
224 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
229 PERL_STATIC_INLINE void
230 Perl_SvREFCNT_inc_void(SV *sv)
232 if (LIKELY(sv != NULL))
235 PERL_STATIC_INLINE void
236 Perl_SvREFCNT_dec(pTHX_ SV *sv)
238 if (LIKELY(sv != NULL)) {
239 U32 rc = SvREFCNT(sv);
241 SvREFCNT(sv) = rc - 1;
243 Perl_sv_free2(aTHX_ sv, rc);
247 PERL_STATIC_INLINE void
248 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
250 U32 rc = SvREFCNT(sv);
252 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
255 SvREFCNT(sv) = rc - 1;
257 Perl_sv_free2(aTHX_ sv, rc);
260 PERL_STATIC_INLINE void
261 Perl_SvAMAGIC_on(SV *sv)
263 PERL_ARGS_ASSERT_SVAMAGIC_ON;
266 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
268 PERL_STATIC_INLINE void
269 Perl_SvAMAGIC_off(SV *sv)
271 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
273 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
274 HvAMAGIC_off(SvSTASH(SvRV(sv)));
277 PERL_STATIC_INLINE U32
278 Perl_SvPADSTALE_on(SV *sv)
280 assert(!(SvFLAGS(sv) & SVs_PADTMP));
281 return SvFLAGS(sv) |= SVs_PADSTALE;
283 PERL_STATIC_INLINE U32
284 Perl_SvPADSTALE_off(SV *sv)
286 assert(!(SvFLAGS(sv) & SVs_PADTMP));
287 return SvFLAGS(sv) &= ~SVs_PADSTALE;
289 #if defined(PERL_CORE) || defined (PERL_EXT)
290 PERL_STATIC_INLINE STRLEN
291 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
293 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
295 U8 *hopped = utf8_hop((U8 *)pv, pos);
296 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
297 return (STRLEN)(hopped - (U8 *)pv);
299 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
303 /* ------------------------------- utf8.h ------------------------------- */
306 =head1 Unicode Support
309 PERL_STATIC_INLINE void
310 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
312 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
313 * encoded string at '*dest', updating '*dest' to include it */
315 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
317 if (NATIVE_BYTE_IS_INVARIANT(byte))
320 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
321 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
326 =for apidoc valid_utf8_to_uvchr
327 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
328 known that the next character in the input UTF-8 string C<s> is well-formed
329 (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
330 points, and non-Unicode code points are allowed.
336 PERL_STATIC_INLINE UV
337 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
339 const UV expectlen = UTF8SKIP(s);
340 const U8* send = s + expectlen;
343 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
349 /* An invariant is trivially returned */
350 if (expectlen == 1) {
354 /* Remove the leading bits that indicate the number of bytes, leaving just
355 * the bits that are part of the value */
356 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
358 /* Now, loop through the remaining bytes, accumulating each into the
359 * working total as we go. (I khw tried unrolling the loop for up to 4
360 * bytes, but there was no performance improvement) */
361 for (++s; s < send; s++) {
362 uv = UTF8_ACCUMULATE(uv, *s);
365 return UNI_TO_NATIVE(uv);
370 =for apidoc is_utf8_invariant_string
372 Returns TRUE if the first C<len> bytes of the string C<s> are the same
373 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
374 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
375 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
376 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
377 characters are invariant, but so also are the C1 controls.
379 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
380 use this option, that C<s> can't have embedded C<NUL> characters and has to
381 have a terminating C<NUL> byte).
384 C<L</is_utf8_string>>,
385 C<L</is_utf8_string_flags>>,
386 C<L</is_utf8_string_loc>>,
387 C<L</is_utf8_string_loc_flags>>,
388 C<L</is_utf8_string_loclen>>,
389 C<L</is_utf8_string_loclen_flags>>,
390 C<L</is_utf8_fixed_width_buf_flags>>,
391 C<L</is_utf8_fixed_width_buf_loc_flags>>,
392 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
393 C<L</is_strict_utf8_string>>,
394 C<L</is_strict_utf8_string_loc>>,
395 C<L</is_strict_utf8_string_loclen>>,
396 C<L</is_c9strict_utf8_string>>,
397 C<L</is_c9strict_utf8_string_loc>>,
399 C<L</is_c9strict_utf8_string_loclen>>.
405 #define is_utf8_invariant_string(s, len) \
406 is_utf8_invariant_string_loc(s, len, NULL)
409 =for apidoc is_utf8_invariant_string_loc
411 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
412 the first UTF-8 variant character in the C<ep> pointer; if all characters are
413 UTF-8 invariant, this function does not change the contents of C<*ep>.
419 PERL_STATIC_INLINE bool
420 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
425 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
428 len = strlen((const char *)s);
433 /* This looks like 0x010101... */
434 # define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
436 /* This looks like 0x808080... */
437 # define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
438 # define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
439 # define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
441 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
442 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
443 * optimized out completely on a 32-bit system, and its mask gets optimized out
444 * on a 64-bit system */
445 # define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
446 | ( PTR2nat(x) >> 1) \
448 & PERL_WORD_BOUNDARY_MASK) >> 2))))
452 /* Do the word-at-a-time iff there is at least one usable full word. That
453 * means that after advancing to a word boundary, there still is at least a
454 * full word left. The number of bytes needed to advance is 'wordsize -
455 * offset' unless offset is 0. */
456 if ((STRLEN) (send - x) >= PERL_WORDSIZE
458 /* This term is wordsize if subword; 0 if not */
459 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
462 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
465 /* Process per-byte until reach word boundary. XXX This loop could be
466 * eliminated if we knew that this platform had fast unaligned reads */
467 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
468 if (! UTF8_IS_INVARIANT(*x)) {
478 /* Here, we know we have at least one full word to process. Process
479 * per-word as long as we have at least a full word left */
481 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
483 /* Found a variant. Just return if caller doesn't want its
489 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
490 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
492 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
493 assert(*ep >= s && *ep < send);
497 # else /* If weird byte order, drop into next loop to do byte-at-a-time
506 } while (x + PERL_WORDSIZE <= send);
509 #endif /* End of ! EBCDIC */
511 /* Process per-byte */
513 if (! UTF8_IS_INVARIANT(*x)) {
529 PERL_STATIC_INLINE unsigned int
530 Perl_variant_byte_number(PERL_UINTMAX_T word)
533 /* This returns the position in a word (0..7) of the first variant byte in
534 * it. This is a helper function. Note that there are no branches */
538 /* Get just the msb bits of each byte */
539 word &= PERL_VARIANTS_WORD_MASK;
541 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
543 /* Bytes are stored like
544 * Byte8 ... Byte2 Byte1
545 * 63..56...15...8 7...0
548 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
550 * The word will look like this, with a rightmost set bit in position 's':
551 * ('x's are don't cares)
554 * x..xx10..0 Right shift (rightmost 0 is shifted off)
555 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
556 * the 1 just to their left into a 0; the remainder is
558 * 0..0011..1 The xor with the original, x..xx10..0, clears that
559 * remainder, sets the bottom to all 1
560 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
562 * Another method is to do 'word &= -word'; but it generates a compiler
563 * message on some platforms about taking the negative of an unsigned */
566 word = 1 + (word ^ (word - 1));
568 # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
570 /* Bytes are stored like
571 * Byte1 Byte2 ... Byte8
572 * 63..56 55..47 ... 7...0
574 * Isolate the msb; http://codeforces.com/blog/entry/10330
576 * Only the most significant set bit matters. Or'ing word with its right
577 * shift of 1 makes that bit and the next one to its right both 1. Then
578 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
579 * msb and all to the right being 1. */
585 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
587 /* Then subtracting the right shift by 1 clears all but the left-most of
588 * the 1 bits, which is our desired result */
592 # error Unexpected byte order
595 /* Here 'word' has a single bit set: the msb of the first byte in which it
596 * is set. Calculate that position in the word. We can use this
597 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
598 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
599 * just get shifted off at compile time) */
600 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
601 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
602 | (39 << 24) | (47 << 16)
603 | (55 << 8) | (63 << 0));
604 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
606 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
607 word = ((word + 1) >> 3) - 1;
609 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
611 /* And invert the result */
612 word = CHARBITS - word - 1;
616 return (unsigned int) word;
620 #if defined(PERL_CORE) || defined(PERL_EXT)
623 =for apidoc variant_under_utf8_count
625 This function looks at the sequence of bytes between C<s> and C<e>, which are
626 assumed to be encoded in ASCII/Latin1, and returns how many of them would
627 change should the string be translated into UTF-8. Due to the nature of UTF-8,
628 each of these would occupy two bytes instead of the single one in the input
629 string. Thus, this function returns the precise number of bytes the string
630 would expand by when translated to UTF-8.
632 Unlike most of the other functions that have C<utf8> in their name, the input
633 to this function is NOT a UTF-8-encoded string. The function name is slightly
634 I<odd> to emphasize this.
636 This function is internal to Perl because khw thinks that any XS code that
637 would want this is probably operating too close to the internals. Presenting a
638 valid use case could change that.
641 C<L<perlapi/is_utf8_invariant_string>>
643 C<L<perlapi/is_utf8_invariant_string_loc>>,
649 PERL_STATIC_INLINE Size_t
650 S_variant_under_utf8_count(const U8* const s, const U8* const e)
655 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
659 /* Test if the string is long enough to use word-at-a-time. (Logic is the
660 * same as for is_utf8_invariant_string()) */
661 if ((STRLEN) (e - x) >= PERL_WORDSIZE
662 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
663 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
666 /* Process per-byte until reach word boundary. XXX This loop could be
667 * eliminated if we knew that this platform had fast unaligned reads */
668 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
669 count += ! UTF8_IS_INVARIANT(*x++);
672 /* Process per-word as long as we have at least a full word left */
673 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
674 explanation of how this works */
675 PERL_UINTMAX_T increment
676 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
677 * PERL_COUNT_MULTIPLIER)
678 >> ((PERL_WORDSIZE - 1) * CHARBITS);
679 count += (Size_t) increment;
681 } while (x + PERL_WORDSIZE <= e);
686 /* Process per-byte */
688 if (! UTF8_IS_INVARIANT(*x)) {
700 #ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
701 # undef PERL_WORDSIZE
702 # undef PERL_COUNT_MULTIPLIER
703 # undef PERL_WORD_BOUNDARY_MASK
704 # undef PERL_VARIANTS_WORD_MASK
708 =for apidoc is_utf8_string
710 Returns TRUE if the first C<len> bytes of string C<s> form a valid
711 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
712 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
713 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
714 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
716 This function considers Perl's extended UTF-8 to be valid. That means that
717 code points above Unicode, surrogates, and non-character code points are
718 considered valid by this function. Use C<L</is_strict_utf8_string>>,
719 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
720 code points are considered valid.
723 C<L</is_utf8_invariant_string>>,
724 C<L</is_utf8_invariant_string_loc>>,
725 C<L</is_utf8_string_loc>>,
726 C<L</is_utf8_string_loclen>>,
727 C<L</is_utf8_fixed_width_buf_flags>>,
728 C<L</is_utf8_fixed_width_buf_loc_flags>>,
729 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
734 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
736 #if defined(PERL_CORE) || defined (PERL_EXT)
739 =for apidoc is_utf8_non_invariant_string
741 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
742 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
743 UTF-8; otherwise returns FALSE.
745 A TRUE return means that at least one code point represented by the sequence
746 either is a wide character not representable as a single byte, or the
747 representation differs depending on whether the sequence is encoded in UTF-8 or
751 C<L<perlapi/is_utf8_invariant_string>>,
752 C<L<perlapi/is_utf8_string>>
756 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
757 It generally needn't be if its string is entirely UTF-8 invariant, and it
758 shouldn't be if it otherwise contains invalid UTF-8.
760 It is an internal function because khw thinks that XS code shouldn't be working
761 at this low a level. A valid use case could change that.
765 PERL_STATIC_INLINE bool
766 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
768 const U8 * first_variant;
770 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
772 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
776 return is_utf8_string(first_variant, len - (first_variant - s));
782 =for apidoc is_strict_utf8_string
784 Returns TRUE if the first C<len> bytes of string C<s> form a valid
785 UTF-8-encoded string that is fully interchangeable by any application using
786 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
787 calculated using C<strlen(s)> (which means if you use this option, that C<s>
788 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
789 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
791 This function returns FALSE for strings containing any
792 code points above the Unicode max of 0x10FFFF, surrogate code points, or
793 non-character code points.
796 C<L</is_utf8_invariant_string>>,
797 C<L</is_utf8_invariant_string_loc>>,
798 C<L</is_utf8_string>>,
799 C<L</is_utf8_string_flags>>,
800 C<L</is_utf8_string_loc>>,
801 C<L</is_utf8_string_loc_flags>>,
802 C<L</is_utf8_string_loclen>>,
803 C<L</is_utf8_string_loclen_flags>>,
804 C<L</is_utf8_fixed_width_buf_flags>>,
805 C<L</is_utf8_fixed_width_buf_loc_flags>>,
806 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
807 C<L</is_strict_utf8_string_loc>>,
808 C<L</is_strict_utf8_string_loclen>>,
809 C<L</is_c9strict_utf8_string>>,
810 C<L</is_c9strict_utf8_string_loc>>,
812 C<L</is_c9strict_utf8_string_loclen>>.
817 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
820 =for apidoc is_c9strict_utf8_string
822 Returns TRUE if the first C<len> bytes of string C<s> form a valid
823 UTF-8-encoded string that conforms to
824 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
825 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
826 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
827 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
828 characters being ASCII constitute 'a valid UTF-8 string'.
830 This function returns FALSE for strings containing any code points above the
831 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
833 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
836 C<L</is_utf8_invariant_string>>,
837 C<L</is_utf8_invariant_string_loc>>,
838 C<L</is_utf8_string>>,
839 C<L</is_utf8_string_flags>>,
840 C<L</is_utf8_string_loc>>,
841 C<L</is_utf8_string_loc_flags>>,
842 C<L</is_utf8_string_loclen>>,
843 C<L</is_utf8_string_loclen_flags>>,
844 C<L</is_utf8_fixed_width_buf_flags>>,
845 C<L</is_utf8_fixed_width_buf_loc_flags>>,
846 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
847 C<L</is_strict_utf8_string>>,
848 C<L</is_strict_utf8_string_loc>>,
849 C<L</is_strict_utf8_string_loclen>>,
850 C<L</is_c9strict_utf8_string_loc>>,
852 C<L</is_c9strict_utf8_string_loclen>>.
857 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
860 =for apidoc is_utf8_string_flags
862 Returns TRUE if the first C<len> bytes of string C<s> form a valid
863 UTF-8 string, subject to the restrictions imposed by C<flags>;
864 returns FALSE otherwise. If C<len> is 0, it will be calculated
865 using C<strlen(s)> (which means if you use this option, that C<s> can't have
866 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
867 that all characters being ASCII constitute 'a valid UTF-8 string'.
869 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
870 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
871 as C<L</is_strict_utf8_string>>; and if C<flags> is
872 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
873 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
874 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
875 C<L</utf8n_to_uvchr>>, with the same meanings.
878 C<L</is_utf8_invariant_string>>,
879 C<L</is_utf8_invariant_string_loc>>,
880 C<L</is_utf8_string>>,
881 C<L</is_utf8_string_loc>>,
882 C<L</is_utf8_string_loc_flags>>,
883 C<L</is_utf8_string_loclen>>,
884 C<L</is_utf8_string_loclen_flags>>,
885 C<L</is_utf8_fixed_width_buf_flags>>,
886 C<L</is_utf8_fixed_width_buf_loc_flags>>,
887 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
888 C<L</is_strict_utf8_string>>,
889 C<L</is_strict_utf8_string_loc>>,
890 C<L</is_strict_utf8_string_loclen>>,
891 C<L</is_c9strict_utf8_string>>,
892 C<L</is_c9strict_utf8_string_loc>>,
894 C<L</is_c9strict_utf8_string_loclen>>.
899 PERL_STATIC_INLINE bool
900 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
902 const U8 * first_variant;
904 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
905 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
906 |UTF8_DISALLOW_PERL_EXTENDED)));
909 len = strlen((const char *)s);
913 return is_utf8_string(s, len);
916 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
917 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
919 return is_strict_utf8_string(s, len);
922 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
923 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
925 return is_c9strict_utf8_string(s, len);
928 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
929 const U8* const send = s + len;
930 const U8* x = first_variant;
933 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
934 if (UNLIKELY(! cur_len)) {
946 =for apidoc is_utf8_string_loc
948 Like C<L</is_utf8_string>> but stores the location of the failure (in the
949 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
950 "utf8ness success") in the C<ep> pointer.
952 See also C<L</is_utf8_string_loclen>>.
957 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
961 =for apidoc is_utf8_string_loclen
963 Like C<L</is_utf8_string>> but stores the location of the failure (in the
964 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
965 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
966 encoded characters in the C<el> pointer.
968 See also C<L</is_utf8_string_loc>>.
973 PERL_STATIC_INLINE bool
974 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
976 const U8 * first_variant;
978 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
981 len = strlen((const char *) s);
984 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
996 const U8* const send = s + len;
997 const U8* x = first_variant;
998 STRLEN outlen = first_variant - s;
1001 const STRLEN cur_len = isUTF8_CHAR(x, send);
1002 if (UNLIKELY(! cur_len)) {
1022 =for apidoc isUTF8_CHAR
1024 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1025 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1026 that represents some code point; otherwise it evaluates to 0. If non-zero, the
1027 value gives how many bytes starting at C<s> comprise the code point's
1028 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1029 form the first code point in C<s>, are not examined.
1031 The code point can be any that will fit in an IV on this machine, using Perl's
1032 extension to official UTF-8 to represent those higher than the Unicode maximum
1033 of 0x10FFFF. That means that this macro is used to efficiently decide if the
1034 next few bytes in C<s> is legal UTF-8 for a single character.
1036 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1037 defined by Unicode to be fully interchangeable across applications;
1038 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1039 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1040 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1042 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1043 C<L</is_utf8_string_loclen>> to check entire strings.
1045 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1046 machines) is a valid UTF-8 character.
1050 This uses an adaptation of the table and algorithm given in
1051 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1052 documentation of the original version. A copyright notice for the original
1053 version is given at the beginning of this file. The Perl adapation is
1054 documented at the definition of PL_extended_utf8_dfa_tab[].
1058 PERL_STATIC_INLINE Size_t
1059 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1064 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1066 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1067 * code point, which can be returned immediately. Otherwise, it is either
1068 * malformed, or for the start byte FF which the dfa doesn't handle (except
1069 * on 32-bit ASCII platforms where it trivially is an error). Call a
1070 * helper function for the other platforms. */
1072 while (s < e && LIKELY(state != 1)) {
1073 state = PL_extended_utf8_dfa_tab[256
1075 + PL_extended_utf8_dfa_tab[*s]];
1084 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1086 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1087 return is_utf8_char_helper(s0, e, 0);
1097 =for apidoc isSTRICT_UTF8_CHAR
1099 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1100 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1101 Unicode code point completely acceptable for open interchange between all
1102 applications; otherwise it evaluates to 0. If non-zero, the value gives how
1103 many bytes starting at C<s> comprise the code point's representation. Any
1104 bytes remaining before C<e>, but beyond the ones needed to form the first code
1105 point in C<s>, are not examined.
1107 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1108 be a surrogate nor a non-character code point. Thus this excludes any code
1109 point from Perl's extended UTF-8.
1111 This is used to efficiently decide if the next few bytes in C<s> is
1112 legal Unicode-acceptable UTF-8 for a single character.
1114 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1115 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1116 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1117 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1119 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1120 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1124 This uses an adaptation of the tables and algorithm given in
1125 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1126 documentation of the original version. A copyright notice for the original
1127 version is given at the beginning of this file. The Perl adapation is
1128 documented at the definition of strict_extended_utf8_dfa_tab[].
1132 PERL_STATIC_INLINE Size_t
1133 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1138 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1140 while (s < e && LIKELY(state != 1)) {
1141 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1153 /* The dfa above drops out for certain Hanguls; handle them specially */
1154 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1165 =for apidoc isC9_STRICT_UTF8_CHAR
1167 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1168 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1169 Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1170 the value gives how many bytes starting at C<s> comprise the code point's
1171 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1172 form the first code point in C<s>, are not examined.
1174 The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1175 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1176 code points. This corresponds to
1177 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1178 which said that non-character code points are merely discouraged rather than
1179 completely forbidden in open interchange. See
1180 L<perlunicode/Noncharacter code points>.
1182 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1183 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1185 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1186 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1190 This uses an adaptation of the tables and algorithm given in
1191 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1192 documentation of the original version. A copyright notice for the original
1193 version is given at the beginning of this file. The Perl adapation is
1194 documented at the definition of PL_c9_utf8_dfa_tab[].
1198 PERL_STATIC_INLINE Size_t
1199 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1204 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1206 while (s < e && LIKELY(state != 1)) {
1207 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1222 =for apidoc is_strict_utf8_string_loc
1224 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1225 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1226 "utf8ness success") in the C<ep> pointer.
1228 See also C<L</is_strict_utf8_string_loclen>>.
1233 #define is_strict_utf8_string_loc(s, len, ep) \
1234 is_strict_utf8_string_loclen(s, len, ep, 0)
1238 =for apidoc is_strict_utf8_string_loclen
1240 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1241 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1242 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1243 encoded characters in the C<el> pointer.
1245 See also C<L</is_strict_utf8_string_loc>>.
1250 PERL_STATIC_INLINE bool
1251 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1253 const U8 * first_variant;
1255 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1258 len = strlen((const char *) s);
1261 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1273 const U8* const send = s + len;
1274 const U8* x = first_variant;
1275 STRLEN outlen = first_variant - s;
1278 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1279 if (UNLIKELY(! cur_len)) {
1299 =for apidoc is_c9strict_utf8_string_loc
1301 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1302 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1303 "utf8ness success") in the C<ep> pointer.
1305 See also C<L</is_c9strict_utf8_string_loclen>>.
1310 #define is_c9strict_utf8_string_loc(s, len, ep) \
1311 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1315 =for apidoc is_c9strict_utf8_string_loclen
1317 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1318 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1319 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1320 characters in the C<el> pointer.
1322 See also C<L</is_c9strict_utf8_string_loc>>.
1327 PERL_STATIC_INLINE bool
1328 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1330 const U8 * first_variant;
1332 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1335 len = strlen((const char *) s);
1338 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1350 const U8* const send = s + len;
1351 const U8* x = first_variant;
1352 STRLEN outlen = first_variant - s;
1355 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1356 if (UNLIKELY(! cur_len)) {
1376 =for apidoc is_utf8_string_loc_flags
1378 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1379 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1380 "utf8ness success") in the C<ep> pointer.
1382 See also C<L</is_utf8_string_loclen_flags>>.
1387 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1388 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1391 /* The above 3 actual functions could have been moved into the more general one
1392 * just below, and made #defines that call it with the right 'flags'. They are
1393 * currently kept separate to increase their chances of getting inlined */
1397 =for apidoc is_utf8_string_loclen_flags
1399 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1400 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1401 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1402 encoded characters in the C<el> pointer.
1404 See also C<L</is_utf8_string_loc_flags>>.
1409 PERL_STATIC_INLINE bool
1410 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1412 const U8 * first_variant;
1414 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1415 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1416 |UTF8_DISALLOW_PERL_EXTENDED)));
1419 len = strlen((const char *) s);
1423 return is_utf8_string_loclen(s, len, ep, el);
1426 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1427 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1429 return is_strict_utf8_string_loclen(s, len, ep, el);
1432 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1433 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1435 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1438 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1450 const U8* send = s + len;
1451 const U8* x = first_variant;
1452 STRLEN outlen = first_variant - s;
1455 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1456 if (UNLIKELY(! cur_len)) {
1475 =for apidoc utf8_distance
1477 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1480 WARNING: use only if you *know* that the pointers point inside the
1486 PERL_STATIC_INLINE IV
1487 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1489 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1491 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1495 =for apidoc utf8_hop
1497 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1498 forward or backward.
1500 WARNING: do not use the following unless you *know* C<off> is within
1501 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1502 on the first byte of character or just after the last byte of a character.
1507 PERL_STATIC_INLINE U8 *
1508 Perl_utf8_hop(const U8 *s, SSize_t off)
1510 PERL_ARGS_ASSERT_UTF8_HOP;
1512 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1513 * the bitops (especially ~) can create illegal UTF-8.
1514 * In other words: in Perl UTF-8 is not just for Unicode. */
1523 while (UTF8_IS_CONTINUATION(*s))
1527 GCC_DIAG_IGNORE(-Wcast-qual)
1533 =for apidoc utf8_hop_forward
1535 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1538 C<off> must be non-negative.
1540 C<s> must be before or equal to C<end>.
1542 When moving forward it will not move beyond C<end>.
1544 Will not exceed this limit even if the string is not valid "UTF-8".
1549 PERL_STATIC_INLINE U8 *
1550 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1552 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1554 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1555 * the bitops (especially ~) can create illegal UTF-8.
1556 * In other words: in Perl UTF-8 is not just for Unicode. */
1562 STRLEN skip = UTF8SKIP(s);
1563 if ((STRLEN)(end - s) <= skip) {
1564 GCC_DIAG_IGNORE(-Wcast-qual)
1571 GCC_DIAG_IGNORE(-Wcast-qual)
1577 =for apidoc utf8_hop_back
1579 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1582 C<off> must be non-positive.
1584 C<s> must be after or equal to C<start>.
1586 When moving backward it will not move before C<start>.
1588 Will not exceed this limit even if the string is not valid "UTF-8".
1593 PERL_STATIC_INLINE U8 *
1594 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1596 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1598 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1599 * the bitops (especially ~) can create illegal UTF-8.
1600 * In other words: in Perl UTF-8 is not just for Unicode. */
1605 while (off++ && s > start) {
1608 } while (UTF8_IS_CONTINUATION(*s) && s > start);
1611 GCC_DIAG_IGNORE(-Wcast-qual)
1617 =for apidoc utf8_hop_safe
1619 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1620 either forward or backward.
1622 When moving backward it will not move before C<start>.
1624 When moving forward it will not move beyond C<end>.
1626 Will not exceed those limits even if the string is not valid "UTF-8".
1631 PERL_STATIC_INLINE U8 *
1632 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1634 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1636 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1637 * the bitops (especially ~) can create illegal UTF-8.
1638 * In other words: in Perl UTF-8 is not just for Unicode. */
1640 assert(start <= s && s <= end);
1643 return utf8_hop_forward(s, off, end);
1646 return utf8_hop_back(s, off, start);
1652 =for apidoc is_utf8_valid_partial_char
1654 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1655 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1656 points. Otherwise, it returns 1 if there exists at least one non-empty
1657 sequence of bytes that when appended to sequence C<s>, starting at position
1658 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1659 otherwise returns 0.
1661 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1664 This is useful when a fixed-length buffer is being tested for being well-formed
1665 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1666 it is split somewhere in the middle of the final code point's UTF-8
1667 representation. (Presumably when the buffer is refreshed with the next chunk
1668 of data, the new first bytes will complete the partial code point.) This
1669 function is used to verify that the final bytes in the current buffer are in
1670 fact the legal beginning of some code point, so that if they aren't, the
1671 failure can be signalled without having to wait for the next read.
1675 #define is_utf8_valid_partial_char(s, e) \
1676 is_utf8_valid_partial_char_flags(s, e, 0)
1680 =for apidoc is_utf8_valid_partial_char_flags
1682 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1683 or not the input is a valid UTF-8 encoded partial character, but it takes an
1684 extra parameter, C<flags>, which can further restrict which code points are
1687 If C<flags> is 0, this behaves identically to
1688 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1689 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1690 there is any sequence of bytes that can complete the input partial character in
1691 such a way that a non-prohibited character is formed, the function returns
1692 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1693 partial character input. But many of the other possible excluded types can be
1694 determined from just the first one or two bytes.
1699 PERL_STATIC_INLINE bool
1700 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1702 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1704 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1705 |UTF8_DISALLOW_PERL_EXTENDED)));
1707 if (s >= e || s + UTF8SKIP(s) <= e) {
1711 return cBOOL(is_utf8_char_helper(s, e, flags));
1716 =for apidoc is_utf8_fixed_width_buf_flags
1718 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1719 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1720 otherwise it returns FALSE.
1722 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1723 without restriction. If the final few bytes of the buffer do not form a
1724 complete code point, this will return TRUE anyway, provided that
1725 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1727 If C<flags> in non-zero, it can be any combination of the
1728 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1731 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1732 returns FALSE if the final few bytes of the string don't form a complete code
1737 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1738 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1742 =for apidoc is_utf8_fixed_width_buf_loc_flags
1744 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1745 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1746 to the beginning of any partial character at the end of the buffer; if there is
1747 no partial character C<*ep> will contain C<s>+C<len>.
1749 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1754 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1755 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1759 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1761 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1762 complete, valid characters found in the C<el> pointer.
1767 PERL_STATIC_INLINE bool
1768 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1774 const U8 * maybe_partial;
1776 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1779 ep = &maybe_partial;
1782 /* If it's entirely valid, return that; otherwise see if the only error is
1783 * that the final few bytes are for a partial character */
1784 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1785 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1788 PERL_STATIC_INLINE UV
1789 Perl_utf8n_to_uvchr_msgs(const U8 *s,
1796 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1797 * simple cases, and, if necessary calls a helper function to deal with the
1798 * more complex ones. Almost all well-formed non-problematic code points
1799 * are considered simple, so that it's unlikely that the helper function
1800 * will need to be called.
1802 * This is an adaptation of the tables and algorithm given in
1803 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1804 * comprehensive documentation of the original version. A copyright notice
1805 * for the original version is given at the beginning of this file. The
1806 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1809 const U8 * const s0 = s;
1810 const U8 * send = s0 + curlen;
1811 UV uv = 0; /* The 0 silences some stupid compilers */
1814 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1816 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1817 * non-problematic code point, which can be returned immediately.
1818 * Otherwise we call a helper function to figure out the more complicated
1821 while (s < send && LIKELY(state != 1)) {
1822 UV type = PL_strict_utf8_dfa_tab[*s];
1825 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1826 : UTF8_ACCUMULATE(uv, *s);
1827 state = PL_strict_utf8_dfa_tab[256 + state + type];
1835 *retlen = s - s0 + 1;
1844 return UNI_TO_NATIVE(uv);
1847 /* Here is potentially problematic. Use the full mechanism */
1848 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1851 PERL_STATIC_INLINE UV
1852 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1854 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1858 if (! ckWARN_d(WARN_UTF8)) {
1860 /* EMPTY is not really allowed, and asserts on debugging builds. But
1861 * on non-debugging we have to deal with it, and this causes it to
1862 * return the REPLACEMENT CHARACTER, as the documentation indicates */
1863 return utf8n_to_uvchr(s, send - s, retlen,
1864 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
1867 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1868 if (retlen && ret == 0 && *s != '\0') {
1869 *retlen = (STRLEN) -1;
1876 /* ------------------------------- perl.h ----------------------------- */
1879 =head1 Miscellaneous Functions
1881 =for apidoc is_safe_syscall
1883 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1885 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1886 category, and return FALSE.
1888 Return TRUE if the name is safe.
1890 C<what> and C<op_name> are used in any warning.
1892 Used by the C<IS_SAFE_SYSCALL()> macro.
1897 PERL_STATIC_INLINE bool
1898 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1900 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1901 * perl itself uses xce*() functions which accept 8-bit strings.
1904 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1908 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1909 SETERRNO(ENOENT, LIB_INVARG);
1910 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1911 "Invalid \\0 character in %s for %s: %s\\0%s",
1912 what, op_name, pv, null_at+1);
1922 Return true if the supplied filename has a newline character
1923 immediately before the first (hopefully only) NUL.
1925 My original look at this incorrectly used the len from SvPV(), but
1926 that's incorrect, since we allow for a NUL in pv[len-1].
1928 So instead, strlen() and work from there.
1930 This allow for the user reading a filename, forgetting to chomp it,
1933 open my $foo, "$file\0";
1939 PERL_STATIC_INLINE bool
1940 S_should_warn_nl(const char *pv)
1944 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1948 return len > 0 && pv[len-1] == '\n';
1953 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1955 PERL_STATIC_INLINE bool
1956 S_lossless_NV_to_IV(const NV nv, IV *ivp)
1958 /* This function determines if the input NV 'nv' may be converted without
1959 * loss of data to an IV. If not, it returns FALSE taking no other action.
1960 * But if it is possible, it does the conversion, returning TRUE, and
1961 * storing the converted result in '*ivp' */
1963 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1965 # if defined(Perl_isnan)
1967 if (UNLIKELY(Perl_isnan(nv))) {
1973 if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
1977 if ((IV) nv != nv) {
1987 /* ------------------ regcomp.c, toke.c ------------ */
1989 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
1992 - regcurly - a little FSA that accepts {\d+,?\d*}
1995 PERL_STATIC_INLINE bool
1996 S_regcurly(const char *s)
1998 PERL_ARGS_ASSERT_REGCURLY;
2017 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
2019 #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
2021 #define MAX_CHARSET_NAME_LENGTH 2
2023 PERL_STATIC_INLINE const char *
2024 S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
2026 PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
2028 /* Returns a string that corresponds to the name of the regex character set
2029 * given by 'flags', and *lenp is set the length of that string, which
2030 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
2033 switch (get_regex_charset(flags)) {
2034 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
2035 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
2036 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
2037 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
2038 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2040 return ASCII_MORE_RESTRICT_PAT_MODS;
2042 /* The NOT_REACHED; hides an assert() which has a rather complex
2043 * definition in perl.h. */
2044 NOT_REACHED; /* NOTREACHED */
2045 return "?"; /* Unknown */
2052 Return false if any get magic is on the SV other than taint magic.
2056 PERL_STATIC_INLINE bool
2057 Perl_sv_only_taint_gmagic(SV *sv)
2059 MAGIC *mg = SvMAGIC(sv);
2061 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2064 if (mg->mg_type != PERL_MAGIC_taint
2065 && !(mg->mg_flags & MGf_GSKIP)
2066 && mg->mg_virtual->svt_get) {
2069 mg = mg->mg_moremagic;
2075 /* ------------------ cop.h ------------------------------------------- */
2077 /* implement GIMME_V() macro */
2079 PERL_STATIC_INLINE U8
2083 U8 gimme = (PL_op->op_flags & OPf_WANT);
2087 cxix = PL_curstackinfo->si_cxsubix;
2090 assert(cxstack[cxix].blk_gimme & G_WANT);
2091 return (cxstack[cxix].blk_gimme & G_WANT);
2095 /* Enter a block. Push a new base context and return its address. */
2097 PERL_STATIC_INLINE PERL_CONTEXT *
2098 Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2102 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2107 cx->blk_gimme = gimme;
2108 cx->blk_oldsaveix = saveix;
2109 cx->blk_oldsp = (I32)(sp - PL_stack_base);
2110 cx->blk_oldcop = PL_curcop;
2111 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
2112 cx->blk_oldscopesp = PL_scopestack_ix;
2113 cx->blk_oldpm = PL_curpm;
2114 cx->blk_old_tmpsfloor = PL_tmps_floor;
2116 PL_tmps_floor = PL_tmps_ix;
2117 CX_DEBUG(cx, "PUSH");
2122 /* Exit a block (RETURN and LAST). */
2124 PERL_STATIC_INLINE void
2125 Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2127 PERL_ARGS_ASSERT_CX_POPBLOCK;
2129 CX_DEBUG(cx, "POP");
2130 /* these 3 are common to cx_popblock and cx_topblock */
2131 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2132 PL_scopestack_ix = cx->blk_oldscopesp;
2133 PL_curpm = cx->blk_oldpm;
2135 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2136 * and leaves a CX entry lying around for repeated use, so
2137 * skip for multicall */ \
2138 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2139 || PL_savestack_ix == cx->blk_oldsaveix);
2140 PL_curcop = cx->blk_oldcop;
2141 PL_tmps_floor = cx->blk_old_tmpsfloor;
2144 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2145 * Whereas cx_popblock() restores the state to the point just before
2146 * cx_pushblock() was called, cx_topblock() restores it to the point just
2147 * *after* cx_pushblock() was called. */
2149 PERL_STATIC_INLINE void
2150 Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2152 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2154 CX_DEBUG(cx, "TOP");
2155 /* these 3 are common to cx_popblock and cx_topblock */
2156 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2157 PL_scopestack_ix = cx->blk_oldscopesp;
2158 PL_curpm = cx->blk_oldpm;
2160 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2164 PERL_STATIC_INLINE void
2165 Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2167 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2169 PERL_ARGS_ASSERT_CX_PUSHSUB;
2171 PERL_DTRACE_PROBE_ENTRY(cv);
2172 cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
2173 PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
2174 cx->blk_sub.cv = cv;
2175 cx->blk_sub.olddepth = CvDEPTH(cv);
2176 cx->blk_sub.prevcomppad = PL_comppad;
2177 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2178 cx->blk_sub.retop = retop;
2179 SvREFCNT_inc_simple_void_NN(cv);
2180 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2184 /* subsets of cx_popsub() */
2186 PERL_STATIC_INLINE void
2187 Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2191 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2192 assert(CxTYPE(cx) == CXt_SUB);
2194 PL_comppad = cx->blk_sub.prevcomppad;
2195 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2196 cv = cx->blk_sub.cv;
2197 CvDEPTH(cv) = cx->blk_sub.olddepth;
2198 cx->blk_sub.cv = NULL;
2200 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2204 /* handle the @_ part of leaving a sub */
2206 PERL_STATIC_INLINE void
2207 Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2211 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2212 assert(CxTYPE(cx) == CXt_SUB);
2213 assert(AvARRAY(MUTABLE_AV(
2214 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2215 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2217 CX_POP_SAVEARRAY(cx);
2218 av = MUTABLE_AV(PAD_SVl(0));
2219 if (UNLIKELY(AvREAL(av)))
2220 /* abandon @_ if it got reified */
2221 clear_defarray(av, 0);
2228 PERL_STATIC_INLINE void
2229 Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2231 PERL_ARGS_ASSERT_CX_POPSUB;
2232 assert(CxTYPE(cx) == CXt_SUB);
2234 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
2238 cx_popsub_common(cx);
2242 PERL_STATIC_INLINE void
2243 Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2245 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2247 cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2248 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2249 cx->blk_format.cv = cv;
2250 cx->blk_format.retop = retop;
2251 cx->blk_format.gv = gv;
2252 cx->blk_format.dfoutgv = PL_defoutgv;
2253 cx->blk_format.prevcomppad = PL_comppad;
2256 SvREFCNT_inc_simple_void_NN(cv);
2258 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2262 PERL_STATIC_INLINE void
2263 Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2268 PERL_ARGS_ASSERT_CX_POPFORMAT;
2269 assert(CxTYPE(cx) == CXt_FORMAT);
2271 dfout = cx->blk_format.dfoutgv;
2273 cx->blk_format.dfoutgv = NULL;
2274 SvREFCNT_dec_NN(dfout);
2276 PL_comppad = cx->blk_format.prevcomppad;
2277 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2278 cv = cx->blk_format.cv;
2279 cx->blk_format.cv = NULL;
2281 SvREFCNT_dec_NN(cv);
2282 PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
2286 PERL_STATIC_INLINE void
2287 Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2289 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2291 cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
2292 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2293 cx->blk_eval.retop = retop;
2294 cx->blk_eval.old_namesv = namesv;
2295 cx->blk_eval.old_eval_root = PL_eval_root;
2296 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2297 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2298 cx->blk_eval.cur_top_env = PL_top_env;
2300 assert(!(PL_in_eval & ~ 0x3F));
2301 assert(!(PL_op->op_type & ~0x1FF));
2302 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
2306 PERL_STATIC_INLINE void
2307 Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2311 PERL_ARGS_ASSERT_CX_POPEVAL;
2312 assert(CxTYPE(cx) == CXt_EVAL);
2314 PL_in_eval = CxOLD_IN_EVAL(cx);
2315 assert(!(PL_in_eval & 0xc0));
2316 PL_eval_root = cx->blk_eval.old_eval_root;
2317 sv = cx->blk_eval.cur_text;
2318 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
2319 cx->blk_eval.cur_text = NULL;
2320 SvREFCNT_dec_NN(sv);
2323 sv = cx->blk_eval.old_namesv;
2325 cx->blk_eval.old_namesv = NULL;
2326 SvREFCNT_dec_NN(sv);
2328 PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
2332 /* push a plain loop, i.e.
2334 * while (cond) { block }
2335 * for (init;cond;continue) { block }
2336 * This loop can be last/redo'ed etc.
2339 PERL_STATIC_INLINE void
2340 Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2342 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2343 cx->blk_loop.my_op = cLOOP;
2347 /* push a true for loop, i.e.
2348 * for var (list) { block }
2351 PERL_STATIC_INLINE void
2352 Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2354 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2356 /* this one line is common with cx_pushloop_plain */
2357 cx->blk_loop.my_op = cLOOP;
2359 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2360 cx->blk_loop.itersave = itersave;
2362 cx->blk_loop.oldcomppad = PL_comppad;
2367 /* pop all loop types, including plain */
2369 PERL_STATIC_INLINE void
2370 Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2372 PERL_ARGS_ASSERT_CX_POPLOOP;
2374 assert(CxTYPE_is_LOOP(cx));
2375 if ( CxTYPE(cx) == CXt_LOOP_ARY
2376 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2378 /* Free ary or cur. This assumes that state_u.ary.ary
2379 * aligns with state_u.lazysv.cur. See cx_dup() */
2380 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2381 cx->blk_loop.state_u.lazysv.cur = NULL;
2382 SvREFCNT_dec_NN(sv);
2383 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2384 sv = cx->blk_loop.state_u.lazysv.end;
2385 cx->blk_loop.state_u.lazysv.end = NULL;
2386 SvREFCNT_dec_NN(sv);
2389 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2391 SV **svp = (cx)->blk_loop.itervar_u.svp;
2392 if ((cx->cx_type & CXp_FOR_GV))
2393 svp = &GvSV((GV*)svp);
2395 *svp = cx->blk_loop.itersave;
2396 cx->blk_loop.itersave = NULL;
2397 SvREFCNT_dec(cursv);
2402 PERL_STATIC_INLINE void
2403 Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2405 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2407 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2411 PERL_STATIC_INLINE void
2412 Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2414 PERL_ARGS_ASSERT_CX_POPWHEN;
2415 assert(CxTYPE(cx) == CXt_WHEN);
2417 PERL_UNUSED_ARG(cx);
2418 PERL_UNUSED_CONTEXT;
2419 /* currently NOOP */
2423 PERL_STATIC_INLINE void
2424 Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2426 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2428 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2429 cx->blk_givwhen.defsv_save = orig_defsv;
2433 PERL_STATIC_INLINE void
2434 Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2438 PERL_ARGS_ASSERT_CX_POPGIVEN;
2439 assert(CxTYPE(cx) == CXt_GIVEN);
2441 sv = GvSV(PL_defgv);
2442 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2443 cx->blk_givwhen.defsv_save = NULL;
2447 /* ------------------ util.h ------------------------------------------- */
2450 =head1 Miscellaneous Functions
2454 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2456 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2457 match themselves and their opposite case counterparts. Non-cased and non-ASCII
2458 range bytes match only themselves.
2463 PERL_STATIC_INLINE I32
2464 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2466 const U8 *a = (const U8 *)s1;
2467 const U8 *b = (const U8 *)s2;
2469 PERL_ARGS_ASSERT_FOLDEQ;
2474 if (*a != *b && *a != PL_fold[*b])
2481 PERL_STATIC_INLINE I32
2482 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2484 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2485 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2486 * does not check for this. Nor does it check that the strings each have
2487 * at least 'len' characters. */
2489 const U8 *a = (const U8 *)s1;
2490 const U8 *b = (const U8 *)s2;
2492 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2497 if (*a != *b && *a != PL_fold_latin1[*b]) {
2506 =for apidoc foldEQ_locale
2508 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2509 same case-insensitively in the current locale; false otherwise.
2514 PERL_STATIC_INLINE I32
2515 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2517 const U8 *a = (const U8 *)s1;
2518 const U8 *b = (const U8 *)s2;
2520 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2525 if (*a != *b && *a != PL_fold_locale[*b])
2533 =for apidoc my_strnlen
2535 The C library C<strnlen> if available, or a Perl implementation of it.
2537 C<my_strnlen()> computes the length of the string, up to C<maxlen>
2538 characters. It will never attempt to address more than C<maxlen>
2539 characters, making it suitable for use with strings that are not
2540 guaranteed to be NUL-terminated.
2544 Description stolen from http://man.openbsd.org/strnlen.3,
2545 implementation stolen from PostgreSQL.
2549 PERL_STATIC_INLINE Size_t
2550 Perl_my_strnlen(const char *str, Size_t maxlen)
2552 const char *end = (char *) memchr(str, '\0', maxlen);
2554 PERL_ARGS_ASSERT_MY_STRNLEN;
2556 if (end == NULL) return maxlen;
2562 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2564 PERL_STATIC_INLINE void *
2565 S_my_memrchr(const char * s, const char c, const STRLEN len)
2567 /* memrchr(), since many platforms lack it */
2569 const char * t = s + len - 1;
2571 PERL_ARGS_ASSERT_MY_MEMRCHR;
2585 PERL_STATIC_INLINE char *
2586 Perl_mortal_getenv(const char * str)
2588 /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
2590 * It's (mostly) thread-safe because it uses a mutex to prevent
2591 * simultaneous access from other threads that use the same mutex, and
2592 * makes a copy of the result before releasing that mutex. All of the Perl
2593 * core uses that mutex, but, like all mutexes, everything has to cooperate
2594 * for it to completely work. It is possible for code from, say XS, to not
2595 * use this mutex, defeating the safety.
2597 * On some platforms, getenv() is not sequential-call-safe, because
2598 * subsequent calls destroy the static storage inside the C library
2599 * returned by an earlier call. The result must be copied or completely
2600 * acted upon before a subsequent getenv call. Those calls could come from
2601 * another thread. Again, making a copy while controlling the mutex
2602 * prevents these problems..
2604 * To prevent leaks, the copy is made by creating a new SV containing it,
2605 * mortalizing the SV, and returning the SV's string (the copy). Thus this
2606 * is a drop-in replacement for getenv().
2608 * A complication is that this can be called during phases where the
2609 * mortalization process isn't available. These are in interpreter
2610 * destruction or early in construction. khw believes that at these times
2611 * there shouldn't be anything else going on, so plain getenv is safe AS
2612 * LONG AS the caller acts on the return before calling it again. */
2617 PERL_ARGS_ASSERT_MORTAL_GETENV;
2619 /* Can't mortalize without stacks. khw believes that no other threads
2620 * should be running, so no need to lock things, and this may be during a
2621 * phase when locking isn't even available */
2622 if (UNLIKELY(PL_scopestack_ix == 0)) {
2631 ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
2639 * ex: set ts=8 sts=4 sw=4 et: