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 ------------------------------- */
43 =for apidoc_section $AV
45 Returns the number of elements in the array C<av>. This is the true length of
46 the array, including any undefined elements. It is always the same as
47 S<C<av_top_index(av) + 1>>.
51 PERL_STATIC_INLINE Size_t
52 Perl_av_count(pTHX_ AV *av)
54 PERL_ARGS_ASSERT_AV_COUNT;
55 assert(SvTYPE(av) == SVt_PVAV);
57 return AvFILL(av) + 1;
60 /* ------------------------------- cv.h ------------------------------- */
63 =for apidoc_section $CV
65 Returns the GV associated with the CV C<sv>, reifying it if necessary.
69 PERL_STATIC_INLINE GV *
70 Perl_CvGV(pTHX_ CV *sv)
72 PERL_ARGS_ASSERT_CVGV;
75 ? Perl_cvgv_from_hek(aTHX_ sv)
76 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
79 PERL_STATIC_INLINE I32 *
80 Perl_CvDEPTH(const CV * const sv)
82 PERL_ARGS_ASSERT_CVDEPTH;
83 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
85 return &((XPVCV*)SvANY(sv))->xcv_depth;
89 CvPROTO returns the prototype as stored, which is not necessarily what
90 the interpreter should be using. Specifically, the interpreter assumes
91 that spaces have been stripped, which has been the case if the prototype
92 was added by toke.c, but is generally not the case if it was added elsewhere.
93 Since we can't enforce the spacelessness at assignment time, this routine
94 provides a temporary copy at parse time with spaces removed.
95 I<orig> is the start of the original buffer, I<len> is the length of the
96 prototype and will be updated when this returns.
100 PERL_STATIC_INLINE char *
101 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
105 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
113 *len = tmps - SvPVX(tmpsv);
118 /* ------------------------------- mg.h ------------------------------- */
120 #if defined(PERL_CORE) || defined(PERL_EXT)
121 /* assumes get-magic and stringification have already occurred */
122 PERL_STATIC_INLINE STRLEN
123 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
125 assert(mg->mg_type == PERL_MAGIC_regex_global);
126 assert(mg->mg_len != -1);
127 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
128 return (STRLEN)mg->mg_len;
130 const STRLEN pos = (STRLEN)mg->mg_len;
131 /* Without this check, we may read past the end of the buffer: */
132 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
133 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
138 /* ------------------------------- pad.h ------------------------------ */
140 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
141 PERL_STATIC_INLINE bool
142 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
144 PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
146 /* is seq within the range _LOW to _HIGH ?
147 * This is complicated by the fact that PL_cop_seqmax
148 * may have wrapped around at some point */
149 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
150 return FALSE; /* not yet introduced */
152 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
153 /* in compiling scope */
155 (seq > COP_SEQ_RANGE_LOW(pn))
156 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
157 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
162 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
164 ( seq > COP_SEQ_RANGE_LOW(pn)
165 || seq <= COP_SEQ_RANGE_HIGH(pn))
167 : ( seq > COP_SEQ_RANGE_LOW(pn)
168 && seq <= COP_SEQ_RANGE_HIGH(pn))
175 /* ------------------------------- pp.h ------------------------------- */
177 PERL_STATIC_INLINE I32
180 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
181 "MARK top %p %" IVdf "\n",
183 (IV)*PL_markstack_ptr)));
184 return *PL_markstack_ptr;
187 PERL_STATIC_INLINE I32
190 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
191 "MARK pop %p %" IVdf "\n",
192 (PL_markstack_ptr-1),
193 (IV)*(PL_markstack_ptr-1))));
194 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
195 return *PL_markstack_ptr--;
198 /* ----------------------------- regexp.h ----------------------------- */
200 PERL_STATIC_INLINE struct regexp *
201 Perl_ReANY(const REGEXP * const re)
203 XPV* const p = (XPV*)SvANY(re);
205 PERL_ARGS_ASSERT_REANY;
206 assert(isREGEXP(re));
208 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
209 : (struct regexp *)p;
212 /* ------------------------------- sv.h ------------------------------- */
214 PERL_STATIC_INLINE bool
215 Perl_SvTRUE(pTHX_ SV *sv) {
216 if (UNLIKELY(sv == NULL))
219 return SvTRUE_nomg_NN(sv);
222 PERL_STATIC_INLINE SV *
223 Perl_SvREFCNT_inc(SV *sv)
225 if (LIKELY(sv != NULL))
229 PERL_STATIC_INLINE SV *
230 Perl_SvREFCNT_inc_NN(SV *sv)
232 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
237 PERL_STATIC_INLINE void
238 Perl_SvREFCNT_inc_void(SV *sv)
240 if (LIKELY(sv != NULL))
243 PERL_STATIC_INLINE void
244 Perl_SvREFCNT_dec(pTHX_ SV *sv)
246 if (LIKELY(sv != NULL)) {
247 U32 rc = SvREFCNT(sv);
249 SvREFCNT(sv) = rc - 1;
251 Perl_sv_free2(aTHX_ sv, rc);
255 PERL_STATIC_INLINE void
256 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
258 U32 rc = SvREFCNT(sv);
260 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
263 SvREFCNT(sv) = rc - 1;
265 Perl_sv_free2(aTHX_ sv, rc);
268 PERL_STATIC_INLINE void
269 Perl_SvAMAGIC_on(SV *sv)
271 PERL_ARGS_ASSERT_SVAMAGIC_ON;
274 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
276 PERL_STATIC_INLINE void
277 Perl_SvAMAGIC_off(SV *sv)
279 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
281 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
282 HvAMAGIC_off(SvSTASH(SvRV(sv)));
285 PERL_STATIC_INLINE U32
286 Perl_SvPADSTALE_on(SV *sv)
288 assert(!(SvFLAGS(sv) & SVs_PADTMP));
289 return SvFLAGS(sv) |= SVs_PADSTALE;
291 PERL_STATIC_INLINE U32
292 Perl_SvPADSTALE_off(SV *sv)
294 assert(!(SvFLAGS(sv) & SVs_PADTMP));
295 return SvFLAGS(sv) &= ~SVs_PADSTALE;
297 #if defined(PERL_CORE) || defined (PERL_EXT)
298 PERL_STATIC_INLINE STRLEN
299 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
301 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
303 U8 *hopped = utf8_hop((U8 *)pv, pos);
304 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
305 return (STRLEN)(hopped - (U8 *)pv);
307 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
311 /* ------------------------------- utf8.h ------------------------------- */
314 =for apidoc_section $unicode
317 PERL_STATIC_INLINE void
318 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
320 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
321 * encoded string at '*dest', updating '*dest' to include it */
323 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
325 if (NATIVE_BYTE_IS_INVARIANT(byte))
328 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
329 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
334 =for apidoc valid_utf8_to_uvchr
335 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
336 known that the next character in the input UTF-8 string C<s> is well-formed
337 (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
338 points, and non-Unicode code points are allowed.
344 PERL_STATIC_INLINE UV
345 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
347 const UV expectlen = UTF8SKIP(s);
348 const U8* send = s + expectlen;
351 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
357 /* An invariant is trivially returned */
358 if (expectlen == 1) {
362 /* Remove the leading bits that indicate the number of bytes, leaving just
363 * the bits that are part of the value */
364 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
366 /* Now, loop through the remaining bytes, accumulating each into the
367 * working total as we go. (I khw tried unrolling the loop for up to 4
368 * bytes, but there was no performance improvement) */
369 for (++s; s < send; s++) {
370 uv = UTF8_ACCUMULATE(uv, *s);
373 return UNI_TO_NATIVE(uv);
378 =for apidoc is_utf8_invariant_string
380 Returns TRUE if the first C<len> bytes of the string C<s> are the same
381 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
382 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
383 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
384 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
385 characters are invariant, but so also are the C1 controls.
387 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
388 use this option, that C<s> can't have embedded C<NUL> characters and has to
389 have a terminating C<NUL> byte).
392 C<L</is_utf8_string>>,
393 C<L</is_utf8_string_flags>>,
394 C<L</is_utf8_string_loc>>,
395 C<L</is_utf8_string_loc_flags>>,
396 C<L</is_utf8_string_loclen>>,
397 C<L</is_utf8_string_loclen_flags>>,
398 C<L</is_utf8_fixed_width_buf_flags>>,
399 C<L</is_utf8_fixed_width_buf_loc_flags>>,
400 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
401 C<L</is_strict_utf8_string>>,
402 C<L</is_strict_utf8_string_loc>>,
403 C<L</is_strict_utf8_string_loclen>>,
404 C<L</is_c9strict_utf8_string>>,
405 C<L</is_c9strict_utf8_string_loc>>,
407 C<L</is_c9strict_utf8_string_loclen>>.
413 #define is_utf8_invariant_string(s, len) \
414 is_utf8_invariant_string_loc(s, len, NULL)
417 =for apidoc is_utf8_invariant_string_loc
419 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
420 the first UTF-8 variant character in the C<ep> pointer; if all characters are
421 UTF-8 invariant, this function does not change the contents of C<*ep>.
427 PERL_STATIC_INLINE bool
428 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
433 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
436 len = strlen((const char *)s);
441 /* This looks like 0x010101... */
442 # define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
444 /* This looks like 0x808080... */
445 # define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
446 # define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
447 # define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
449 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
450 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
451 * optimized out completely on a 32-bit system, and its mask gets optimized out
452 * on a 64-bit system */
453 # define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
454 | ( PTR2nat(x) >> 1) \
456 & PERL_WORD_BOUNDARY_MASK) >> 2))))
460 /* Do the word-at-a-time iff there is at least one usable full word. That
461 * means that after advancing to a word boundary, there still is at least a
462 * full word left. The number of bytes needed to advance is 'wordsize -
463 * offset' unless offset is 0. */
464 if ((STRLEN) (send - x) >= PERL_WORDSIZE
466 /* This term is wordsize if subword; 0 if not */
467 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
470 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
473 /* Process per-byte until reach word boundary. XXX This loop could be
474 * eliminated if we knew that this platform had fast unaligned reads */
475 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
476 if (! UTF8_IS_INVARIANT(*x)) {
486 /* Here, we know we have at least one full word to process. Process
487 * per-word as long as we have at least a full word left */
489 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
491 /* Found a variant. Just return if caller doesn't want its
497 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
498 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
500 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
501 assert(*ep >= s && *ep < send);
505 # else /* If weird byte order, drop into next loop to do byte-at-a-time
514 } while (x + PERL_WORDSIZE <= send);
517 #endif /* End of ! EBCDIC */
519 /* Process per-byte */
521 if (! UTF8_IS_INVARIANT(*x)) {
537 PERL_STATIC_INLINE unsigned int
538 Perl_variant_byte_number(PERL_UINTMAX_T word)
541 /* This returns the position in a word (0..7) of the first variant byte in
542 * it. This is a helper function. Note that there are no branches */
546 /* Get just the msb bits of each byte */
547 word &= PERL_VARIANTS_WORD_MASK;
549 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
551 /* Bytes are stored like
552 * Byte8 ... Byte2 Byte1
553 * 63..56...15...8 7...0
556 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
558 * The word will look like this, with a rightmost set bit in position 's':
559 * ('x's are don't cares)
562 * x..xx10..0 Right shift (rightmost 0 is shifted off)
563 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
564 * the 1 just to their left into a 0; the remainder is
566 * 0..0011..1 The xor with the original, x..xx10..0, clears that
567 * remainder, sets the bottom to all 1
568 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
570 * Another method is to do 'word &= -word'; but it generates a compiler
571 * message on some platforms about taking the negative of an unsigned */
574 word = 1 + (word ^ (word - 1));
576 # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
578 /* Bytes are stored like
579 * Byte1 Byte2 ... Byte8
580 * 63..56 55..47 ... 7...0
582 * Isolate the msb; http://codeforces.com/blog/entry/10330
584 * Only the most significant set bit matters. Or'ing word with its right
585 * shift of 1 makes that bit and the next one to its right both 1. Then
586 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
587 * msb and all to the right being 1. */
593 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
595 /* Then subtracting the right shift by 1 clears all but the left-most of
596 * the 1 bits, which is our desired result */
600 # error Unexpected byte order
603 /* Here 'word' has a single bit set: the msb of the first byte in which it
604 * is set. Calculate that position in the word. We can use this
605 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
606 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
607 * just get shifted off at compile time) */
608 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
609 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
610 | (39 << 24) | (47 << 16)
611 | (55 << 8) | (63 << 0));
612 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
614 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
615 word = ((word + 1) >> 3) - 1;
617 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
619 /* And invert the result */
620 word = CHARBITS - word - 1;
624 return (unsigned int) word;
628 #if defined(PERL_CORE) || defined(PERL_EXT)
631 =for apidoc variant_under_utf8_count
633 This function looks at the sequence of bytes between C<s> and C<e>, which are
634 assumed to be encoded in ASCII/Latin1, and returns how many of them would
635 change should the string be translated into UTF-8. Due to the nature of UTF-8,
636 each of these would occupy two bytes instead of the single one in the input
637 string. Thus, this function returns the precise number of bytes the string
638 would expand by when translated to UTF-8.
640 Unlike most of the other functions that have C<utf8> in their name, the input
641 to this function is NOT a UTF-8-encoded string. The function name is slightly
642 I<odd> to emphasize this.
644 This function is internal to Perl because khw thinks that any XS code that
645 would want this is probably operating too close to the internals. Presenting a
646 valid use case could change that.
649 C<L<perlapi/is_utf8_invariant_string>>
651 C<L<perlapi/is_utf8_invariant_string_loc>>,
657 PERL_STATIC_INLINE Size_t
658 S_variant_under_utf8_count(const U8* const s, const U8* const e)
663 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
667 /* Test if the string is long enough to use word-at-a-time. (Logic is the
668 * same as for is_utf8_invariant_string()) */
669 if ((STRLEN) (e - x) >= PERL_WORDSIZE
670 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
671 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
674 /* Process per-byte until reach word boundary. XXX This loop could be
675 * eliminated if we knew that this platform had fast unaligned reads */
676 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
677 count += ! UTF8_IS_INVARIANT(*x++);
680 /* Process per-word as long as we have at least a full word left */
681 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
682 explanation of how this works */
683 PERL_UINTMAX_T increment
684 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
685 * PERL_COUNT_MULTIPLIER)
686 >> ((PERL_WORDSIZE - 1) * CHARBITS);
687 count += (Size_t) increment;
689 } while (x + PERL_WORDSIZE <= e);
694 /* Process per-byte */
696 if (! UTF8_IS_INVARIANT(*x)) {
708 #ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
709 # undef PERL_WORDSIZE
710 # undef PERL_COUNT_MULTIPLIER
711 # undef PERL_WORD_BOUNDARY_MASK
712 # undef PERL_VARIANTS_WORD_MASK
716 =for apidoc is_utf8_string
718 Returns TRUE if the first C<len> bytes of string C<s> form a valid
719 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
720 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
721 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
722 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
724 This function considers Perl's extended UTF-8 to be valid. That means that
725 code points above Unicode, surrogates, and non-character code points are
726 considered valid by this function. Use C<L</is_strict_utf8_string>>,
727 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
728 code points are considered valid.
731 C<L</is_utf8_invariant_string>>,
732 C<L</is_utf8_invariant_string_loc>>,
733 C<L</is_utf8_string_loc>>,
734 C<L</is_utf8_string_loclen>>,
735 C<L</is_utf8_fixed_width_buf_flags>>,
736 C<L</is_utf8_fixed_width_buf_loc_flags>>,
737 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
742 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
744 #if defined(PERL_CORE) || defined (PERL_EXT)
747 =for apidoc is_utf8_non_invariant_string
749 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
750 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
751 UTF-8; otherwise returns FALSE.
753 A TRUE return means that at least one code point represented by the sequence
754 either is a wide character not representable as a single byte, or the
755 representation differs depending on whether the sequence is encoded in UTF-8 or
759 C<L<perlapi/is_utf8_invariant_string>>,
760 C<L<perlapi/is_utf8_string>>
764 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
765 It generally needn't be if its string is entirely UTF-8 invariant, and it
766 shouldn't be if it otherwise contains invalid UTF-8.
768 It is an internal function because khw thinks that XS code shouldn't be working
769 at this low a level. A valid use case could change that.
773 PERL_STATIC_INLINE bool
774 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
776 const U8 * first_variant;
778 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
780 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
784 return is_utf8_string(first_variant, len - (first_variant - s));
790 =for apidoc is_strict_utf8_string
792 Returns TRUE if the first C<len> bytes of string C<s> form a valid
793 UTF-8-encoded string that is fully interchangeable by any application using
794 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
795 calculated using C<strlen(s)> (which means if you use this option, that C<s>
796 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
797 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
799 This function returns FALSE for strings containing any
800 code points above the Unicode max of 0x10FFFF, surrogate code points, or
801 non-character code points.
804 C<L</is_utf8_invariant_string>>,
805 C<L</is_utf8_invariant_string_loc>>,
806 C<L</is_utf8_string>>,
807 C<L</is_utf8_string_flags>>,
808 C<L</is_utf8_string_loc>>,
809 C<L</is_utf8_string_loc_flags>>,
810 C<L</is_utf8_string_loclen>>,
811 C<L</is_utf8_string_loclen_flags>>,
812 C<L</is_utf8_fixed_width_buf_flags>>,
813 C<L</is_utf8_fixed_width_buf_loc_flags>>,
814 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
815 C<L</is_strict_utf8_string_loc>>,
816 C<L</is_strict_utf8_string_loclen>>,
817 C<L</is_c9strict_utf8_string>>,
818 C<L</is_c9strict_utf8_string_loc>>,
820 C<L</is_c9strict_utf8_string_loclen>>.
825 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
828 =for apidoc is_c9strict_utf8_string
830 Returns TRUE if the first C<len> bytes of string C<s> form a valid
831 UTF-8-encoded string that conforms to
832 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
833 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
834 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
835 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
836 characters being ASCII constitute 'a valid UTF-8 string'.
838 This function returns FALSE for strings containing any code points above the
839 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
841 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
844 C<L</is_utf8_invariant_string>>,
845 C<L</is_utf8_invariant_string_loc>>,
846 C<L</is_utf8_string>>,
847 C<L</is_utf8_string_flags>>,
848 C<L</is_utf8_string_loc>>,
849 C<L</is_utf8_string_loc_flags>>,
850 C<L</is_utf8_string_loclen>>,
851 C<L</is_utf8_string_loclen_flags>>,
852 C<L</is_utf8_fixed_width_buf_flags>>,
853 C<L</is_utf8_fixed_width_buf_loc_flags>>,
854 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
855 C<L</is_strict_utf8_string>>,
856 C<L</is_strict_utf8_string_loc>>,
857 C<L</is_strict_utf8_string_loclen>>,
858 C<L</is_c9strict_utf8_string_loc>>,
860 C<L</is_c9strict_utf8_string_loclen>>.
865 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
868 =for apidoc is_utf8_string_flags
870 Returns TRUE if the first C<len> bytes of string C<s> form a valid
871 UTF-8 string, subject to the restrictions imposed by C<flags>;
872 returns FALSE otherwise. If C<len> is 0, it will be calculated
873 using C<strlen(s)> (which means if you use this option, that C<s> can't have
874 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
875 that all characters being ASCII constitute 'a valid UTF-8 string'.
877 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
878 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
879 as C<L</is_strict_utf8_string>>; and if C<flags> is
880 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
881 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
882 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
883 C<L</utf8n_to_uvchr>>, with the same meanings.
886 C<L</is_utf8_invariant_string>>,
887 C<L</is_utf8_invariant_string_loc>>,
888 C<L</is_utf8_string>>,
889 C<L</is_utf8_string_loc>>,
890 C<L</is_utf8_string_loc_flags>>,
891 C<L</is_utf8_string_loclen>>,
892 C<L</is_utf8_string_loclen_flags>>,
893 C<L</is_utf8_fixed_width_buf_flags>>,
894 C<L</is_utf8_fixed_width_buf_loc_flags>>,
895 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
896 C<L</is_strict_utf8_string>>,
897 C<L</is_strict_utf8_string_loc>>,
898 C<L</is_strict_utf8_string_loclen>>,
899 C<L</is_c9strict_utf8_string>>,
900 C<L</is_c9strict_utf8_string_loc>>,
902 C<L</is_c9strict_utf8_string_loclen>>.
907 PERL_STATIC_INLINE bool
908 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
910 const U8 * first_variant;
912 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
913 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
914 |UTF8_DISALLOW_PERL_EXTENDED)));
917 len = strlen((const char *)s);
921 return is_utf8_string(s, len);
924 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
925 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
927 return is_strict_utf8_string(s, len);
930 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
931 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
933 return is_c9strict_utf8_string(s, len);
936 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
937 const U8* const send = s + len;
938 const U8* x = first_variant;
941 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
942 if (UNLIKELY(! cur_len)) {
954 =for apidoc is_utf8_string_loc
956 Like C<L</is_utf8_string>> but stores the location of the failure (in the
957 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
958 "utf8ness success") in the C<ep> pointer.
960 See also C<L</is_utf8_string_loclen>>.
965 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
969 =for apidoc is_utf8_string_loclen
971 Like C<L</is_utf8_string>> but stores the location of the failure (in the
972 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
973 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
974 encoded characters in the C<el> pointer.
976 See also C<L</is_utf8_string_loc>>.
981 PERL_STATIC_INLINE bool
982 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
984 const U8 * first_variant;
986 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
989 len = strlen((const char *) s);
992 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1004 const U8* const send = s + len;
1005 const U8* x = first_variant;
1006 STRLEN outlen = first_variant - s;
1009 const STRLEN cur_len = isUTF8_CHAR(x, send);
1010 if (UNLIKELY(! cur_len)) {
1030 =for apidoc isUTF8_CHAR
1032 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1033 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1034 that represents some code point; otherwise it evaluates to 0. If non-zero, the
1035 value gives how many bytes starting at C<s> comprise the code point's
1036 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1037 form the first code point in C<s>, are not examined.
1039 The code point can be any that will fit in an IV on this machine, using Perl's
1040 extension to official UTF-8 to represent those higher than the Unicode maximum
1041 of 0x10FFFF. That means that this macro is used to efficiently decide if the
1042 next few bytes in C<s> is legal UTF-8 for a single character.
1044 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1045 defined by Unicode to be fully interchangeable across applications;
1046 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1047 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1048 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1050 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1051 C<L</is_utf8_string_loclen>> to check entire strings.
1053 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1054 machines) is a valid UTF-8 character.
1058 This uses an adaptation of the table and algorithm given in
1059 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1060 documentation of the original version. A copyright notice for the original
1061 version is given at the beginning of this file. The Perl adapation is
1062 documented at the definition of PL_extended_utf8_dfa_tab[].
1066 PERL_STATIC_INLINE Size_t
1067 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1072 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1074 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1075 * code point, which can be returned immediately. Otherwise, it is either
1076 * malformed, or for the start byte FF which the dfa doesn't handle (except
1077 * on 32-bit ASCII platforms where it trivially is an error). Call a
1078 * helper function for the other platforms. */
1080 while (s < e && LIKELY(state != 1)) {
1081 state = PL_extended_utf8_dfa_tab[256
1083 + PL_extended_utf8_dfa_tab[*s]];
1092 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1094 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1095 return is_utf8_char_helper(s0, e, 0);
1105 =for apidoc isSTRICT_UTF8_CHAR
1107 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1108 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1109 Unicode code point completely acceptable for open interchange between all
1110 applications; otherwise it evaluates to 0. If non-zero, the value gives how
1111 many bytes starting at C<s> comprise the code point's representation. Any
1112 bytes remaining before C<e>, but beyond the ones needed to form the first code
1113 point in C<s>, are not examined.
1115 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1116 be a surrogate nor a non-character code point. Thus this excludes any code
1117 point from Perl's extended UTF-8.
1119 This is used to efficiently decide if the next few bytes in C<s> is
1120 legal Unicode-acceptable UTF-8 for a single character.
1122 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1123 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1124 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1125 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1127 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1128 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1132 This uses an adaptation of the tables and algorithm given in
1133 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1134 documentation of the original version. A copyright notice for the original
1135 version is given at the beginning of this file. The Perl adapation is
1136 documented at the definition of strict_extended_utf8_dfa_tab[].
1140 PERL_STATIC_INLINE Size_t
1141 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1146 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1148 while (s < e && LIKELY(state != 1)) {
1149 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1161 /* The dfa above drops out for certain Hanguls; handle them specially */
1162 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1173 =for apidoc isC9_STRICT_UTF8_CHAR
1175 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1176 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1177 Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1178 the value gives how many bytes starting at C<s> comprise the code point's
1179 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1180 form the first code point in C<s>, are not examined.
1182 The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1183 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1184 code points. This corresponds to
1185 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1186 which said that non-character code points are merely discouraged rather than
1187 completely forbidden in open interchange. See
1188 L<perlunicode/Noncharacter code points>.
1190 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1191 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1193 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1194 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1198 This uses an adaptation of the tables and algorithm given in
1199 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1200 documentation of the original version. A copyright notice for the original
1201 version is given at the beginning of this file. The Perl adapation is
1202 documented at the definition of PL_c9_utf8_dfa_tab[].
1206 PERL_STATIC_INLINE Size_t
1207 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1212 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1214 while (s < e && LIKELY(state != 1)) {
1215 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1230 =for apidoc is_strict_utf8_string_loc
1232 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1233 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1234 "utf8ness success") in the C<ep> pointer.
1236 See also C<L</is_strict_utf8_string_loclen>>.
1241 #define is_strict_utf8_string_loc(s, len, ep) \
1242 is_strict_utf8_string_loclen(s, len, ep, 0)
1246 =for apidoc is_strict_utf8_string_loclen
1248 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1249 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1250 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1251 encoded characters in the C<el> pointer.
1253 See also C<L</is_strict_utf8_string_loc>>.
1258 PERL_STATIC_INLINE bool
1259 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1261 const U8 * first_variant;
1263 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1266 len = strlen((const char *) s);
1269 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1281 const U8* const send = s + len;
1282 const U8* x = first_variant;
1283 STRLEN outlen = first_variant - s;
1286 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1287 if (UNLIKELY(! cur_len)) {
1307 =for apidoc is_c9strict_utf8_string_loc
1309 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1310 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1311 "utf8ness success") in the C<ep> pointer.
1313 See also C<L</is_c9strict_utf8_string_loclen>>.
1318 #define is_c9strict_utf8_string_loc(s, len, ep) \
1319 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1323 =for apidoc is_c9strict_utf8_string_loclen
1325 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1326 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1327 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1328 characters in the C<el> pointer.
1330 See also C<L</is_c9strict_utf8_string_loc>>.
1335 PERL_STATIC_INLINE bool
1336 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1338 const U8 * first_variant;
1340 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1343 len = strlen((const char *) s);
1346 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1358 const U8* const send = s + len;
1359 const U8* x = first_variant;
1360 STRLEN outlen = first_variant - s;
1363 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1364 if (UNLIKELY(! cur_len)) {
1384 =for apidoc is_utf8_string_loc_flags
1386 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1387 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1388 "utf8ness success") in the C<ep> pointer.
1390 See also C<L</is_utf8_string_loclen_flags>>.
1395 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1396 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1399 /* The above 3 actual functions could have been moved into the more general one
1400 * just below, and made #defines that call it with the right 'flags'. They are
1401 * currently kept separate to increase their chances of getting inlined */
1405 =for apidoc is_utf8_string_loclen_flags
1407 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1408 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1409 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1410 encoded characters in the C<el> pointer.
1412 See also C<L</is_utf8_string_loc_flags>>.
1417 PERL_STATIC_INLINE bool
1418 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1420 const U8 * first_variant;
1422 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1423 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1424 |UTF8_DISALLOW_PERL_EXTENDED)));
1427 len = strlen((const char *) s);
1431 return is_utf8_string_loclen(s, len, ep, el);
1434 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1435 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1437 return is_strict_utf8_string_loclen(s, len, ep, el);
1440 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1441 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1443 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1446 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1458 const U8* send = s + len;
1459 const U8* x = first_variant;
1460 STRLEN outlen = first_variant - s;
1463 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1464 if (UNLIKELY(! cur_len)) {
1483 =for apidoc utf8_distance
1485 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1488 WARNING: use only if you *know* that the pointers point inside the
1494 PERL_STATIC_INLINE IV
1495 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1497 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1499 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1503 =for apidoc utf8_hop
1505 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1506 forward or backward.
1508 WARNING: do not use the following unless you *know* C<off> is within
1509 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1510 on the first byte of character or just after the last byte of a character.
1515 PERL_STATIC_INLINE U8 *
1516 Perl_utf8_hop(const U8 *s, SSize_t off)
1518 PERL_ARGS_ASSERT_UTF8_HOP;
1520 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1521 * the bitops (especially ~) can create illegal UTF-8.
1522 * In other words: in Perl UTF-8 is not just for Unicode. */
1531 while (UTF8_IS_CONTINUATION(*s))
1535 GCC_DIAG_IGNORE(-Wcast-qual)
1541 =for apidoc utf8_hop_forward
1543 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1546 C<off> must be non-negative.
1548 C<s> must be before or equal to C<end>.
1550 When moving forward it will not move beyond C<end>.
1552 Will not exceed this limit even if the string is not valid "UTF-8".
1557 PERL_STATIC_INLINE U8 *
1558 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1560 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1562 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1563 * the bitops (especially ~) can create illegal UTF-8.
1564 * In other words: in Perl UTF-8 is not just for Unicode. */
1570 STRLEN skip = UTF8SKIP(s);
1571 if ((STRLEN)(end - s) <= skip) {
1572 GCC_DIAG_IGNORE(-Wcast-qual)
1579 GCC_DIAG_IGNORE(-Wcast-qual)
1585 =for apidoc utf8_hop_back
1587 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1590 C<off> must be non-positive.
1592 C<s> must be after or equal to C<start>.
1594 When moving backward it will not move before C<start>.
1596 Will not exceed this limit even if the string is not valid "UTF-8".
1601 PERL_STATIC_INLINE U8 *
1602 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1604 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1606 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1607 * the bitops (especially ~) can create illegal UTF-8.
1608 * In other words: in Perl UTF-8 is not just for Unicode. */
1613 while (off++ && s > start) {
1616 } while (UTF8_IS_CONTINUATION(*s) && s > start);
1619 GCC_DIAG_IGNORE(-Wcast-qual)
1625 =for apidoc utf8_hop_safe
1627 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1628 either forward or backward.
1630 When moving backward it will not move before C<start>.
1632 When moving forward it will not move beyond C<end>.
1634 Will not exceed those limits even if the string is not valid "UTF-8".
1639 PERL_STATIC_INLINE U8 *
1640 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1642 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1644 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1645 * the bitops (especially ~) can create illegal UTF-8.
1646 * In other words: in Perl UTF-8 is not just for Unicode. */
1648 assert(start <= s && s <= end);
1651 return utf8_hop_forward(s, off, end);
1654 return utf8_hop_back(s, off, start);
1660 =for apidoc is_utf8_valid_partial_char
1662 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1663 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1664 points. Otherwise, it returns 1 if there exists at least one non-empty
1665 sequence of bytes that when appended to sequence C<s>, starting at position
1666 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1667 otherwise returns 0.
1669 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1672 This is useful when a fixed-length buffer is being tested for being well-formed
1673 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1674 it is split somewhere in the middle of the final code point's UTF-8
1675 representation. (Presumably when the buffer is refreshed with the next chunk
1676 of data, the new first bytes will complete the partial code point.) This
1677 function is used to verify that the final bytes in the current buffer are in
1678 fact the legal beginning of some code point, so that if they aren't, the
1679 failure can be signalled without having to wait for the next read.
1683 #define is_utf8_valid_partial_char(s, e) \
1684 is_utf8_valid_partial_char_flags(s, e, 0)
1688 =for apidoc is_utf8_valid_partial_char_flags
1690 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1691 or not the input is a valid UTF-8 encoded partial character, but it takes an
1692 extra parameter, C<flags>, which can further restrict which code points are
1695 If C<flags> is 0, this behaves identically to
1696 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1697 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1698 there is any sequence of bytes that can complete the input partial character in
1699 such a way that a non-prohibited character is formed, the function returns
1700 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1701 partial character input. But many of the other possible excluded types can be
1702 determined from just the first one or two bytes.
1707 PERL_STATIC_INLINE bool
1708 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1710 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1712 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1713 |UTF8_DISALLOW_PERL_EXTENDED)));
1715 if (s >= e || s + UTF8SKIP(s) <= e) {
1719 return cBOOL(is_utf8_char_helper(s, e, flags));
1724 =for apidoc is_utf8_fixed_width_buf_flags
1726 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1727 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1728 otherwise it returns FALSE.
1730 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1731 without restriction. If the final few bytes of the buffer do not form a
1732 complete code point, this will return TRUE anyway, provided that
1733 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1735 If C<flags> in non-zero, it can be any combination of the
1736 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1739 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1740 returns FALSE if the final few bytes of the string don't form a complete code
1745 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1746 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1750 =for apidoc is_utf8_fixed_width_buf_loc_flags
1752 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1753 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1754 to the beginning of any partial character at the end of the buffer; if there is
1755 no partial character C<*ep> will contain C<s>+C<len>.
1757 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1762 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1763 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1767 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1769 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1770 complete, valid characters found in the C<el> pointer.
1775 PERL_STATIC_INLINE bool
1776 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1782 const U8 * maybe_partial;
1784 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1787 ep = &maybe_partial;
1790 /* If it's entirely valid, return that; otherwise see if the only error is
1791 * that the final few bytes are for a partial character */
1792 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1793 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1796 PERL_STATIC_INLINE UV
1797 Perl_utf8n_to_uvchr_msgs(const U8 *s,
1804 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1805 * simple cases, and, if necessary calls a helper function to deal with the
1806 * more complex ones. Almost all well-formed non-problematic code points
1807 * are considered simple, so that it's unlikely that the helper function
1808 * will need to be called.
1810 * This is an adaptation of the tables and algorithm given in
1811 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1812 * comprehensive documentation of the original version. A copyright notice
1813 * for the original version is given at the beginning of this file. The
1814 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1817 const U8 * const s0 = s;
1818 const U8 * send = s0 + curlen;
1819 UV uv = 0; /* The 0 silences some stupid compilers */
1822 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1824 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1825 * non-problematic code point, which can be returned immediately.
1826 * Otherwise we call a helper function to figure out the more complicated
1829 while (s < send && LIKELY(state != 1)) {
1830 UV type = PL_strict_utf8_dfa_tab[*s];
1833 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1834 : UTF8_ACCUMULATE(uv, *s);
1835 state = PL_strict_utf8_dfa_tab[256 + state + type];
1843 *retlen = s - s0 + 1;
1852 return UNI_TO_NATIVE(uv);
1855 /* Here is potentially problematic. Use the full mechanism */
1856 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1859 PERL_STATIC_INLINE UV
1860 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1862 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1866 if (! ckWARN_d(WARN_UTF8)) {
1868 /* EMPTY is not really allowed, and asserts on debugging builds. But
1869 * on non-debugging we have to deal with it, and this causes it to
1870 * return the REPLACEMENT CHARACTER, as the documentation indicates */
1871 return utf8n_to_uvchr(s, send - s, retlen,
1872 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
1875 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1876 if (retlen && ret == 0 && *s != '\0') {
1877 *retlen = (STRLEN) -1;
1884 /* ------------------------------- perl.h ----------------------------- */
1887 =for apidoc_section $utility
1889 =for apidoc is_safe_syscall
1891 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1893 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1894 category, and return FALSE.
1896 Return TRUE if the name is safe.
1898 C<what> and C<op_name> are used in any warning.
1900 Used by the C<IS_SAFE_SYSCALL()> macro.
1905 PERL_STATIC_INLINE bool
1906 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1908 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1909 * perl itself uses xce*() functions which accept 8-bit strings.
1912 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1916 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1917 SETERRNO(ENOENT, LIB_INVARG);
1918 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1919 "Invalid \\0 character in %s for %s: %s\\0%s",
1920 what, op_name, pv, null_at+1);
1930 Return true if the supplied filename has a newline character
1931 immediately before the first (hopefully only) NUL.
1933 My original look at this incorrectly used the len from SvPV(), but
1934 that's incorrect, since we allow for a NUL in pv[len-1].
1936 So instead, strlen() and work from there.
1938 This allow for the user reading a filename, forgetting to chomp it,
1941 open my $foo, "$file\0";
1947 PERL_STATIC_INLINE bool
1948 S_should_warn_nl(const char *pv)
1952 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1956 return len > 0 && pv[len-1] == '\n';
1961 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1963 PERL_STATIC_INLINE bool
1964 S_lossless_NV_to_IV(const NV nv, IV *ivp)
1966 /* This function determines if the input NV 'nv' may be converted without
1967 * loss of data to an IV. If not, it returns FALSE taking no other action.
1968 * But if it is possible, it does the conversion, returning TRUE, and
1969 * storing the converted result in '*ivp' */
1971 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1973 # if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1974 /* Normally any comparison with a NaN returns false; if we can't rely
1975 * on that behaviour, check explicitly */
1976 if (UNLIKELY(Perl_isnan(nv))) {
1981 /* Written this way so that with an always-false NaN comparison we
1983 if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
1987 if ((IV) nv != nv) {
1997 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1999 #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
2001 #define MAX_CHARSET_NAME_LENGTH 2
2003 PERL_STATIC_INLINE const char *
2004 S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
2006 PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
2008 /* Returns a string that corresponds to the name of the regex character set
2009 * given by 'flags', and *lenp is set the length of that string, which
2010 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
2013 switch (get_regex_charset(flags)) {
2014 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
2015 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
2016 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
2017 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
2018 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2020 return ASCII_MORE_RESTRICT_PAT_MODS;
2022 /* The NOT_REACHED; hides an assert() which has a rather complex
2023 * definition in perl.h. */
2024 NOT_REACHED; /* NOTREACHED */
2025 return "?"; /* Unknown */
2032 Return false if any get magic is on the SV other than taint magic.
2036 PERL_STATIC_INLINE bool
2037 Perl_sv_only_taint_gmagic(SV *sv)
2039 MAGIC *mg = SvMAGIC(sv);
2041 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2044 if (mg->mg_type != PERL_MAGIC_taint
2045 && !(mg->mg_flags & MGf_GSKIP)
2046 && mg->mg_virtual->svt_get) {
2049 mg = mg->mg_moremagic;
2055 /* ------------------ cop.h ------------------------------------------- */
2057 /* implement GIMME_V() macro */
2059 PERL_STATIC_INLINE U8
2063 U8 gimme = (PL_op->op_flags & OPf_WANT);
2067 cxix = PL_curstackinfo->si_cxsubix;
2069 return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
2070 assert(cxstack[cxix].blk_gimme & G_WANT);
2071 return (cxstack[cxix].blk_gimme & G_WANT);
2075 /* Enter a block. Push a new base context and return its address. */
2077 PERL_STATIC_INLINE PERL_CONTEXT *
2078 Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2082 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2087 cx->blk_gimme = gimme;
2088 cx->blk_oldsaveix = saveix;
2089 cx->blk_oldsp = (I32)(sp - PL_stack_base);
2090 cx->blk_oldcop = PL_curcop;
2091 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
2092 cx->blk_oldscopesp = PL_scopestack_ix;
2093 cx->blk_oldpm = PL_curpm;
2094 cx->blk_old_tmpsfloor = PL_tmps_floor;
2096 PL_tmps_floor = PL_tmps_ix;
2097 CX_DEBUG(cx, "PUSH");
2102 /* Exit a block (RETURN and LAST). */
2104 PERL_STATIC_INLINE void
2105 Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2107 PERL_ARGS_ASSERT_CX_POPBLOCK;
2109 CX_DEBUG(cx, "POP");
2110 /* these 3 are common to cx_popblock and cx_topblock */
2111 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2112 PL_scopestack_ix = cx->blk_oldscopesp;
2113 PL_curpm = cx->blk_oldpm;
2115 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2116 * and leaves a CX entry lying around for repeated use, so
2117 * skip for multicall */ \
2118 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2119 || PL_savestack_ix == cx->blk_oldsaveix);
2120 PL_curcop = cx->blk_oldcop;
2121 PL_tmps_floor = cx->blk_old_tmpsfloor;
2124 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2125 * Whereas cx_popblock() restores the state to the point just before
2126 * cx_pushblock() was called, cx_topblock() restores it to the point just
2127 * *after* cx_pushblock() was called. */
2129 PERL_STATIC_INLINE void
2130 Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2132 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2134 CX_DEBUG(cx, "TOP");
2135 /* these 3 are common to cx_popblock and cx_topblock */
2136 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2137 PL_scopestack_ix = cx->blk_oldscopesp;
2138 PL_curpm = cx->blk_oldpm;
2140 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2144 PERL_STATIC_INLINE void
2145 Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2147 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2149 PERL_ARGS_ASSERT_CX_PUSHSUB;
2151 PERL_DTRACE_PROBE_ENTRY(cv);
2152 cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
2153 PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
2154 cx->blk_sub.cv = cv;
2155 cx->blk_sub.olddepth = CvDEPTH(cv);
2156 cx->blk_sub.prevcomppad = PL_comppad;
2157 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2158 cx->blk_sub.retop = retop;
2159 SvREFCNT_inc_simple_void_NN(cv);
2160 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2164 /* subsets of cx_popsub() */
2166 PERL_STATIC_INLINE void
2167 Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2171 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2172 assert(CxTYPE(cx) == CXt_SUB);
2174 PL_comppad = cx->blk_sub.prevcomppad;
2175 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2176 cv = cx->blk_sub.cv;
2177 CvDEPTH(cv) = cx->blk_sub.olddepth;
2178 cx->blk_sub.cv = NULL;
2180 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2184 /* handle the @_ part of leaving a sub */
2186 PERL_STATIC_INLINE void
2187 Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2191 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2192 assert(CxTYPE(cx) == CXt_SUB);
2193 assert(AvARRAY(MUTABLE_AV(
2194 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2195 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2197 CX_POP_SAVEARRAY(cx);
2198 av = MUTABLE_AV(PAD_SVl(0));
2199 if (UNLIKELY(AvREAL(av)))
2200 /* abandon @_ if it got reified */
2201 clear_defarray(av, 0);
2208 PERL_STATIC_INLINE void
2209 Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2211 PERL_ARGS_ASSERT_CX_POPSUB;
2212 assert(CxTYPE(cx) == CXt_SUB);
2214 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
2218 cx_popsub_common(cx);
2222 PERL_STATIC_INLINE void
2223 Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2225 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2227 cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2228 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2229 cx->blk_format.cv = cv;
2230 cx->blk_format.retop = retop;
2231 cx->blk_format.gv = gv;
2232 cx->blk_format.dfoutgv = PL_defoutgv;
2233 cx->blk_format.prevcomppad = PL_comppad;
2236 SvREFCNT_inc_simple_void_NN(cv);
2238 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2242 PERL_STATIC_INLINE void
2243 Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2248 PERL_ARGS_ASSERT_CX_POPFORMAT;
2249 assert(CxTYPE(cx) == CXt_FORMAT);
2251 dfout = cx->blk_format.dfoutgv;
2253 cx->blk_format.dfoutgv = NULL;
2254 SvREFCNT_dec_NN(dfout);
2256 PL_comppad = cx->blk_format.prevcomppad;
2257 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2258 cv = cx->blk_format.cv;
2259 cx->blk_format.cv = NULL;
2261 SvREFCNT_dec_NN(cv);
2262 PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
2266 PERL_STATIC_INLINE void
2267 Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2269 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2271 cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
2272 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2273 cx->blk_eval.retop = retop;
2274 cx->blk_eval.old_namesv = namesv;
2275 cx->blk_eval.old_eval_root = PL_eval_root;
2276 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2277 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2278 cx->blk_eval.cur_top_env = PL_top_env;
2280 assert(!(PL_in_eval & ~ 0x3F));
2281 assert(!(PL_op->op_type & ~0x1FF));
2282 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
2286 PERL_STATIC_INLINE void
2287 Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2291 PERL_ARGS_ASSERT_CX_POPEVAL;
2292 assert(CxTYPE(cx) == CXt_EVAL);
2294 PL_in_eval = CxOLD_IN_EVAL(cx);
2295 assert(!(PL_in_eval & 0xc0));
2296 PL_eval_root = cx->blk_eval.old_eval_root;
2297 sv = cx->blk_eval.cur_text;
2298 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
2299 cx->blk_eval.cur_text = NULL;
2300 SvREFCNT_dec_NN(sv);
2303 sv = cx->blk_eval.old_namesv;
2305 cx->blk_eval.old_namesv = NULL;
2306 SvREFCNT_dec_NN(sv);
2308 PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
2312 /* push a plain loop, i.e.
2314 * while (cond) { block }
2315 * for (init;cond;continue) { block }
2316 * This loop can be last/redo'ed etc.
2319 PERL_STATIC_INLINE void
2320 Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2322 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2323 cx->blk_loop.my_op = cLOOP;
2327 /* push a true for loop, i.e.
2328 * for var (list) { block }
2331 PERL_STATIC_INLINE void
2332 Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2334 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2336 /* this one line is common with cx_pushloop_plain */
2337 cx->blk_loop.my_op = cLOOP;
2339 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2340 cx->blk_loop.itersave = itersave;
2342 cx->blk_loop.oldcomppad = PL_comppad;
2347 /* pop all loop types, including plain */
2349 PERL_STATIC_INLINE void
2350 Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2352 PERL_ARGS_ASSERT_CX_POPLOOP;
2354 assert(CxTYPE_is_LOOP(cx));
2355 if ( CxTYPE(cx) == CXt_LOOP_ARY
2356 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2358 /* Free ary or cur. This assumes that state_u.ary.ary
2359 * aligns with state_u.lazysv.cur. See cx_dup() */
2360 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2361 cx->blk_loop.state_u.lazysv.cur = NULL;
2362 SvREFCNT_dec_NN(sv);
2363 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2364 sv = cx->blk_loop.state_u.lazysv.end;
2365 cx->blk_loop.state_u.lazysv.end = NULL;
2366 SvREFCNT_dec_NN(sv);
2369 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2371 SV **svp = (cx)->blk_loop.itervar_u.svp;
2372 if ((cx->cx_type & CXp_FOR_GV))
2373 svp = &GvSV((GV*)svp);
2375 *svp = cx->blk_loop.itersave;
2376 cx->blk_loop.itersave = NULL;
2377 SvREFCNT_dec(cursv);
2382 PERL_STATIC_INLINE void
2383 Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2385 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2387 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2391 PERL_STATIC_INLINE void
2392 Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2394 PERL_ARGS_ASSERT_CX_POPWHEN;
2395 assert(CxTYPE(cx) == CXt_WHEN);
2397 PERL_UNUSED_ARG(cx);
2398 PERL_UNUSED_CONTEXT;
2399 /* currently NOOP */
2403 PERL_STATIC_INLINE void
2404 Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2406 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2408 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2409 cx->blk_givwhen.defsv_save = orig_defsv;
2413 PERL_STATIC_INLINE void
2414 Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2418 PERL_ARGS_ASSERT_CX_POPGIVEN;
2419 assert(CxTYPE(cx) == CXt_GIVEN);
2421 sv = GvSV(PL_defgv);
2422 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2423 cx->blk_givwhen.defsv_save = NULL;
2427 /* ------------------ util.h ------------------------------------------- */
2430 =for apidoc_section $string
2434 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2436 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2437 match themselves and their opposite case counterparts. Non-cased and non-ASCII
2438 range bytes match only themselves.
2443 PERL_STATIC_INLINE I32
2444 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2446 const U8 *a = (const U8 *)s1;
2447 const U8 *b = (const U8 *)s2;
2449 PERL_ARGS_ASSERT_FOLDEQ;
2454 if (*a != *b && *a != PL_fold[*b])
2461 PERL_STATIC_INLINE I32
2462 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2464 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2465 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2466 * does not check for this. Nor does it check that the strings each have
2467 * at least 'len' characters. */
2469 const U8 *a = (const U8 *)s1;
2470 const U8 *b = (const U8 *)s2;
2472 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2477 if (*a != *b && *a != PL_fold_latin1[*b]) {
2486 =for apidoc_section $locale
2487 =for apidoc foldEQ_locale
2489 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2490 same case-insensitively in the current locale; false otherwise.
2495 PERL_STATIC_INLINE I32
2496 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2498 const U8 *a = (const U8 *)s1;
2499 const U8 *b = (const U8 *)s2;
2501 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2506 if (*a != *b && *a != PL_fold_locale[*b])
2514 =for apidoc_section $string
2515 =for apidoc my_strnlen
2517 The C library C<strnlen> if available, or a Perl implementation of it.
2519 C<my_strnlen()> computes the length of the string, up to C<maxlen>
2520 characters. It will never attempt to address more than C<maxlen>
2521 characters, making it suitable for use with strings that are not
2522 guaranteed to be NUL-terminated.
2526 Description stolen from http://man.openbsd.org/strnlen.3,
2527 implementation stolen from PostgreSQL.
2531 PERL_STATIC_INLINE Size_t
2532 Perl_my_strnlen(const char *str, Size_t maxlen)
2534 const char *end = (char *) memchr(str, '\0', maxlen);
2536 PERL_ARGS_ASSERT_MY_STRNLEN;
2538 if (end == NULL) return maxlen;
2544 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2546 PERL_STATIC_INLINE void *
2547 S_my_memrchr(const char * s, const char c, const STRLEN len)
2549 /* memrchr(), since many platforms lack it */
2551 const char * t = s + len - 1;
2553 PERL_ARGS_ASSERT_MY_MEMRCHR;
2567 PERL_STATIC_INLINE char *
2568 Perl_mortal_getenv(const char * str)
2570 /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
2572 * It's (mostly) thread-safe because it uses a mutex to prevent
2573 * simultaneous access from other threads that use the same mutex, and
2574 * makes a copy of the result before releasing that mutex. All of the Perl
2575 * core uses that mutex, but, like all mutexes, everything has to cooperate
2576 * for it to completely work. It is possible for code from, say XS, to not
2577 * use this mutex, defeating the safety.
2579 * On some platforms, getenv() is not sequential-call-safe, because
2580 * subsequent calls destroy the static storage inside the C library
2581 * returned by an earlier call. The result must be copied or completely
2582 * acted upon before a subsequent getenv call. Those calls could come from
2583 * another thread. Again, making a copy while controlling the mutex
2584 * prevents these problems..
2586 * To prevent leaks, the copy is made by creating a new SV containing it,
2587 * mortalizing the SV, and returning the SV's string (the copy). Thus this
2588 * is a drop-in replacement for getenv().
2590 * A complication is that this can be called during phases where the
2591 * mortalization process isn't available. These are in interpreter
2592 * destruction or early in construction. khw believes that at these times
2593 * there shouldn't be anything else going on, so plain getenv is safe AS
2594 * LONG AS the caller acts on the return before calling it again. */
2599 PERL_ARGS_ASSERT_MORTAL_GETENV;
2601 /* Can't mortalize without stacks. khw believes that no other threads
2602 * should be running, so no need to lock things, and this may be during a
2603 * phase when locking isn't even available */
2604 if (UNLIKELY(PL_scopestack_ix == 0)) {
2613 ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
2621 * ex: set ts=8 sts=4 sw=4 et: