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 Handling
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 ------------------------------- */
62 PERL_STATIC_INLINE GV *
63 Perl_CvGV(pTHX_ CV *sv)
65 PERL_ARGS_ASSERT_CVGV;
68 ? Perl_cvgv_from_hek(aTHX_ sv)
69 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
72 PERL_STATIC_INLINE I32 *
73 Perl_CvDEPTH(const CV * const sv)
75 PERL_ARGS_ASSERT_CVDEPTH;
76 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
78 return &((XPVCV*)SvANY(sv))->xcv_depth;
82 CvPROTO returns the prototype as stored, which is not necessarily what
83 the interpreter should be using. Specifically, the interpreter assumes
84 that spaces have been stripped, which has been the case if the prototype
85 was added by toke.c, but is generally not the case if it was added elsewhere.
86 Since we can't enforce the spacelessness at assignment time, this routine
87 provides a temporary copy at parse time with spaces removed.
88 I<orig> is the start of the original buffer, I<len> is the length of the
89 prototype and will be updated when this returns.
93 PERL_STATIC_INLINE char *
94 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
98 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
106 *len = tmps - SvPVX(tmpsv);
111 /* ------------------------------- mg.h ------------------------------- */
113 #if defined(PERL_CORE) || defined(PERL_EXT)
114 /* assumes get-magic and stringification have already occurred */
115 PERL_STATIC_INLINE STRLEN
116 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
118 assert(mg->mg_type == PERL_MAGIC_regex_global);
119 assert(mg->mg_len != -1);
120 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
121 return (STRLEN)mg->mg_len;
123 const STRLEN pos = (STRLEN)mg->mg_len;
124 /* Without this check, we may read past the end of the buffer: */
125 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
126 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
131 /* ------------------------------- pad.h ------------------------------ */
133 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
134 PERL_STATIC_INLINE bool
135 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
137 PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
139 /* is seq within the range _LOW to _HIGH ?
140 * This is complicated by the fact that PL_cop_seqmax
141 * may have wrapped around at some point */
142 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
143 return FALSE; /* not yet introduced */
145 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
146 /* in compiling scope */
148 (seq > COP_SEQ_RANGE_LOW(pn))
149 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
150 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
155 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
157 ( seq > COP_SEQ_RANGE_LOW(pn)
158 || seq <= COP_SEQ_RANGE_HIGH(pn))
160 : ( seq > COP_SEQ_RANGE_LOW(pn)
161 && seq <= COP_SEQ_RANGE_HIGH(pn))
168 /* ------------------------------- pp.h ------------------------------- */
170 PERL_STATIC_INLINE I32
173 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
174 "MARK top %p %" IVdf "\n",
176 (IV)*PL_markstack_ptr)));
177 return *PL_markstack_ptr;
180 PERL_STATIC_INLINE I32
183 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
184 "MARK pop %p %" IVdf "\n",
185 (PL_markstack_ptr-1),
186 (IV)*(PL_markstack_ptr-1))));
187 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
188 return *PL_markstack_ptr--;
191 /* ----------------------------- regexp.h ----------------------------- */
193 PERL_STATIC_INLINE struct regexp *
194 Perl_ReANY(const REGEXP * const re)
196 XPV* const p = (XPV*)SvANY(re);
198 PERL_ARGS_ASSERT_REANY;
199 assert(isREGEXP(re));
201 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
202 : (struct regexp *)p;
205 /* ------------------------------- sv.h ------------------------------- */
207 PERL_STATIC_INLINE bool
208 Perl_SvTRUE(pTHX_ SV *sv) {
209 if (UNLIKELY(sv == NULL))
212 return SvTRUE_nomg_NN(sv);
215 PERL_STATIC_INLINE SV *
216 Perl_SvREFCNT_inc(SV *sv)
218 if (LIKELY(sv != NULL))
222 PERL_STATIC_INLINE SV *
223 Perl_SvREFCNT_inc_NN(SV *sv)
225 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
230 PERL_STATIC_INLINE void
231 Perl_SvREFCNT_inc_void(SV *sv)
233 if (LIKELY(sv != NULL))
236 PERL_STATIC_INLINE void
237 Perl_SvREFCNT_dec(pTHX_ SV *sv)
239 if (LIKELY(sv != NULL)) {
240 U32 rc = SvREFCNT(sv);
242 SvREFCNT(sv) = rc - 1;
244 Perl_sv_free2(aTHX_ sv, rc);
248 PERL_STATIC_INLINE void
249 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
251 U32 rc = SvREFCNT(sv);
253 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
256 SvREFCNT(sv) = rc - 1;
258 Perl_sv_free2(aTHX_ sv, rc);
261 PERL_STATIC_INLINE void
262 Perl_SvAMAGIC_on(SV *sv)
264 PERL_ARGS_ASSERT_SVAMAGIC_ON;
267 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
269 PERL_STATIC_INLINE void
270 Perl_SvAMAGIC_off(SV *sv)
272 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
274 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
275 HvAMAGIC_off(SvSTASH(SvRV(sv)));
278 PERL_STATIC_INLINE U32
279 Perl_SvPADSTALE_on(SV *sv)
281 assert(!(SvFLAGS(sv) & SVs_PADTMP));
282 return SvFLAGS(sv) |= SVs_PADSTALE;
284 PERL_STATIC_INLINE U32
285 Perl_SvPADSTALE_off(SV *sv)
287 assert(!(SvFLAGS(sv) & SVs_PADTMP));
288 return SvFLAGS(sv) &= ~SVs_PADSTALE;
290 #if defined(PERL_CORE) || defined (PERL_EXT)
291 PERL_STATIC_INLINE STRLEN
292 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
294 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
296 U8 *hopped = utf8_hop((U8 *)pv, pos);
297 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
298 return (STRLEN)(hopped - (U8 *)pv);
300 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
304 /* ------------------------------- utf8.h ------------------------------- */
307 =for apidoc_section Unicode Support
310 PERL_STATIC_INLINE void
311 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
313 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
314 * encoded string at '*dest', updating '*dest' to include it */
316 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
318 if (NATIVE_BYTE_IS_INVARIANT(byte))
321 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
322 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
327 =for apidoc valid_utf8_to_uvchr
328 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
329 known that the next character in the input UTF-8 string C<s> is well-formed
330 (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
331 points, and non-Unicode code points are allowed.
337 PERL_STATIC_INLINE UV
338 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
340 const UV expectlen = UTF8SKIP(s);
341 const U8* send = s + expectlen;
344 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
350 /* An invariant is trivially returned */
351 if (expectlen == 1) {
355 /* Remove the leading bits that indicate the number of bytes, leaving just
356 * the bits that are part of the value */
357 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
359 /* Now, loop through the remaining bytes, accumulating each into the
360 * working total as we go. (I khw tried unrolling the loop for up to 4
361 * bytes, but there was no performance improvement) */
362 for (++s; s < send; s++) {
363 uv = UTF8_ACCUMULATE(uv, *s);
366 return UNI_TO_NATIVE(uv);
371 =for apidoc is_utf8_invariant_string
373 Returns TRUE if the first C<len> bytes of the string C<s> are the same
374 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
375 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
376 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
377 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
378 characters are invariant, but so also are the C1 controls.
380 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
381 use this option, that C<s> can't have embedded C<NUL> characters and has to
382 have a terminating C<NUL> byte).
385 C<L</is_utf8_string>>,
386 C<L</is_utf8_string_flags>>,
387 C<L</is_utf8_string_loc>>,
388 C<L</is_utf8_string_loc_flags>>,
389 C<L</is_utf8_string_loclen>>,
390 C<L</is_utf8_string_loclen_flags>>,
391 C<L</is_utf8_fixed_width_buf_flags>>,
392 C<L</is_utf8_fixed_width_buf_loc_flags>>,
393 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
394 C<L</is_strict_utf8_string>>,
395 C<L</is_strict_utf8_string_loc>>,
396 C<L</is_strict_utf8_string_loclen>>,
397 C<L</is_c9strict_utf8_string>>,
398 C<L</is_c9strict_utf8_string_loc>>,
400 C<L</is_c9strict_utf8_string_loclen>>.
406 #define is_utf8_invariant_string(s, len) \
407 is_utf8_invariant_string_loc(s, len, NULL)
410 =for apidoc is_utf8_invariant_string_loc
412 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
413 the first UTF-8 variant character in the C<ep> pointer; if all characters are
414 UTF-8 invariant, this function does not change the contents of C<*ep>.
420 PERL_STATIC_INLINE bool
421 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
426 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
429 len = strlen((const char *)s);
434 /* This looks like 0x010101... */
435 # define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
437 /* This looks like 0x808080... */
438 # define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
439 # define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
440 # define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
442 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
443 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
444 * optimized out completely on a 32-bit system, and its mask gets optimized out
445 * on a 64-bit system */
446 # define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
447 | ( PTR2nat(x) >> 1) \
449 & PERL_WORD_BOUNDARY_MASK) >> 2))))
453 /* Do the word-at-a-time iff there is at least one usable full word. That
454 * means that after advancing to a word boundary, there still is at least a
455 * full word left. The number of bytes needed to advance is 'wordsize -
456 * offset' unless offset is 0. */
457 if ((STRLEN) (send - x) >= PERL_WORDSIZE
459 /* This term is wordsize if subword; 0 if not */
460 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
463 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
466 /* Process per-byte until reach word boundary. XXX This loop could be
467 * eliminated if we knew that this platform had fast unaligned reads */
468 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
469 if (! UTF8_IS_INVARIANT(*x)) {
479 /* Here, we know we have at least one full word to process. Process
480 * per-word as long as we have at least a full word left */
482 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
484 /* Found a variant. Just return if caller doesn't want its
490 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
491 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
493 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
494 assert(*ep >= s && *ep < send);
498 # else /* If weird byte order, drop into next loop to do byte-at-a-time
507 } while (x + PERL_WORDSIZE <= send);
510 #endif /* End of ! EBCDIC */
512 /* Process per-byte */
514 if (! UTF8_IS_INVARIANT(*x)) {
530 PERL_STATIC_INLINE unsigned int
531 Perl_variant_byte_number(PERL_UINTMAX_T word)
534 /* This returns the position in a word (0..7) of the first variant byte in
535 * it. This is a helper function. Note that there are no branches */
539 /* Get just the msb bits of each byte */
540 word &= PERL_VARIANTS_WORD_MASK;
542 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
544 /* Bytes are stored like
545 * Byte8 ... Byte2 Byte1
546 * 63..56...15...8 7...0
549 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
551 * The word will look like this, with a rightmost set bit in position 's':
552 * ('x's are don't cares)
555 * x..xx10..0 Right shift (rightmost 0 is shifted off)
556 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
557 * the 1 just to their left into a 0; the remainder is
559 * 0..0011..1 The xor with the original, x..xx10..0, clears that
560 * remainder, sets the bottom to all 1
561 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
563 * Another method is to do 'word &= -word'; but it generates a compiler
564 * message on some platforms about taking the negative of an unsigned */
567 word = 1 + (word ^ (word - 1));
569 # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
571 /* Bytes are stored like
572 * Byte1 Byte2 ... Byte8
573 * 63..56 55..47 ... 7...0
575 * Isolate the msb; http://codeforces.com/blog/entry/10330
577 * Only the most significant set bit matters. Or'ing word with its right
578 * shift of 1 makes that bit and the next one to its right both 1. Then
579 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
580 * msb and all to the right being 1. */
586 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
588 /* Then subtracting the right shift by 1 clears all but the left-most of
589 * the 1 bits, which is our desired result */
593 # error Unexpected byte order
596 /* Here 'word' has a single bit set: the msb of the first byte in which it
597 * is set. Calculate that position in the word. We can use this
598 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
599 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
600 * just get shifted off at compile time) */
601 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
602 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
603 | (39 << 24) | (47 << 16)
604 | (55 << 8) | (63 << 0));
605 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
607 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
608 word = ((word + 1) >> 3) - 1;
610 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
612 /* And invert the result */
613 word = CHARBITS - word - 1;
617 return (unsigned int) word;
621 #if defined(PERL_CORE) || defined(PERL_EXT)
624 =for apidoc variant_under_utf8_count
626 This function looks at the sequence of bytes between C<s> and C<e>, which are
627 assumed to be encoded in ASCII/Latin1, and returns how many of them would
628 change should the string be translated into UTF-8. Due to the nature of UTF-8,
629 each of these would occupy two bytes instead of the single one in the input
630 string. Thus, this function returns the precise number of bytes the string
631 would expand by when translated to UTF-8.
633 Unlike most of the other functions that have C<utf8> in their name, the input
634 to this function is NOT a UTF-8-encoded string. The function name is slightly
635 I<odd> to emphasize this.
637 This function is internal to Perl because khw thinks that any XS code that
638 would want this is probably operating too close to the internals. Presenting a
639 valid use case could change that.
642 C<L<perlapi/is_utf8_invariant_string>>
644 C<L<perlapi/is_utf8_invariant_string_loc>>,
650 PERL_STATIC_INLINE Size_t
651 S_variant_under_utf8_count(const U8* const s, const U8* const e)
656 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
660 /* Test if the string is long enough to use word-at-a-time. (Logic is the
661 * same as for is_utf8_invariant_string()) */
662 if ((STRLEN) (e - x) >= PERL_WORDSIZE
663 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
664 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
667 /* Process per-byte until reach word boundary. XXX This loop could be
668 * eliminated if we knew that this platform had fast unaligned reads */
669 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
670 count += ! UTF8_IS_INVARIANT(*x++);
673 /* Process per-word as long as we have at least a full word left */
674 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
675 explanation of how this works */
676 PERL_UINTMAX_T increment
677 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
678 * PERL_COUNT_MULTIPLIER)
679 >> ((PERL_WORDSIZE - 1) * CHARBITS);
680 count += (Size_t) increment;
682 } while (x + PERL_WORDSIZE <= e);
687 /* Process per-byte */
689 if (! UTF8_IS_INVARIANT(*x)) {
701 #ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
702 # undef PERL_WORDSIZE
703 # undef PERL_COUNT_MULTIPLIER
704 # undef PERL_WORD_BOUNDARY_MASK
705 # undef PERL_VARIANTS_WORD_MASK
709 =for apidoc is_utf8_string
711 Returns TRUE if the first C<len> bytes of string C<s> form a valid
712 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
713 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
714 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
715 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
717 This function considers Perl's extended UTF-8 to be valid. That means that
718 code points above Unicode, surrogates, and non-character code points are
719 considered valid by this function. Use C<L</is_strict_utf8_string>>,
720 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
721 code points are considered valid.
724 C<L</is_utf8_invariant_string>>,
725 C<L</is_utf8_invariant_string_loc>>,
726 C<L</is_utf8_string_loc>>,
727 C<L</is_utf8_string_loclen>>,
728 C<L</is_utf8_fixed_width_buf_flags>>,
729 C<L</is_utf8_fixed_width_buf_loc_flags>>,
730 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
735 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
737 #if defined(PERL_CORE) || defined (PERL_EXT)
740 =for apidoc is_utf8_non_invariant_string
742 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
743 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
744 UTF-8; otherwise returns FALSE.
746 A TRUE return means that at least one code point represented by the sequence
747 either is a wide character not representable as a single byte, or the
748 representation differs depending on whether the sequence is encoded in UTF-8 or
752 C<L<perlapi/is_utf8_invariant_string>>,
753 C<L<perlapi/is_utf8_string>>
757 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
758 It generally needn't be if its string is entirely UTF-8 invariant, and it
759 shouldn't be if it otherwise contains invalid UTF-8.
761 It is an internal function because khw thinks that XS code shouldn't be working
762 at this low a level. A valid use case could change that.
766 PERL_STATIC_INLINE bool
767 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
769 const U8 * first_variant;
771 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
773 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
777 return is_utf8_string(first_variant, len - (first_variant - s));
783 =for apidoc is_strict_utf8_string
785 Returns TRUE if the first C<len> bytes of string C<s> form a valid
786 UTF-8-encoded string that is fully interchangeable by any application using
787 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
788 calculated using C<strlen(s)> (which means if you use this option, that C<s>
789 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
790 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
792 This function returns FALSE for strings containing any
793 code points above the Unicode max of 0x10FFFF, surrogate code points, or
794 non-character code points.
797 C<L</is_utf8_invariant_string>>,
798 C<L</is_utf8_invariant_string_loc>>,
799 C<L</is_utf8_string>>,
800 C<L</is_utf8_string_flags>>,
801 C<L</is_utf8_string_loc>>,
802 C<L</is_utf8_string_loc_flags>>,
803 C<L</is_utf8_string_loclen>>,
804 C<L</is_utf8_string_loclen_flags>>,
805 C<L</is_utf8_fixed_width_buf_flags>>,
806 C<L</is_utf8_fixed_width_buf_loc_flags>>,
807 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
808 C<L</is_strict_utf8_string_loc>>,
809 C<L</is_strict_utf8_string_loclen>>,
810 C<L</is_c9strict_utf8_string>>,
811 C<L</is_c9strict_utf8_string_loc>>,
813 C<L</is_c9strict_utf8_string_loclen>>.
818 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
821 =for apidoc is_c9strict_utf8_string
823 Returns TRUE if the first C<len> bytes of string C<s> form a valid
824 UTF-8-encoded string that conforms to
825 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
826 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
827 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
828 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
829 characters being ASCII constitute 'a valid UTF-8 string'.
831 This function returns FALSE for strings containing any code points above the
832 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
834 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
837 C<L</is_utf8_invariant_string>>,
838 C<L</is_utf8_invariant_string_loc>>,
839 C<L</is_utf8_string>>,
840 C<L</is_utf8_string_flags>>,
841 C<L</is_utf8_string_loc>>,
842 C<L</is_utf8_string_loc_flags>>,
843 C<L</is_utf8_string_loclen>>,
844 C<L</is_utf8_string_loclen_flags>>,
845 C<L</is_utf8_fixed_width_buf_flags>>,
846 C<L</is_utf8_fixed_width_buf_loc_flags>>,
847 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
848 C<L</is_strict_utf8_string>>,
849 C<L</is_strict_utf8_string_loc>>,
850 C<L</is_strict_utf8_string_loclen>>,
851 C<L</is_c9strict_utf8_string_loc>>,
853 C<L</is_c9strict_utf8_string_loclen>>.
858 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
861 =for apidoc is_utf8_string_flags
863 Returns TRUE if the first C<len> bytes of string C<s> form a valid
864 UTF-8 string, subject to the restrictions imposed by C<flags>;
865 returns FALSE otherwise. If C<len> is 0, it will be calculated
866 using C<strlen(s)> (which means if you use this option, that C<s> can't have
867 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
868 that all characters being ASCII constitute 'a valid UTF-8 string'.
870 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
871 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
872 as C<L</is_strict_utf8_string>>; and if C<flags> is
873 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
874 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
875 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
876 C<L</utf8n_to_uvchr>>, with the same meanings.
879 C<L</is_utf8_invariant_string>>,
880 C<L</is_utf8_invariant_string_loc>>,
881 C<L</is_utf8_string>>,
882 C<L</is_utf8_string_loc>>,
883 C<L</is_utf8_string_loc_flags>>,
884 C<L</is_utf8_string_loclen>>,
885 C<L</is_utf8_string_loclen_flags>>,
886 C<L</is_utf8_fixed_width_buf_flags>>,
887 C<L</is_utf8_fixed_width_buf_loc_flags>>,
888 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
889 C<L</is_strict_utf8_string>>,
890 C<L</is_strict_utf8_string_loc>>,
891 C<L</is_strict_utf8_string_loclen>>,
892 C<L</is_c9strict_utf8_string>>,
893 C<L</is_c9strict_utf8_string_loc>>,
895 C<L</is_c9strict_utf8_string_loclen>>.
900 PERL_STATIC_INLINE bool
901 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
903 const U8 * first_variant;
905 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
906 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
907 |UTF8_DISALLOW_PERL_EXTENDED)));
910 len = strlen((const char *)s);
914 return is_utf8_string(s, len);
917 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
918 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
920 return is_strict_utf8_string(s, len);
923 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
924 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
926 return is_c9strict_utf8_string(s, len);
929 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
930 const U8* const send = s + len;
931 const U8* x = first_variant;
934 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
935 if (UNLIKELY(! cur_len)) {
947 =for apidoc is_utf8_string_loc
949 Like C<L</is_utf8_string>> but stores the location of the failure (in the
950 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
951 "utf8ness success") in the C<ep> pointer.
953 See also C<L</is_utf8_string_loclen>>.
958 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
962 =for apidoc is_utf8_string_loclen
964 Like C<L</is_utf8_string>> but stores the location of the failure (in the
965 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
966 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
967 encoded characters in the C<el> pointer.
969 See also C<L</is_utf8_string_loc>>.
974 PERL_STATIC_INLINE bool
975 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
977 const U8 * first_variant;
979 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
982 len = strlen((const char *) s);
985 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
997 const U8* const send = s + len;
998 const U8* x = first_variant;
999 STRLEN outlen = first_variant - s;
1002 const STRLEN cur_len = isUTF8_CHAR(x, send);
1003 if (UNLIKELY(! cur_len)) {
1023 =for apidoc isUTF8_CHAR
1025 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1026 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1027 that represents some code point; otherwise it evaluates to 0. If non-zero, the
1028 value gives how many bytes starting at C<s> comprise the code point's
1029 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1030 form the first code point in C<s>, are not examined.
1032 The code point can be any that will fit in an IV on this machine, using Perl's
1033 extension to official UTF-8 to represent those higher than the Unicode maximum
1034 of 0x10FFFF. That means that this macro is used to efficiently decide if the
1035 next few bytes in C<s> is legal UTF-8 for a single character.
1037 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1038 defined by Unicode to be fully interchangeable across applications;
1039 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1040 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1041 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1043 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1044 C<L</is_utf8_string_loclen>> to check entire strings.
1046 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1047 machines) is a valid UTF-8 character.
1051 This uses an adaptation of the table and algorithm given in
1052 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1053 documentation of the original version. A copyright notice for the original
1054 version is given at the beginning of this file. The Perl adapation is
1055 documented at the definition of PL_extended_utf8_dfa_tab[].
1059 PERL_STATIC_INLINE Size_t
1060 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1065 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1067 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1068 * code point, which can be returned immediately. Otherwise, it is either
1069 * malformed, or for the start byte FF which the dfa doesn't handle (except
1070 * on 32-bit ASCII platforms where it trivially is an error). Call a
1071 * helper function for the other platforms. */
1073 while (s < e && LIKELY(state != 1)) {
1074 state = PL_extended_utf8_dfa_tab[256
1076 + PL_extended_utf8_dfa_tab[*s]];
1085 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1087 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1088 return is_utf8_char_helper(s0, e, 0);
1098 =for apidoc isSTRICT_UTF8_CHAR
1100 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1101 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1102 Unicode code point completely acceptable for open interchange between all
1103 applications; otherwise it evaluates to 0. If non-zero, the value gives how
1104 many bytes starting at C<s> comprise the code point's representation. Any
1105 bytes remaining before C<e>, but beyond the ones needed to form the first code
1106 point in C<s>, are not examined.
1108 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1109 be a surrogate nor a non-character code point. Thus this excludes any code
1110 point from Perl's extended UTF-8.
1112 This is used to efficiently decide if the next few bytes in C<s> is
1113 legal Unicode-acceptable UTF-8 for a single character.
1115 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1116 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1117 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1118 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1120 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1121 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1125 This uses an adaptation of the tables and algorithm given in
1126 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1127 documentation of the original version. A copyright notice for the original
1128 version is given at the beginning of this file. The Perl adapation is
1129 documented at the definition of strict_extended_utf8_dfa_tab[].
1133 PERL_STATIC_INLINE Size_t
1134 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1139 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1141 while (s < e && LIKELY(state != 1)) {
1142 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1154 /* The dfa above drops out for certain Hanguls; handle them specially */
1155 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1166 =for apidoc isC9_STRICT_UTF8_CHAR
1168 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1169 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1170 Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1171 the value gives how many bytes starting at C<s> comprise the code point's
1172 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1173 form the first code point in C<s>, are not examined.
1175 The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1176 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1177 code points. This corresponds to
1178 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1179 which said that non-character code points are merely discouraged rather than
1180 completely forbidden in open interchange. See
1181 L<perlunicode/Noncharacter code points>.
1183 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1184 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1186 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1187 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1191 This uses an adaptation of the tables and algorithm given in
1192 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1193 documentation of the original version. A copyright notice for the original
1194 version is given at the beginning of this file. The Perl adapation is
1195 documented at the definition of PL_c9_utf8_dfa_tab[].
1199 PERL_STATIC_INLINE Size_t
1200 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1205 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1207 while (s < e && LIKELY(state != 1)) {
1208 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1223 =for apidoc is_strict_utf8_string_loc
1225 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1226 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1227 "utf8ness success") in the C<ep> pointer.
1229 See also C<L</is_strict_utf8_string_loclen>>.
1234 #define is_strict_utf8_string_loc(s, len, ep) \
1235 is_strict_utf8_string_loclen(s, len, ep, 0)
1239 =for apidoc is_strict_utf8_string_loclen
1241 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1242 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1243 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1244 encoded characters in the C<el> pointer.
1246 See also C<L</is_strict_utf8_string_loc>>.
1251 PERL_STATIC_INLINE bool
1252 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1254 const U8 * first_variant;
1256 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1259 len = strlen((const char *) s);
1262 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1274 const U8* const send = s + len;
1275 const U8* x = first_variant;
1276 STRLEN outlen = first_variant - s;
1279 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1280 if (UNLIKELY(! cur_len)) {
1300 =for apidoc is_c9strict_utf8_string_loc
1302 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1303 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1304 "utf8ness success") in the C<ep> pointer.
1306 See also C<L</is_c9strict_utf8_string_loclen>>.
1311 #define is_c9strict_utf8_string_loc(s, len, ep) \
1312 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1316 =for apidoc is_c9strict_utf8_string_loclen
1318 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1319 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1320 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1321 characters in the C<el> pointer.
1323 See also C<L</is_c9strict_utf8_string_loc>>.
1328 PERL_STATIC_INLINE bool
1329 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1331 const U8 * first_variant;
1333 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1336 len = strlen((const char *) s);
1339 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1351 const U8* const send = s + len;
1352 const U8* x = first_variant;
1353 STRLEN outlen = first_variant - s;
1356 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1357 if (UNLIKELY(! cur_len)) {
1377 =for apidoc is_utf8_string_loc_flags
1379 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1380 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1381 "utf8ness success") in the C<ep> pointer.
1383 See also C<L</is_utf8_string_loclen_flags>>.
1388 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1389 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1392 /* The above 3 actual functions could have been moved into the more general one
1393 * just below, and made #defines that call it with the right 'flags'. They are
1394 * currently kept separate to increase their chances of getting inlined */
1398 =for apidoc is_utf8_string_loclen_flags
1400 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1401 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1402 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1403 encoded characters in the C<el> pointer.
1405 See also C<L</is_utf8_string_loc_flags>>.
1410 PERL_STATIC_INLINE bool
1411 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1413 const U8 * first_variant;
1415 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1416 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1417 |UTF8_DISALLOW_PERL_EXTENDED)));
1420 len = strlen((const char *) s);
1424 return is_utf8_string_loclen(s, len, ep, el);
1427 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1428 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1430 return is_strict_utf8_string_loclen(s, len, ep, el);
1433 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1434 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1436 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1439 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1451 const U8* send = s + len;
1452 const U8* x = first_variant;
1453 STRLEN outlen = first_variant - s;
1456 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1457 if (UNLIKELY(! cur_len)) {
1476 =for apidoc utf8_distance
1478 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1481 WARNING: use only if you *know* that the pointers point inside the
1487 PERL_STATIC_INLINE IV
1488 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1490 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1492 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1496 =for apidoc utf8_hop
1498 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1499 forward or backward.
1501 WARNING: do not use the following unless you *know* C<off> is within
1502 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1503 on the first byte of character or just after the last byte of a character.
1508 PERL_STATIC_INLINE U8 *
1509 Perl_utf8_hop(const U8 *s, SSize_t off)
1511 PERL_ARGS_ASSERT_UTF8_HOP;
1513 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1514 * the bitops (especially ~) can create illegal UTF-8.
1515 * In other words: in Perl UTF-8 is not just for Unicode. */
1524 while (UTF8_IS_CONTINUATION(*s))
1528 GCC_DIAG_IGNORE(-Wcast-qual)
1534 =for apidoc utf8_hop_forward
1536 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1539 C<off> must be non-negative.
1541 C<s> must be before or equal to C<end>.
1543 When moving forward it will not move beyond C<end>.
1545 Will not exceed this limit even if the string is not valid "UTF-8".
1550 PERL_STATIC_INLINE U8 *
1551 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1553 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1555 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1556 * the bitops (especially ~) can create illegal UTF-8.
1557 * In other words: in Perl UTF-8 is not just for Unicode. */
1563 STRLEN skip = UTF8SKIP(s);
1564 if ((STRLEN)(end - s) <= skip) {
1565 GCC_DIAG_IGNORE(-Wcast-qual)
1572 GCC_DIAG_IGNORE(-Wcast-qual)
1578 =for apidoc utf8_hop_back
1580 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1583 C<off> must be non-positive.
1585 C<s> must be after or equal to C<start>.
1587 When moving backward it will not move before C<start>.
1589 Will not exceed this limit even if the string is not valid "UTF-8".
1594 PERL_STATIC_INLINE U8 *
1595 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1597 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1599 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1600 * the bitops (especially ~) can create illegal UTF-8.
1601 * In other words: in Perl UTF-8 is not just for Unicode. */
1606 while (off++ && s > start) {
1609 } while (UTF8_IS_CONTINUATION(*s) && s > start);
1612 GCC_DIAG_IGNORE(-Wcast-qual)
1618 =for apidoc utf8_hop_safe
1620 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1621 either forward or backward.
1623 When moving backward it will not move before C<start>.
1625 When moving forward it will not move beyond C<end>.
1627 Will not exceed those limits even if the string is not valid "UTF-8".
1632 PERL_STATIC_INLINE U8 *
1633 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1635 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1637 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1638 * the bitops (especially ~) can create illegal UTF-8.
1639 * In other words: in Perl UTF-8 is not just for Unicode. */
1641 assert(start <= s && s <= end);
1644 return utf8_hop_forward(s, off, end);
1647 return utf8_hop_back(s, off, start);
1653 =for apidoc is_utf8_valid_partial_char
1655 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1656 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1657 points. Otherwise, it returns 1 if there exists at least one non-empty
1658 sequence of bytes that when appended to sequence C<s>, starting at position
1659 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1660 otherwise returns 0.
1662 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1665 This is useful when a fixed-length buffer is being tested for being well-formed
1666 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1667 it is split somewhere in the middle of the final code point's UTF-8
1668 representation. (Presumably when the buffer is refreshed with the next chunk
1669 of data, the new first bytes will complete the partial code point.) This
1670 function is used to verify that the final bytes in the current buffer are in
1671 fact the legal beginning of some code point, so that if they aren't, the
1672 failure can be signalled without having to wait for the next read.
1676 #define is_utf8_valid_partial_char(s, e) \
1677 is_utf8_valid_partial_char_flags(s, e, 0)
1681 =for apidoc is_utf8_valid_partial_char_flags
1683 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1684 or not the input is a valid UTF-8 encoded partial character, but it takes an
1685 extra parameter, C<flags>, which can further restrict which code points are
1688 If C<flags> is 0, this behaves identically to
1689 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1690 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1691 there is any sequence of bytes that can complete the input partial character in
1692 such a way that a non-prohibited character is formed, the function returns
1693 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1694 partial character input. But many of the other possible excluded types can be
1695 determined from just the first one or two bytes.
1700 PERL_STATIC_INLINE bool
1701 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1703 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1705 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1706 |UTF8_DISALLOW_PERL_EXTENDED)));
1708 if (s >= e || s + UTF8SKIP(s) <= e) {
1712 return cBOOL(is_utf8_char_helper(s, e, flags));
1717 =for apidoc is_utf8_fixed_width_buf_flags
1719 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1720 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1721 otherwise it returns FALSE.
1723 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1724 without restriction. If the final few bytes of the buffer do not form a
1725 complete code point, this will return TRUE anyway, provided that
1726 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1728 If C<flags> in non-zero, it can be any combination of the
1729 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1732 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1733 returns FALSE if the final few bytes of the string don't form a complete code
1738 #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1739 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1743 =for apidoc is_utf8_fixed_width_buf_loc_flags
1745 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1746 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1747 to the beginning of any partial character at the end of the buffer; if there is
1748 no partial character C<*ep> will contain C<s>+C<len>.
1750 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1755 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1756 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1760 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1762 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1763 complete, valid characters found in the C<el> pointer.
1768 PERL_STATIC_INLINE bool
1769 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1775 const U8 * maybe_partial;
1777 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1780 ep = &maybe_partial;
1783 /* If it's entirely valid, return that; otherwise see if the only error is
1784 * that the final few bytes are for a partial character */
1785 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1786 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1789 PERL_STATIC_INLINE UV
1790 Perl_utf8n_to_uvchr_msgs(const U8 *s,
1797 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1798 * simple cases, and, if necessary calls a helper function to deal with the
1799 * more complex ones. Almost all well-formed non-problematic code points
1800 * are considered simple, so that it's unlikely that the helper function
1801 * will need to be called.
1803 * This is an adaptation of the tables and algorithm given in
1804 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1805 * comprehensive documentation of the original version. A copyright notice
1806 * for the original version is given at the beginning of this file. The
1807 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1810 const U8 * const s0 = s;
1811 const U8 * send = s0 + curlen;
1812 UV uv = 0; /* The 0 silences some stupid compilers */
1815 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1817 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1818 * non-problematic code point, which can be returned immediately.
1819 * Otherwise we call a helper function to figure out the more complicated
1822 while (s < send && LIKELY(state != 1)) {
1823 UV type = PL_strict_utf8_dfa_tab[*s];
1826 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1827 : UTF8_ACCUMULATE(uv, *s);
1828 state = PL_strict_utf8_dfa_tab[256 + state + type];
1836 *retlen = s - s0 + 1;
1845 return UNI_TO_NATIVE(uv);
1848 /* Here is potentially problematic. Use the full mechanism */
1849 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1852 PERL_STATIC_INLINE UV
1853 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1855 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1859 if (! ckWARN_d(WARN_UTF8)) {
1861 /* EMPTY is not really allowed, and asserts on debugging builds. But
1862 * on non-debugging we have to deal with it, and this causes it to
1863 * return the REPLACEMENT CHARACTER, as the documentation indicates */
1864 return utf8n_to_uvchr(s, send - s, retlen,
1865 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
1868 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1869 if (retlen && ret == 0 && *s != '\0') {
1870 *retlen = (STRLEN) -1;
1877 /* ------------------------------- perl.h ----------------------------- */
1880 =for apidoc_section Utility Functions
1882 =for apidoc is_safe_syscall
1884 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1886 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1887 category, and return FALSE.
1889 Return TRUE if the name is safe.
1891 C<what> and C<op_name> are used in any warning.
1893 Used by the C<IS_SAFE_SYSCALL()> macro.
1898 PERL_STATIC_INLINE bool
1899 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1901 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1902 * perl itself uses xce*() functions which accept 8-bit strings.
1905 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1909 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1910 SETERRNO(ENOENT, LIB_INVARG);
1911 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1912 "Invalid \\0 character in %s for %s: %s\\0%s",
1913 what, op_name, pv, null_at+1);
1923 Return true if the supplied filename has a newline character
1924 immediately before the first (hopefully only) NUL.
1926 My original look at this incorrectly used the len from SvPV(), but
1927 that's incorrect, since we allow for a NUL in pv[len-1].
1929 So instead, strlen() and work from there.
1931 This allow for the user reading a filename, forgetting to chomp it,
1934 open my $foo, "$file\0";
1940 PERL_STATIC_INLINE bool
1941 S_should_warn_nl(const char *pv)
1945 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1949 return len > 0 && pv[len-1] == '\n';
1954 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1956 PERL_STATIC_INLINE bool
1957 S_lossless_NV_to_IV(const NV nv, IV *ivp)
1959 /* This function determines if the input NV 'nv' may be converted without
1960 * loss of data to an IV. If not, it returns FALSE taking no other action.
1961 * But if it is possible, it does the conversion, returning TRUE, and
1962 * storing the converted result in '*ivp' */
1964 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1966 # if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1967 /* Normally any comparison with a NaN returns false; if we can't rely
1968 * on that behaviour, check explicitly */
1969 if (UNLIKELY(Perl_isnan(nv))) {
1974 /* Written this way so that with an always-false NaN comparison we
1976 if (!(LIKELY(nv >= IV_MIN) && LIKELY(nv <= IV_MAX))) {
1980 if ((IV) nv != nv) {
1990 /* ------------------ regcomp.c, toke.c ------------ */
1992 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
1995 - regcurly - a little FSA that accepts {\d+,?\d*}
1998 PERL_STATIC_INLINE bool
1999 S_regcurly(const char *s)
2001 PERL_ARGS_ASSERT_REGCURLY;
2020 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
2022 #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
2024 #define MAX_CHARSET_NAME_LENGTH 2
2026 PERL_STATIC_INLINE const char *
2027 S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
2029 PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
2031 /* Returns a string that corresponds to the name of the regex character set
2032 * given by 'flags', and *lenp is set the length of that string, which
2033 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
2036 switch (get_regex_charset(flags)) {
2037 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
2038 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
2039 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
2040 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
2041 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2043 return ASCII_MORE_RESTRICT_PAT_MODS;
2045 /* The NOT_REACHED; hides an assert() which has a rather complex
2046 * definition in perl.h. */
2047 NOT_REACHED; /* NOTREACHED */
2048 return "?"; /* Unknown */
2055 Return false if any get magic is on the SV other than taint magic.
2059 PERL_STATIC_INLINE bool
2060 Perl_sv_only_taint_gmagic(SV *sv)
2062 MAGIC *mg = SvMAGIC(sv);
2064 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2067 if (mg->mg_type != PERL_MAGIC_taint
2068 && !(mg->mg_flags & MGf_GSKIP)
2069 && mg->mg_virtual->svt_get) {
2072 mg = mg->mg_moremagic;
2078 /* ------------------ cop.h ------------------------------------------- */
2080 /* implement GIMME_V() macro */
2082 PERL_STATIC_INLINE U8
2086 U8 gimme = (PL_op->op_flags & OPf_WANT);
2090 cxix = PL_curstackinfo->si_cxsubix;
2092 return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
2093 assert(cxstack[cxix].blk_gimme & G_WANT);
2094 return (cxstack[cxix].blk_gimme & G_WANT);
2098 /* Enter a block. Push a new base context and return its address. */
2100 PERL_STATIC_INLINE PERL_CONTEXT *
2101 Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2105 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2110 cx->blk_gimme = gimme;
2111 cx->blk_oldsaveix = saveix;
2112 cx->blk_oldsp = (I32)(sp - PL_stack_base);
2113 cx->blk_oldcop = PL_curcop;
2114 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
2115 cx->blk_oldscopesp = PL_scopestack_ix;
2116 cx->blk_oldpm = PL_curpm;
2117 cx->blk_old_tmpsfloor = PL_tmps_floor;
2119 PL_tmps_floor = PL_tmps_ix;
2120 CX_DEBUG(cx, "PUSH");
2125 /* Exit a block (RETURN and LAST). */
2127 PERL_STATIC_INLINE void
2128 Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2130 PERL_ARGS_ASSERT_CX_POPBLOCK;
2132 CX_DEBUG(cx, "POP");
2133 /* these 3 are common to cx_popblock and cx_topblock */
2134 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2135 PL_scopestack_ix = cx->blk_oldscopesp;
2136 PL_curpm = cx->blk_oldpm;
2138 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2139 * and leaves a CX entry lying around for repeated use, so
2140 * skip for multicall */ \
2141 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2142 || PL_savestack_ix == cx->blk_oldsaveix);
2143 PL_curcop = cx->blk_oldcop;
2144 PL_tmps_floor = cx->blk_old_tmpsfloor;
2147 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2148 * Whereas cx_popblock() restores the state to the point just before
2149 * cx_pushblock() was called, cx_topblock() restores it to the point just
2150 * *after* cx_pushblock() was called. */
2152 PERL_STATIC_INLINE void
2153 Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2155 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2157 CX_DEBUG(cx, "TOP");
2158 /* these 3 are common to cx_popblock and cx_topblock */
2159 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2160 PL_scopestack_ix = cx->blk_oldscopesp;
2161 PL_curpm = cx->blk_oldpm;
2163 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2167 PERL_STATIC_INLINE void
2168 Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2170 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2172 PERL_ARGS_ASSERT_CX_PUSHSUB;
2174 PERL_DTRACE_PROBE_ENTRY(cv);
2175 cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
2176 PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
2177 cx->blk_sub.cv = cv;
2178 cx->blk_sub.olddepth = CvDEPTH(cv);
2179 cx->blk_sub.prevcomppad = PL_comppad;
2180 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2181 cx->blk_sub.retop = retop;
2182 SvREFCNT_inc_simple_void_NN(cv);
2183 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2187 /* subsets of cx_popsub() */
2189 PERL_STATIC_INLINE void
2190 Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2194 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2195 assert(CxTYPE(cx) == CXt_SUB);
2197 PL_comppad = cx->blk_sub.prevcomppad;
2198 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2199 cv = cx->blk_sub.cv;
2200 CvDEPTH(cv) = cx->blk_sub.olddepth;
2201 cx->blk_sub.cv = NULL;
2203 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2207 /* handle the @_ part of leaving a sub */
2209 PERL_STATIC_INLINE void
2210 Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2214 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2215 assert(CxTYPE(cx) == CXt_SUB);
2216 assert(AvARRAY(MUTABLE_AV(
2217 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2218 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2220 CX_POP_SAVEARRAY(cx);
2221 av = MUTABLE_AV(PAD_SVl(0));
2222 if (UNLIKELY(AvREAL(av)))
2223 /* abandon @_ if it got reified */
2224 clear_defarray(av, 0);
2231 PERL_STATIC_INLINE void
2232 Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2234 PERL_ARGS_ASSERT_CX_POPSUB;
2235 assert(CxTYPE(cx) == CXt_SUB);
2237 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
2241 cx_popsub_common(cx);
2245 PERL_STATIC_INLINE void
2246 Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2248 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2250 cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2251 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2252 cx->blk_format.cv = cv;
2253 cx->blk_format.retop = retop;
2254 cx->blk_format.gv = gv;
2255 cx->blk_format.dfoutgv = PL_defoutgv;
2256 cx->blk_format.prevcomppad = PL_comppad;
2259 SvREFCNT_inc_simple_void_NN(cv);
2261 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2265 PERL_STATIC_INLINE void
2266 Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2271 PERL_ARGS_ASSERT_CX_POPFORMAT;
2272 assert(CxTYPE(cx) == CXt_FORMAT);
2274 dfout = cx->blk_format.dfoutgv;
2276 cx->blk_format.dfoutgv = NULL;
2277 SvREFCNT_dec_NN(dfout);
2279 PL_comppad = cx->blk_format.prevcomppad;
2280 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2281 cv = cx->blk_format.cv;
2282 cx->blk_format.cv = NULL;
2284 SvREFCNT_dec_NN(cv);
2285 PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
2289 PERL_STATIC_INLINE void
2290 Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2292 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2294 cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
2295 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2296 cx->blk_eval.retop = retop;
2297 cx->blk_eval.old_namesv = namesv;
2298 cx->blk_eval.old_eval_root = PL_eval_root;
2299 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2300 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2301 cx->blk_eval.cur_top_env = PL_top_env;
2303 assert(!(PL_in_eval & ~ 0x3F));
2304 assert(!(PL_op->op_type & ~0x1FF));
2305 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
2309 PERL_STATIC_INLINE void
2310 Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2314 PERL_ARGS_ASSERT_CX_POPEVAL;
2315 assert(CxTYPE(cx) == CXt_EVAL);
2317 PL_in_eval = CxOLD_IN_EVAL(cx);
2318 assert(!(PL_in_eval & 0xc0));
2319 PL_eval_root = cx->blk_eval.old_eval_root;
2320 sv = cx->blk_eval.cur_text;
2321 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
2322 cx->blk_eval.cur_text = NULL;
2323 SvREFCNT_dec_NN(sv);
2326 sv = cx->blk_eval.old_namesv;
2328 cx->blk_eval.old_namesv = NULL;
2329 SvREFCNT_dec_NN(sv);
2331 PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
2335 /* push a plain loop, i.e.
2337 * while (cond) { block }
2338 * for (init;cond;continue) { block }
2339 * This loop can be last/redo'ed etc.
2342 PERL_STATIC_INLINE void
2343 Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2345 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2346 cx->blk_loop.my_op = cLOOP;
2350 /* push a true for loop, i.e.
2351 * for var (list) { block }
2354 PERL_STATIC_INLINE void
2355 Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2357 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2359 /* this one line is common with cx_pushloop_plain */
2360 cx->blk_loop.my_op = cLOOP;
2362 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2363 cx->blk_loop.itersave = itersave;
2365 cx->blk_loop.oldcomppad = PL_comppad;
2370 /* pop all loop types, including plain */
2372 PERL_STATIC_INLINE void
2373 Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2375 PERL_ARGS_ASSERT_CX_POPLOOP;
2377 assert(CxTYPE_is_LOOP(cx));
2378 if ( CxTYPE(cx) == CXt_LOOP_ARY
2379 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2381 /* Free ary or cur. This assumes that state_u.ary.ary
2382 * aligns with state_u.lazysv.cur. See cx_dup() */
2383 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2384 cx->blk_loop.state_u.lazysv.cur = NULL;
2385 SvREFCNT_dec_NN(sv);
2386 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2387 sv = cx->blk_loop.state_u.lazysv.end;
2388 cx->blk_loop.state_u.lazysv.end = NULL;
2389 SvREFCNT_dec_NN(sv);
2392 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2394 SV **svp = (cx)->blk_loop.itervar_u.svp;
2395 if ((cx->cx_type & CXp_FOR_GV))
2396 svp = &GvSV((GV*)svp);
2398 *svp = cx->blk_loop.itersave;
2399 cx->blk_loop.itersave = NULL;
2400 SvREFCNT_dec(cursv);
2405 PERL_STATIC_INLINE void
2406 Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2408 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2410 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2414 PERL_STATIC_INLINE void
2415 Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2417 PERL_ARGS_ASSERT_CX_POPWHEN;
2418 assert(CxTYPE(cx) == CXt_WHEN);
2420 PERL_UNUSED_ARG(cx);
2421 PERL_UNUSED_CONTEXT;
2422 /* currently NOOP */
2426 PERL_STATIC_INLINE void
2427 Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2429 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2431 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2432 cx->blk_givwhen.defsv_save = orig_defsv;
2436 PERL_STATIC_INLINE void
2437 Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2441 PERL_ARGS_ASSERT_CX_POPGIVEN;
2442 assert(CxTYPE(cx) == CXt_GIVEN);
2444 sv = GvSV(PL_defgv);
2445 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2446 cx->blk_givwhen.defsv_save = NULL;
2450 /* ------------------ util.h ------------------------------------------- */
2453 =for apidoc_section String Handling
2457 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2459 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2460 match themselves and their opposite case counterparts. Non-cased and non-ASCII
2461 range bytes match only themselves.
2466 PERL_STATIC_INLINE I32
2467 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2469 const U8 *a = (const U8 *)s1;
2470 const U8 *b = (const U8 *)s2;
2472 PERL_ARGS_ASSERT_FOLDEQ;
2477 if (*a != *b && *a != PL_fold[*b])
2484 PERL_STATIC_INLINE I32
2485 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2487 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2488 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2489 * does not check for this. Nor does it check that the strings each have
2490 * at least 'len' characters. */
2492 const U8 *a = (const U8 *)s1;
2493 const U8 *b = (const U8 *)s2;
2495 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2500 if (*a != *b && *a != PL_fold_latin1[*b]) {
2509 =for apidoc_section Locales
2510 =for apidoc foldEQ_locale
2512 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2513 same case-insensitively in the current locale; false otherwise.
2518 PERL_STATIC_INLINE I32
2519 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2521 const U8 *a = (const U8 *)s1;
2522 const U8 *b = (const U8 *)s2;
2524 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2529 if (*a != *b && *a != PL_fold_locale[*b])
2537 =for apidoc_section String Handling
2538 =for apidoc my_strnlen
2540 The C library C<strnlen> if available, or a Perl implementation of it.
2542 C<my_strnlen()> computes the length of the string, up to C<maxlen>
2543 characters. It will never attempt to address more than C<maxlen>
2544 characters, making it suitable for use with strings that are not
2545 guaranteed to be NUL-terminated.
2549 Description stolen from http://man.openbsd.org/strnlen.3,
2550 implementation stolen from PostgreSQL.
2554 PERL_STATIC_INLINE Size_t
2555 Perl_my_strnlen(const char *str, Size_t maxlen)
2557 const char *end = (char *) memchr(str, '\0', maxlen);
2559 PERL_ARGS_ASSERT_MY_STRNLEN;
2561 if (end == NULL) return maxlen;
2567 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2569 PERL_STATIC_INLINE void *
2570 S_my_memrchr(const char * s, const char c, const STRLEN len)
2572 /* memrchr(), since many platforms lack it */
2574 const char * t = s + len - 1;
2576 PERL_ARGS_ASSERT_MY_MEMRCHR;
2590 PERL_STATIC_INLINE char *
2591 Perl_mortal_getenv(const char * str)
2593 /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
2595 * It's (mostly) thread-safe because it uses a mutex to prevent
2596 * simultaneous access from other threads that use the same mutex, and
2597 * makes a copy of the result before releasing that mutex. All of the Perl
2598 * core uses that mutex, but, like all mutexes, everything has to cooperate
2599 * for it to completely work. It is possible for code from, say XS, to not
2600 * use this mutex, defeating the safety.
2602 * On some platforms, getenv() is not sequential-call-safe, because
2603 * subsequent calls destroy the static storage inside the C library
2604 * returned by an earlier call. The result must be copied or completely
2605 * acted upon before a subsequent getenv call. Those calls could come from
2606 * another thread. Again, making a copy while controlling the mutex
2607 * prevents these problems..
2609 * To prevent leaks, the copy is made by creating a new SV containing it,
2610 * mortalizing the SV, and returning the SV's string (the copy). Thus this
2611 * is a drop-in replacement for getenv().
2613 * A complication is that this can be called during phases where the
2614 * mortalization process isn't available. These are in interpreter
2615 * destruction or early in construction. khw believes that at these times
2616 * there shouldn't be anything else going on, so plain getenv is safe AS
2617 * LONG AS the caller acts on the return before calling it again. */
2622 PERL_ARGS_ASSERT_MORTAL_GETENV;
2624 /* Can't mortalize without stacks. khw believes that no other threads
2625 * should be running, so no need to lock things, and this may be during a
2626 * phase when locking isn't even available */
2627 if (UNLIKELY(PL_scopestack_ix == 0)) {
2636 ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
2644 * ex: set ts=8 sts=4 sw=4 et: