File Coverage

/usr/local/lib/perl5/5.26.1/x86_64-linux/CORE/inline.h
Criterion Covered Total %
statement 2 4 50.0
branch n/a
condition n/a
subroutine n/a
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             /* inline.h
2             *
3             * Copyright (C) 2012 by Larry Wall and others
4             *
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.
7             *
8             * This file is a home for static inline functions that cannot go in other
9             * headers files, because they depend on proto.h (included after most other
10             * headers) or struct definitions.
11             *
12             * Each section names the header file that the functions "belong" to.
13             */
14              
15             /* ------------------------------- av.h ------------------------------- */
16              
17             PERL_STATIC_INLINE SSize_t
18             S_av_top_index(pTHX_ AV *av)
19             {
20             PERL_ARGS_ASSERT_AV_TOP_INDEX;
21             assert(SvTYPE(av) == SVt_PVAV);
22              
23             return AvFILL(av);
24             }
25              
26             /* ------------------------------- cv.h ------------------------------- */
27              
28             PERL_STATIC_INLINE GV *
29             S_CvGV(pTHX_ CV *sv)
30             {
31             return CvNAMED(sv)
32             ? Perl_cvgv_from_hek(aTHX_ sv)
33             : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
34             }
35              
36             PERL_STATIC_INLINE I32 *
37             S_CvDEPTHp(const CV * const sv)
38             {
39             assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
40             return &((XPVCV*)SvANY(sv))->xcv_depth;
41             }
42              
43             /*
44             CvPROTO returns the prototype as stored, which is not necessarily what
45             the interpreter should be using. Specifically, the interpreter assumes
46             that spaces have been stripped, which has been the case if the prototype
47             was added by toke.c, but is generally not the case if it was added elsewhere.
48             Since we can't enforce the spacelessness at assignment time, this routine
49             provides a temporary copy at parse time with spaces removed.
50             I<orig> is the start of the original buffer, I<len> is the length of the
51             prototype and will be updated when this returns.
52             */
53              
54             #ifdef PERL_CORE
55             PERL_STATIC_INLINE char *
56             S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
57             {
58             SV * tmpsv;
59             char * tmps;
60             tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
61             tmps = SvPVX(tmpsv);
62             while ((*len)--) {
63             if (!isSPACE(*orig))
64             *tmps++ = *orig;
65             orig++;
66             }
67             *tmps = '\0';
68             *len = tmps - SvPVX(tmpsv);
69             return SvPVX(tmpsv);
70             }
71             #endif
72              
73             /* ------------------------------- mg.h ------------------------------- */
74              
75             #if defined(PERL_CORE) || defined(PERL_EXT)
76             /* assumes get-magic and stringification have already occurred */
77             PERL_STATIC_INLINE STRLEN
78             S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
79             {
80             assert(mg->mg_type == PERL_MAGIC_regex_global);
81             assert(mg->mg_len != -1);
82             if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
83             return (STRLEN)mg->mg_len;
84             else {
85             const STRLEN pos = (STRLEN)mg->mg_len;
86             /* Without this check, we may read past the end of the buffer: */
87             if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
88             return sv_or_pv_pos_u2b(sv, s, pos, NULL);
89             }
90             }
91             #endif
92              
93             /* ------------------------------- pad.h ------------------------------ */
94              
95             #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96             PERL_STATIC_INLINE bool
97             PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
98             {
99             /* is seq within the range _LOW to _HIGH ?
100             * This is complicated by the fact that PL_cop_seqmax
101             * may have wrapped around at some point */
102             if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
103             return FALSE; /* not yet introduced */
104              
105             if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
106             /* in compiling scope */
107             if (
108             (seq > COP_SEQ_RANGE_LOW(pn))
109             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
110             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
111             )
112             return TRUE;
113             }
114             else if (
115             (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
116             ?
117             ( seq > COP_SEQ_RANGE_LOW(pn)
118             || seq <= COP_SEQ_RANGE_HIGH(pn))
119              
120             : ( seq > COP_SEQ_RANGE_LOW(pn)
121             && seq <= COP_SEQ_RANGE_HIGH(pn))
122             )
123             return TRUE;
124             return FALSE;
125             }
126             #endif
127              
128             /* ------------------------------- pp.h ------------------------------- */
129              
130             PERL_STATIC_INLINE I32
131             S_TOPMARK(pTHX)
132             {
133             DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
134             "MARK top %p %" IVdf "\n",
135             PL_markstack_ptr,
136             (IV)*PL_markstack_ptr)));
137             return *PL_markstack_ptr;
138             }
139              
140             PERL_STATIC_INLINE I32
141 6998           S_POPMARK(pTHX)
142             {
143             DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
144             "MARK pop %p %" IVdf "\n",
145             (PL_markstack_ptr-1),
146             (IV)*(PL_markstack_ptr-1))));
147             assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
148 6998           return *PL_markstack_ptr--;
149             }
150              
151             /* ----------------------------- regexp.h ----------------------------- */
152              
153             PERL_STATIC_INLINE struct regexp *
154             S_ReANY(const REGEXP * const re)
155             {
156             assert(isREGEXP(re));
157             return re->sv_u.svu_rx;
158             }
159              
160             /* ------------------------------- sv.h ------------------------------- */
161              
162             PERL_STATIC_INLINE SV *
163             S_SvREFCNT_inc(SV *sv)
164             {
165             if (LIKELY(sv != NULL))
166             SvREFCNT(sv)++;
167             return sv;
168             }
169             PERL_STATIC_INLINE SV *
170             S_SvREFCNT_inc_NN(SV *sv)
171             {
172             SvREFCNT(sv)++;
173             return sv;
174             }
175             PERL_STATIC_INLINE void
176             S_SvREFCNT_inc_void(SV *sv)
177             {
178             if (LIKELY(sv != NULL))
179             SvREFCNT(sv)++;
180             }
181             PERL_STATIC_INLINE void
182             S_SvREFCNT_dec(pTHX_ SV *sv)
183             {
184             if (LIKELY(sv != NULL)) {
185             U32 rc = SvREFCNT(sv);
186             if (LIKELY(rc > 1))
187             SvREFCNT(sv) = rc - 1;
188             else
189             Perl_sv_free2(aTHX_ sv, rc);
190             }
191             }
192              
193             PERL_STATIC_INLINE void
194             S_SvREFCNT_dec_NN(pTHX_ SV *sv)
195             {
196             U32 rc = SvREFCNT(sv);
197             if (LIKELY(rc > 1))
198             SvREFCNT(sv) = rc - 1;
199             else
200             Perl_sv_free2(aTHX_ sv, rc);
201             }
202              
203             PERL_STATIC_INLINE void
204             SvAMAGIC_on(SV *sv)
205             {
206             assert(SvROK(sv));
207             if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
208             }
209             PERL_STATIC_INLINE void
210             SvAMAGIC_off(SV *sv)
211             {
212             if (SvROK(sv) && SvOBJECT(SvRV(sv)))
213             HvAMAGIC_off(SvSTASH(SvRV(sv)));
214             }
215              
216             PERL_STATIC_INLINE U32
217             S_SvPADSTALE_on(SV *sv)
218             {
219             assert(!(SvFLAGS(sv) & SVs_PADTMP));
220             return SvFLAGS(sv) |= SVs_PADSTALE;
221             }
222             PERL_STATIC_INLINE U32
223             S_SvPADSTALE_off(SV *sv)
224             {
225             assert(!(SvFLAGS(sv) & SVs_PADTMP));
226             return SvFLAGS(sv) &= ~SVs_PADSTALE;
227             }
228             #if defined(PERL_CORE) || defined (PERL_EXT)
229             PERL_STATIC_INLINE STRLEN
230             S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
231             {
232             PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
233             if (SvGAMAGIC(sv)) {
234             U8 *hopped = utf8_hop((U8 *)pv, pos);
235             if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
236             return (STRLEN)(hopped - (U8 *)pv);
237             }
238             return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
239             }
240             #endif
241              
242             /* ------------------------------- handy.h ------------------------------- */
243              
244             /* saves machine code for a common noreturn idiom typically used in Newx*() */
245             #ifdef GCC_DIAG_PRAGMA
246             GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
247             #endif
248             static void
249 0           S_croak_memory_wrap(void)
250             {
251 0           Perl_croak_nocontext("%s",PL_memory_wrap);
252             }
253             #ifdef GCC_DIAG_PRAGMA
254             GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
255             #endif
256              
257             /* ------------------------------- utf8.h ------------------------------- */
258              
259             /*
260             =head1 Unicode Support
261             */
262              
263             PERL_STATIC_INLINE void
264             S_append_utf8_from_native_byte(const U8 byte, U8** dest)
265             {
266             /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
267             * encoded string at '*dest', updating '*dest' to include it */
268              
269             PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
270              
271             if (NATIVE_BYTE_IS_INVARIANT(byte))
272             *((*dest)++) = byte;
273             else {
274             *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
275             *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
276             }
277             }
278              
279             /*
280             =for apidoc valid_utf8_to_uvchr
281             Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
282             the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
283             it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
284             non-Unicode code points are allowed.
285              
286             =cut
287              
288             */
289              
290             PERL_STATIC_INLINE UV
291             Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
292             {
293             const UV expectlen = UTF8SKIP(s);
294             const U8* send = s + expectlen;
295             UV uv = *s;
296              
297             PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
298              
299             if (retlen) {
300             *retlen = expectlen;
301             }
302              
303             /* An invariant is trivially returned */
304             if (expectlen == 1) {
305             return uv;
306             }
307              
308             /* Remove the leading bits that indicate the number of bytes, leaving just
309             * the bits that are part of the value */
310             uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
311              
312             /* Now, loop through the remaining bytes, accumulating each into the
313             * working total as we go. (I khw tried unrolling the loop for up to 4
314             * bytes, but there was no performance improvement) */
315             for (++s; s < send; s++) {
316             uv = UTF8_ACCUMULATE(uv, *s);
317             }
318              
319             return UNI_TO_NATIVE(uv);
320              
321             }
322              
323             /*
324             =for apidoc is_utf8_invariant_string
325              
326             Returns TRUE if the first C<len> bytes of the string C<s> are the same
327             regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
328             EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
329             are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
330             the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
331             characters are invariant, but so also are the C1 controls.
332              
333             If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
334             use this option, that C<s> can't have embedded C<NUL> characters and has to
335             have a terminating C<NUL> byte).
336              
337             See also
338             C<L</is_utf8_string>>,
339             C<L</is_utf8_string_flags>>,
340             C<L</is_utf8_string_loc>>,
341             C<L</is_utf8_string_loc_flags>>,
342             C<L</is_utf8_string_loclen>>,
343             C<L</is_utf8_string_loclen_flags>>,
344             C<L</is_utf8_fixed_width_buf_flags>>,
345             C<L</is_utf8_fixed_width_buf_loc_flags>>,
346             C<L</is_utf8_fixed_width_buf_loclen_flags>>,
347             C<L</is_strict_utf8_string>>,
348             C<L</is_strict_utf8_string_loc>>,
349             C<L</is_strict_utf8_string_loclen>>,
350             C<L</is_c9strict_utf8_string>>,
351             C<L</is_c9strict_utf8_string_loc>>,
352             and
353             C<L</is_c9strict_utf8_string_loclen>>.
354              
355             =cut
356             */
357              
358             PERL_STATIC_INLINE bool
359             S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
360             {
361             const U8* const send = s + (len ? len : strlen((const char *)s));
362             const U8* x = s;
363              
364             PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
365              
366             for (; x < send; ++x) {
367             if (!UTF8_IS_INVARIANT(*x))
368             return FALSE;
369             }
370              
371             return TRUE;
372             }
373              
374             /*
375             =for apidoc is_utf8_string
376              
377             Returns TRUE if the first C<len> bytes of string C<s> form a valid
378             Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
379             be calculated using C<strlen(s)> (which means if you use this option, that C<s>
380             can't have embedded C<NUL> characters and has to have a terminating C<NUL>
381             byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
382              
383             This function considers Perl's extended UTF-8 to be valid. That means that
384             code points above Unicode, surrogates, and non-character code points are
385             considered valid by this function. Use C<L</is_strict_utf8_string>>,
386             C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
387             code points are considered valid.
388              
389             See also
390             C<L</is_utf8_invariant_string>>,
391             C<L</is_utf8_string_loc>>,
392             C<L</is_utf8_string_loclen>>,
393             C<L</is_utf8_fixed_width_buf_flags>>,
394             C<L</is_utf8_fixed_width_buf_loc_flags>>,
395             C<L</is_utf8_fixed_width_buf_loclen_flags>>,
396              
397             =cut
398             */
399              
400             PERL_STATIC_INLINE bool
401             Perl_is_utf8_string(const U8 *s, const STRLEN len)
402             {
403             /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
404             * Be aware of possible changes to that */
405              
406             const U8* const send = s + (len ? len : strlen((const char *)s));
407             const U8* x = s;
408              
409             PERL_ARGS_ASSERT_IS_UTF8_STRING;
410              
411             while (x < send) {
412             const STRLEN cur_len = isUTF8_CHAR(x, send);
413             if (UNLIKELY(! cur_len)) {
414             return FALSE;
415             }
416             x += cur_len;
417             }
418              
419             return TRUE;
420             }
421              
422             /*
423             =for apidoc is_strict_utf8_string
424              
425             Returns TRUE if the first C<len> bytes of string C<s> form a valid
426             UTF-8-encoded string that is fully interchangeable by any application using
427             Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
428             calculated using C<strlen(s)> (which means if you use this option, that C<s>
429             can't have embedded C<NUL> characters and has to have a terminating C<NUL>
430             byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
431              
432             This function returns FALSE for strings containing any
433             code points above the Unicode max of 0x10FFFF, surrogate code points, or
434             non-character code points.
435              
436             See also
437             C<L</is_utf8_invariant_string>>,
438             C<L</is_utf8_string>>,
439             C<L</is_utf8_string_flags>>,
440             C<L</is_utf8_string_loc>>,
441             C<L</is_utf8_string_loc_flags>>,
442             C<L</is_utf8_string_loclen>>,
443             C<L</is_utf8_string_loclen_flags>>,
444             C<L</is_utf8_fixed_width_buf_flags>>,
445             C<L</is_utf8_fixed_width_buf_loc_flags>>,
446             C<L</is_utf8_fixed_width_buf_loclen_flags>>,
447             C<L</is_strict_utf8_string_loc>>,
448             C<L</is_strict_utf8_string_loclen>>,
449             C<L</is_c9strict_utf8_string>>,
450             C<L</is_c9strict_utf8_string_loc>>,
451             and
452             C<L</is_c9strict_utf8_string_loclen>>.
453              
454             =cut
455             */
456              
457             PERL_STATIC_INLINE bool
458             S_is_strict_utf8_string(const U8 *s, const STRLEN len)
459             {
460             const U8* const send = s + (len ? len : strlen((const char *)s));
461             const U8* x = s;
462              
463             PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING;
464              
465             while (x < send) {
466             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
467             if (UNLIKELY(! cur_len)) {
468             return FALSE;
469             }
470             x += cur_len;
471             }
472              
473             return TRUE;
474             }
475              
476             /*
477             =for apidoc is_c9strict_utf8_string
478              
479             Returns TRUE if the first C<len> bytes of string C<s> form a valid
480             UTF-8-encoded string that conforms to
481             L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
482             otherwise it returns FALSE. If C<len> is 0, it will be calculated using
483             C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
484             C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
485             characters being ASCII constitute 'a valid UTF-8 string'.
486              
487             This function returns FALSE for strings containing any code points above the
488             Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
489             code points per
490             L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
491              
492             See also
493             C<L</is_utf8_invariant_string>>,
494             C<L</is_utf8_string>>,
495             C<L</is_utf8_string_flags>>,
496             C<L</is_utf8_string_loc>>,
497             C<L</is_utf8_string_loc_flags>>,
498             C<L</is_utf8_string_loclen>>,
499             C<L</is_utf8_string_loclen_flags>>,
500             C<L</is_utf8_fixed_width_buf_flags>>,
501             C<L</is_utf8_fixed_width_buf_loc_flags>>,
502             C<L</is_utf8_fixed_width_buf_loclen_flags>>,
503             C<L</is_strict_utf8_string>>,
504             C<L</is_strict_utf8_string_loc>>,
505             C<L</is_strict_utf8_string_loclen>>,
506             C<L</is_c9strict_utf8_string_loc>>,
507             and
508             C<L</is_c9strict_utf8_string_loclen>>.
509              
510             =cut
511             */
512              
513             PERL_STATIC_INLINE bool
514             S_is_c9strict_utf8_string(const U8 *s, const STRLEN len)
515             {
516             const U8* const send = s + (len ? len : strlen((const char *)s));
517             const U8* x = s;
518              
519             PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING;
520              
521             while (x < send) {
522             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
523             if (UNLIKELY(! cur_len)) {
524             return FALSE;
525             }
526             x += cur_len;
527             }
528              
529             return TRUE;
530             }
531              
532             /* The above 3 functions could have been moved into the more general one just
533             * below, and made #defines that call it with the right 'flags'. They are
534             * currently kept separate to increase their chances of getting inlined */
535              
536             /*
537             =for apidoc is_utf8_string_flags
538              
539             Returns TRUE if the first C<len> bytes of string C<s> form a valid
540             UTF-8 string, subject to the restrictions imposed by C<flags>;
541             returns FALSE otherwise. If C<len> is 0, it will be calculated
542             using C<strlen(s)> (which means if you use this option, that C<s> can't have
543             embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
544             that all characters being ASCII constitute 'a valid UTF-8 string'.
545              
546             If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
547             C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
548             as C<L</is_strict_utf8_string>>; and if C<flags> is
549             C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
550             C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
551             combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
552             C<L</utf8n_to_uvchr>>, with the same meanings.
553              
554             See also
555             C<L</is_utf8_invariant_string>>,
556             C<L</is_utf8_string>>,
557             C<L</is_utf8_string_loc>>,
558             C<L</is_utf8_string_loc_flags>>,
559             C<L</is_utf8_string_loclen>>,
560             C<L</is_utf8_string_loclen_flags>>,
561             C<L</is_utf8_fixed_width_buf_flags>>,
562             C<L</is_utf8_fixed_width_buf_loc_flags>>,
563             C<L</is_utf8_fixed_width_buf_loclen_flags>>,
564             C<L</is_strict_utf8_string>>,
565             C<L</is_strict_utf8_string_loc>>,
566             C<L</is_strict_utf8_string_loclen>>,
567             C<L</is_c9strict_utf8_string>>,
568             C<L</is_c9strict_utf8_string_loc>>,
569             and
570             C<L</is_c9strict_utf8_string_loclen>>.
571              
572             =cut
573             */
574              
575             PERL_STATIC_INLINE bool
576             S_is_utf8_string_flags(const U8 *s, const STRLEN len, const U32 flags)
577             {
578             const U8* const send = s + (len ? len : strlen((const char *)s));
579             const U8* x = s;
580              
581             PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
582             assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
583             |UTF8_DISALLOW_ABOVE_31_BIT)));
584              
585             if (flags == 0) {
586             return is_utf8_string(s, len);
587             }
588              
589             if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
590             == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
591             {
592             return is_strict_utf8_string(s, len);
593             }
594              
595             if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
596             == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
597             {
598             return is_c9strict_utf8_string(s, len);
599             }
600              
601             while (x < send) {
602             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
603             if (UNLIKELY(! cur_len)) {
604             return FALSE;
605             }
606             x += cur_len;
607             }
608              
609             return TRUE;
610             }
611              
612             /*
613              
614             =for apidoc is_utf8_string_loc
615              
616             Like C<L</is_utf8_string>> but stores the location of the failure (in the
617             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
618             "utf8ness success") in the C<ep> pointer.
619              
620             See also C<L</is_utf8_string_loclen>>.
621              
622             =cut
623             */
624              
625             #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
626              
627             /*
628              
629             =for apidoc is_utf8_string_loclen
630              
631             Like C<L</is_utf8_string>> but stores the location of the failure (in the
632             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
633             "utf8ness success") in the C<ep> pointer, and the number of UTF-8
634             encoded characters in the C<el> pointer.
635              
636             See also C<L</is_utf8_string_loc>>.
637              
638             =cut
639             */
640              
641             PERL_STATIC_INLINE bool
642             Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
643             {
644             const U8* const send = s + (len ? len : strlen((const char *)s));
645             const U8* x = s;
646             STRLEN outlen = 0;
647              
648             PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
649              
650             while (x < send) {
651             const STRLEN cur_len = isUTF8_CHAR(x, send);
652             if (UNLIKELY(! cur_len)) {
653             break;
654             }
655             x += cur_len;
656             outlen++;
657             }
658              
659             if (el)
660             *el = outlen;
661              
662             if (ep) {
663             *ep = x;
664             }
665              
666             return (x == send);
667             }
668              
669             /*
670              
671             =for apidoc is_strict_utf8_string_loc
672              
673             Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
674             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
675             "utf8ness success") in the C<ep> pointer.
676              
677             See also C<L</is_strict_utf8_string_loclen>>.
678              
679             =cut
680             */
681              
682             #define is_strict_utf8_string_loc(s, len, ep) \
683             is_strict_utf8_string_loclen(s, len, ep, 0)
684              
685             /*
686              
687             =for apidoc is_strict_utf8_string_loclen
688              
689             Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
690             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
691             "utf8ness success") in the C<ep> pointer, and the number of UTF-8
692             encoded characters in the C<el> pointer.
693              
694             See also C<L</is_strict_utf8_string_loc>>.
695              
696             =cut
697             */
698              
699             PERL_STATIC_INLINE bool
700             S_is_strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
701             {
702             const U8* const send = s + (len ? len : strlen((const char *)s));
703             const U8* x = s;
704             STRLEN outlen = 0;
705              
706             PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
707              
708             while (x < send) {
709             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
710             if (UNLIKELY(! cur_len)) {
711             break;
712             }
713             x += cur_len;
714             outlen++;
715             }
716              
717             if (el)
718             *el = outlen;
719              
720             if (ep) {
721             *ep = x;
722             }
723              
724             return (x == send);
725             }
726              
727             /*
728              
729             =for apidoc is_c9strict_utf8_string_loc
730              
731             Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
732             the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
733             "utf8ness success") in the C<ep> pointer.
734              
735             See also C<L</is_c9strict_utf8_string_loclen>>.
736              
737             =cut
738             */
739              
740             #define is_c9strict_utf8_string_loc(s, len, ep) \
741             is_c9strict_utf8_string_loclen(s, len, ep, 0)
742              
743             /*
744              
745             =for apidoc is_c9strict_utf8_string_loclen
746              
747             Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
748             the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
749             "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
750             characters in the C<el> pointer.
751              
752             See also C<L</is_c9strict_utf8_string_loc>>.
753              
754             =cut
755             */
756              
757             PERL_STATIC_INLINE bool
758             S_is_c9strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
759             {
760             const U8* const send = s + (len ? len : strlen((const char *)s));
761             const U8* x = s;
762             STRLEN outlen = 0;
763              
764             PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
765              
766             while (x < send) {
767             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
768             if (UNLIKELY(! cur_len)) {
769             break;
770             }
771             x += cur_len;
772             outlen++;
773             }
774              
775             if (el)
776             *el = outlen;
777              
778             if (ep) {
779             *ep = x;
780             }
781              
782             return (x == send);
783             }
784              
785             /*
786              
787             =for apidoc is_utf8_string_loc_flags
788              
789             Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
790             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
791             "utf8ness success") in the C<ep> pointer.
792              
793             See also C<L</is_utf8_string_loclen_flags>>.
794              
795             =cut
796             */
797              
798             #define is_utf8_string_loc_flags(s, len, ep, flags) \
799             is_utf8_string_loclen_flags(s, len, ep, 0, flags)
800              
801              
802             /* The above 3 actual functions could have been moved into the more general one
803             * just below, and made #defines that call it with the right 'flags'. They are
804             * currently kept separate to increase their chances of getting inlined */
805              
806             /*
807              
808             =for apidoc is_utf8_string_loclen_flags
809              
810             Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
811             case of "utf8ness failure") or the location C<s>+C<len> (in the case of
812             "utf8ness success") in the C<ep> pointer, and the number of UTF-8
813             encoded characters in the C<el> pointer.
814              
815             See also C<L</is_utf8_string_loc_flags>>.
816              
817             =cut
818             */
819              
820             PERL_STATIC_INLINE bool
821             S_is_utf8_string_loclen_flags(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
822             {
823             const U8* const send = s + (len ? len : strlen((const char *)s));
824             const U8* x = s;
825             STRLEN outlen = 0;
826              
827             PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
828             assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
829             |UTF8_DISALLOW_ABOVE_31_BIT)));
830              
831             if (flags == 0) {
832             return is_utf8_string_loclen(s, len, ep, el);
833             }
834              
835             if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
836             == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
837             {
838             return is_strict_utf8_string_loclen(s, len, ep, el);
839             }
840              
841             if ((flags & ~UTF8_DISALLOW_ABOVE_31_BIT)
842             == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
843             {
844             return is_c9strict_utf8_string_loclen(s, len, ep, el);
845             }
846              
847             while (x < send) {
848             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
849             if (UNLIKELY(! cur_len)) {
850             break;
851             }
852             x += cur_len;
853             outlen++;
854             }
855              
856             if (el)
857             *el = outlen;
858              
859             if (ep) {
860             *ep = x;
861             }
862              
863             return (x == send);
864             }
865              
866             /*
867             =for apidoc utf8_distance
868              
869             Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
870             and C<b>.
871              
872             WARNING: use only if you *know* that the pointers point inside the
873             same UTF-8 buffer.
874              
875             =cut
876             */
877              
878             PERL_STATIC_INLINE IV
879             Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
880             {
881             PERL_ARGS_ASSERT_UTF8_DISTANCE;
882              
883             return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
884             }
885              
886             /*
887             =for apidoc utf8_hop
888              
889             Return the UTF-8 pointer C<s> displaced by C<off> characters, either
890             forward or backward.
891              
892             WARNING: do not use the following unless you *know* C<off> is within
893             the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
894             on the first byte of character or just after the last byte of a character.
895              
896             =cut
897             */
898              
899             PERL_STATIC_INLINE U8 *
900             Perl_utf8_hop(const U8 *s, SSize_t off)
901             {
902             PERL_ARGS_ASSERT_UTF8_HOP;
903              
904             /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
905             * the bitops (especially ~) can create illegal UTF-8.
906             * In other words: in Perl UTF-8 is not just for Unicode. */
907              
908             if (off >= 0) {
909             while (off--)
910             s += UTF8SKIP(s);
911             }
912             else {
913             while (off++) {
914             s--;
915             while (UTF8_IS_CONTINUATION(*s))
916             s--;
917             }
918             }
919             GCC_DIAG_IGNORE(-Wcast-qual);
920             return (U8 *)s;
921             GCC_DIAG_RESTORE;
922             }
923              
924             /*
925             =for apidoc utf8_hop_forward
926              
927             Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
928             forward.
929              
930             C<off> must be non-negative.
931              
932             C<s> must be before or equal to C<end>.
933              
934             When moving forward it will not move beyond C<end>.
935              
936             Will not exceed this limit even if the string is not valid "UTF-8".
937              
938             =cut
939             */
940              
941             PERL_STATIC_INLINE U8 *
942             Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
943             {
944             PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
945              
946             /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
947             * the bitops (especially ~) can create illegal UTF-8.
948             * In other words: in Perl UTF-8 is not just for Unicode. */
949              
950             assert(s <= end);
951             assert(off >= 0);
952              
953             while (off--) {
954             STRLEN skip = UTF8SKIP(s);
955             if ((STRLEN)(end - s) <= skip) {
956             GCC_DIAG_IGNORE(-Wcast-qual);
957             return (U8 *)end;
958             GCC_DIAG_RESTORE;
959             }
960             s += skip;
961             }
962              
963             GCC_DIAG_IGNORE(-Wcast-qual);
964             return (U8 *)s;
965             GCC_DIAG_RESTORE;
966             }
967              
968             /*
969             =for apidoc utf8_hop_back
970              
971             Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
972             backward.
973              
974             C<off> must be non-positive.
975              
976             C<s> must be after or equal to C<start>.
977              
978             When moving backward it will not move before C<start>.
979              
980             Will not exceed this limit even if the string is not valid "UTF-8".
981              
982             =cut
983             */
984              
985             PERL_STATIC_INLINE U8 *
986             Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
987             {
988             PERL_ARGS_ASSERT_UTF8_HOP_BACK;
989              
990             /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
991             * the bitops (especially ~) can create illegal UTF-8.
992             * In other words: in Perl UTF-8 is not just for Unicode. */
993              
994             assert(start <= s);
995             assert(off <= 0);
996              
997             while (off++ && s > start) {
998             s--;
999             while (UTF8_IS_CONTINUATION(*s) && s > start)
1000             s--;
1001             }
1002            
1003             GCC_DIAG_IGNORE(-Wcast-qual);
1004             return (U8 *)s;
1005             GCC_DIAG_RESTORE;
1006             }
1007              
1008             /*
1009             =for apidoc utf8_hop_safe
1010              
1011             Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1012             either forward or backward.
1013              
1014             When moving backward it will not move before C<start>.
1015              
1016             When moving forward it will not move beyond C<end>.
1017              
1018             Will not exceed those limits even if the string is not valid "UTF-8".
1019              
1020             =cut
1021             */
1022              
1023             PERL_STATIC_INLINE U8 *
1024             Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1025             {
1026             PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1027              
1028             /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1029             * the bitops (especially ~) can create illegal UTF-8.
1030             * In other words: in Perl UTF-8 is not just for Unicode. */
1031              
1032             assert(start <= s && s <= end);
1033              
1034             if (off >= 0) {
1035             return utf8_hop_forward(s, off, end);
1036             }
1037             else {
1038             return utf8_hop_back(s, off, start);
1039             }
1040             }
1041              
1042             /*
1043              
1044             =for apidoc is_utf8_valid_partial_char
1045              
1046             Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1047             S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1048             points. Otherwise, it returns 1 if there exists at least one non-empty
1049             sequence of bytes that when appended to sequence C<s>, starting at position
1050             C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1051             otherwise returns 0.
1052              
1053             In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1054             point.
1055              
1056             This is useful when a fixed-length buffer is being tested for being well-formed
1057             UTF-8, but the final few bytes in it don't comprise a full character; that is,
1058             it is split somewhere in the middle of the final code point's UTF-8
1059             representation. (Presumably when the buffer is refreshed with the next chunk
1060             of data, the new first bytes will complete the partial code point.) This
1061             function is used to verify that the final bytes in the current buffer are in
1062             fact the legal beginning of some code point, so that if they aren't, the
1063             failure can be signalled without having to wait for the next read.
1064              
1065             =cut
1066             */
1067             #define is_utf8_valid_partial_char(s, e) \
1068             is_utf8_valid_partial_char_flags(s, e, 0)
1069              
1070             /*
1071              
1072             =for apidoc is_utf8_valid_partial_char_flags
1073              
1074             Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1075             or not the input is a valid UTF-8 encoded partial character, but it takes an
1076             extra parameter, C<flags>, which can further restrict which code points are
1077             considered valid.
1078              
1079             If C<flags> is 0, this behaves identically to
1080             C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1081             of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1082             there is any sequence of bytes that can complete the input partial character in
1083             such a way that a non-prohibited character is formed, the function returns
1084             TRUE; otherwise FALSE. Non character code points cannot be determined based on
1085             partial character input. But many of the other possible excluded types can be
1086             determined from just the first one or two bytes.
1087              
1088             =cut
1089             */
1090              
1091             PERL_STATIC_INLINE bool
1092             S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1093             {
1094             PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1095              
1096             assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1097             |UTF8_DISALLOW_ABOVE_31_BIT)));
1098              
1099             if (s >= e || s + UTF8SKIP(s) <= e) {
1100             return FALSE;
1101             }
1102              
1103             return cBOOL(_is_utf8_char_helper(s, e, flags));
1104             }
1105              
1106             /*
1107              
1108             =for apidoc is_utf8_fixed_width_buf_flags
1109              
1110             Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1111             is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1112             otherwise it returns FALSE.
1113              
1114             If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1115             without restriction. If the final few bytes of the buffer do not form a
1116             complete code point, this will return TRUE anyway, provided that
1117             C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1118              
1119             If C<flags> in non-zero, it can be any combination of the
1120             C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1121             same meanings.
1122              
1123             This function differs from C<L</is_utf8_string_flags>> only in that the latter
1124             returns FALSE if the final few bytes of the string don't form a complete code
1125             point.
1126              
1127             =cut
1128             */
1129             #define is_utf8_fixed_width_buf_flags(s, len, flags) \
1130             is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1131              
1132             /*
1133              
1134             =for apidoc is_utf8_fixed_width_buf_loc_flags
1135              
1136             Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1137             failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1138             to the beginning of any partial character at the end of the buffer; if there is
1139             no partial character C<*ep> will contain C<s>+C<len>.
1140              
1141             See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1142              
1143             =cut
1144             */
1145              
1146             #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1147             is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1148              
1149             /*
1150              
1151             =for apidoc is_utf8_fixed_width_buf_loclen_flags
1152              
1153             Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1154             complete, valid characters found in the C<el> pointer.
1155              
1156             =cut
1157             */
1158              
1159             PERL_STATIC_INLINE bool
1160             S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1161             const STRLEN len,
1162             const U8 **ep,
1163             STRLEN *el,
1164             const U32 flags)
1165             {
1166             const U8 * maybe_partial;
1167              
1168             PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1169              
1170             if (! ep) {
1171             ep = &maybe_partial;
1172             }
1173              
1174             /* If it's entirely valid, return that; otherwise see if the only error is
1175             * that the final few bytes are for a partial character */
1176             return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1177             || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1178             }
1179              
1180             /* ------------------------------- perl.h ----------------------------- */
1181              
1182             /*
1183             =head1 Miscellaneous Functions
1184              
1185             =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1186              
1187             Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1188             If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1189              
1190             Return TRUE if the name is safe.
1191              
1192             Used by the C<IS_SAFE_SYSCALL()> macro.
1193              
1194             =cut
1195             */
1196              
1197             PERL_STATIC_INLINE bool
1198             S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1199             /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1200             * perl itself uses xce*() functions which accept 8-bit strings.
1201             */
1202              
1203             PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1204              
1205             if (len > 1) {
1206             char *null_at;
1207             if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1208             SETERRNO(ENOENT, LIB_INVARG);
1209             Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1210             "Invalid \\0 character in %s for %s: %s\\0%s",
1211             what, op_name, pv, null_at+1);
1212             return FALSE;
1213             }
1214             }
1215              
1216             return TRUE;
1217             }
1218              
1219             /*
1220              
1221             Return true if the supplied filename has a newline character
1222             immediately before the first (hopefully only) NUL.
1223              
1224             My original look at this incorrectly used the len from SvPV(), but
1225             that's incorrect, since we allow for a NUL in pv[len-1].
1226              
1227             So instead, strlen() and work from there.
1228              
1229             This allow for the user reading a filename, forgetting to chomp it,
1230             then calling:
1231              
1232             open my $foo, "$file\0";
1233              
1234             */
1235              
1236             #ifdef PERL_CORE
1237              
1238             PERL_STATIC_INLINE bool
1239             S_should_warn_nl(const char *pv) {
1240             STRLEN len;
1241              
1242             PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1243              
1244             len = strlen(pv);
1245              
1246             return len > 0 && pv[len-1] == '\n';
1247             }
1248              
1249             #endif
1250              
1251             /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1252              
1253             #define MAX_CHARSET_NAME_LENGTH 2
1254              
1255             PERL_STATIC_INLINE const char *
1256             get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1257             {
1258             /* Returns a string that corresponds to the name of the regex character set
1259             * given by 'flags', and *lenp is set the length of that string, which
1260             * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1261              
1262             *lenp = 1;
1263             switch (get_regex_charset(flags)) {
1264             case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1265             case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1266             case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1267             case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1268             case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1269             *lenp = 2;
1270             return ASCII_MORE_RESTRICT_PAT_MODS;
1271             }
1272             /* The NOT_REACHED; hides an assert() which has a rather complex
1273             * definition in perl.h. */
1274             NOT_REACHED; /* NOTREACHED */
1275             return "?"; /* Unknown */
1276             }
1277              
1278             /*
1279              
1280             Return false if any get magic is on the SV other than taint magic.
1281              
1282             */
1283              
1284             PERL_STATIC_INLINE bool
1285             S_sv_only_taint_gmagic(SV *sv) {
1286             MAGIC *mg = SvMAGIC(sv);
1287              
1288             PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1289              
1290             while (mg) {
1291             if (mg->mg_type != PERL_MAGIC_taint
1292             && !(mg->mg_flags & MGf_GSKIP)
1293             && mg->mg_virtual->svt_get) {
1294             return FALSE;
1295             }
1296             mg = mg->mg_moremagic;
1297             }
1298              
1299             return TRUE;
1300             }
1301              
1302             /* ------------------ cop.h ------------------------------------------- */
1303              
1304              
1305             /* Enter a block. Push a new base context and return its address. */
1306              
1307             PERL_STATIC_INLINE PERL_CONTEXT *
1308             S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1309             {
1310             PERL_CONTEXT * cx;
1311              
1312             PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1313              
1314             CXINC;
1315             cx = CX_CUR();
1316             cx->cx_type = type;
1317             cx->blk_gimme = gimme;
1318             cx->blk_oldsaveix = saveix;
1319             cx->blk_oldsp = (I32)(sp - PL_stack_base);
1320             cx->blk_oldcop = PL_curcop;
1321             cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
1322             cx->blk_oldscopesp = PL_scopestack_ix;
1323             cx->blk_oldpm = PL_curpm;
1324             cx->blk_old_tmpsfloor = PL_tmps_floor;
1325              
1326             PL_tmps_floor = PL_tmps_ix;
1327             CX_DEBUG(cx, "PUSH");
1328             return cx;
1329             }
1330              
1331              
1332             /* Exit a block (RETURN and LAST). */
1333              
1334             PERL_STATIC_INLINE void
1335             S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1336             {
1337             PERL_ARGS_ASSERT_CX_POPBLOCK;
1338              
1339             CX_DEBUG(cx, "POP");
1340             /* these 3 are common to cx_popblock and cx_topblock */
1341             PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1342             PL_scopestack_ix = cx->blk_oldscopesp;
1343             PL_curpm = cx->blk_oldpm;
1344              
1345             /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1346             * and leaves a CX entry lying around for repeated use, so
1347             * skip for multicall */ \
1348             assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1349             || PL_savestack_ix == cx->blk_oldsaveix);
1350             PL_curcop = cx->blk_oldcop;
1351             PL_tmps_floor = cx->blk_old_tmpsfloor;
1352             }
1353              
1354             /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1355             * Whereas cx_popblock() restores the state to the point just before
1356             * cx_pushblock() was called, cx_topblock() restores it to the point just
1357             * *after* cx_pushblock() was called. */
1358              
1359             PERL_STATIC_INLINE void
1360             S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1361             {
1362             PERL_ARGS_ASSERT_CX_TOPBLOCK;
1363              
1364             CX_DEBUG(cx, "TOP");
1365             /* these 3 are common to cx_popblock and cx_topblock */
1366             PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1367             PL_scopestack_ix = cx->blk_oldscopesp;
1368             PL_curpm = cx->blk_oldpm;
1369              
1370             PL_stack_sp = PL_stack_base + cx->blk_oldsp;
1371             }
1372              
1373              
1374             PERL_STATIC_INLINE void
1375             S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1376             {
1377             U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1378              
1379             PERL_ARGS_ASSERT_CX_PUSHSUB;
1380              
1381             PERL_DTRACE_PROBE_ENTRY(cv);
1382             cx->blk_sub.cv = cv;
1383             cx->blk_sub.olddepth = CvDEPTH(cv);
1384             cx->blk_sub.prevcomppad = PL_comppad;
1385             cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1386             cx->blk_sub.retop = retop;
1387             SvREFCNT_inc_simple_void_NN(cv);
1388             cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1389             }
1390              
1391              
1392             /* subsets of cx_popsub() */
1393              
1394             PERL_STATIC_INLINE void
1395             S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1396             {
1397             CV *cv;
1398              
1399             PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1400             assert(CxTYPE(cx) == CXt_SUB);
1401              
1402             PL_comppad = cx->blk_sub.prevcomppad;
1403             PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1404             cv = cx->blk_sub.cv;
1405             CvDEPTH(cv) = cx->blk_sub.olddepth;
1406             cx->blk_sub.cv = NULL;
1407             SvREFCNT_dec(cv);
1408             }
1409              
1410              
1411             /* handle the @_ part of leaving a sub */
1412              
1413             PERL_STATIC_INLINE void
1414             S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1415             {
1416             AV *av;
1417              
1418             PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1419             assert(CxTYPE(cx) == CXt_SUB);
1420             assert(AvARRAY(MUTABLE_AV(
1421             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1422             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1423              
1424             CX_POP_SAVEARRAY(cx);
1425             av = MUTABLE_AV(PAD_SVl(0));
1426             if (UNLIKELY(AvREAL(av)))
1427             /* abandon @_ if it got reified */
1428             clear_defarray(av, 0);
1429             else {
1430             CLEAR_ARGARRAY(av);
1431             }
1432             }
1433              
1434              
1435             PERL_STATIC_INLINE void
1436             S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1437             {
1438             PERL_ARGS_ASSERT_CX_POPSUB;
1439             assert(CxTYPE(cx) == CXt_SUB);
1440              
1441             PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1442              
1443             if (CxHASARGS(cx))
1444             cx_popsub_args(cx);
1445             cx_popsub_common(cx);
1446             }
1447              
1448              
1449             PERL_STATIC_INLINE void
1450             S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1451             {
1452             PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1453              
1454             cx->blk_format.cv = cv;
1455             cx->blk_format.retop = retop;
1456             cx->blk_format.gv = gv;
1457             cx->blk_format.dfoutgv = PL_defoutgv;
1458             cx->blk_format.prevcomppad = PL_comppad;
1459             cx->blk_u16 = 0;
1460              
1461             SvREFCNT_inc_simple_void_NN(cv);
1462             CvDEPTH(cv)++;
1463             SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1464             }
1465              
1466              
1467             PERL_STATIC_INLINE void
1468             S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1469             {
1470             CV *cv;
1471             GV *dfout;
1472              
1473             PERL_ARGS_ASSERT_CX_POPFORMAT;
1474             assert(CxTYPE(cx) == CXt_FORMAT);
1475              
1476             dfout = cx->blk_format.dfoutgv;
1477             setdefout(dfout);
1478             cx->blk_format.dfoutgv = NULL;
1479             SvREFCNT_dec_NN(dfout);
1480              
1481             PL_comppad = cx->blk_format.prevcomppad;
1482             PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1483             cv = cx->blk_format.cv;
1484             cx->blk_format.cv = NULL;
1485             --CvDEPTH(cv);
1486             SvREFCNT_dec_NN(cv);
1487             }
1488              
1489              
1490             PERL_STATIC_INLINE void
1491             S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1492             {
1493             PERL_ARGS_ASSERT_CX_PUSHEVAL;
1494              
1495             cx->blk_eval.retop = retop;
1496             cx->blk_eval.old_namesv = namesv;
1497             cx->blk_eval.old_eval_root = PL_eval_root;
1498             cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
1499             cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
1500             cx->blk_eval.cur_top_env = PL_top_env;
1501              
1502             assert(!(PL_in_eval & ~ 0x3F));
1503             assert(!(PL_op->op_type & ~0x1FF));
1504             cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1505             }
1506              
1507              
1508             PERL_STATIC_INLINE void
1509             S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1510             {
1511             SV *sv;
1512              
1513             PERL_ARGS_ASSERT_CX_POPEVAL;
1514             assert(CxTYPE(cx) == CXt_EVAL);
1515              
1516             PL_in_eval = CxOLD_IN_EVAL(cx);
1517             assert(!(PL_in_eval & 0xc0));
1518             PL_eval_root = cx->blk_eval.old_eval_root;
1519             sv = cx->blk_eval.cur_text;
1520             if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1521             cx->blk_eval.cur_text = NULL;
1522             SvREFCNT_dec_NN(sv);
1523             }
1524              
1525             sv = cx->blk_eval.old_namesv;
1526             if (sv) {
1527             cx->blk_eval.old_namesv = NULL;
1528             SvREFCNT_dec_NN(sv);
1529             }
1530             }
1531              
1532              
1533             /* push a plain loop, i.e.
1534             * { block }
1535             * while (cond) { block }
1536             * for (init;cond;continue) { block }
1537             * This loop can be last/redo'ed etc.
1538             */
1539              
1540             PERL_STATIC_INLINE void
1541             S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1542             {
1543             PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1544             cx->blk_loop.my_op = cLOOP;
1545             }
1546              
1547              
1548             /* push a true for loop, i.e.
1549             * for var (list) { block }
1550             */
1551              
1552             PERL_STATIC_INLINE void
1553             S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1554             {
1555             PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1556              
1557             /* this one line is common with cx_pushloop_plain */
1558             cx->blk_loop.my_op = cLOOP;
1559              
1560             cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1561             cx->blk_loop.itersave = itersave;
1562             #ifdef USE_ITHREADS
1563             cx->blk_loop.oldcomppad = PL_comppad;
1564             #endif
1565             }
1566              
1567              
1568             /* pop all loop types, including plain */
1569              
1570             PERL_STATIC_INLINE void
1571             S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1572             {
1573             PERL_ARGS_ASSERT_CX_POPLOOP;
1574              
1575             assert(CxTYPE_is_LOOP(cx));
1576             if ( CxTYPE(cx) == CXt_LOOP_ARY
1577             || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1578             {
1579             /* Free ary or cur. This assumes that state_u.ary.ary
1580             * aligns with state_u.lazysv.cur. See cx_dup() */
1581             SV *sv = cx->blk_loop.state_u.lazysv.cur;
1582             cx->blk_loop.state_u.lazysv.cur = NULL;
1583             SvREFCNT_dec_NN(sv);
1584             if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1585             sv = cx->blk_loop.state_u.lazysv.end;
1586             cx->blk_loop.state_u.lazysv.end = NULL;
1587             SvREFCNT_dec_NN(sv);
1588             }
1589             }
1590             if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1591             SV *cursv;
1592             SV **svp = (cx)->blk_loop.itervar_u.svp;
1593             if ((cx->cx_type & CXp_FOR_GV))
1594             svp = &GvSV((GV*)svp);
1595             cursv = *svp;
1596             *svp = cx->blk_loop.itersave;
1597             cx->blk_loop.itersave = NULL;
1598             SvREFCNT_dec(cursv);
1599             }
1600             }
1601              
1602              
1603             PERL_STATIC_INLINE void
1604             S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1605             {
1606             PERL_ARGS_ASSERT_CX_PUSHWHEN;
1607              
1608             cx->blk_givwhen.leave_op = cLOGOP->op_other;
1609             }
1610              
1611              
1612             PERL_STATIC_INLINE void
1613             S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1614             {
1615             PERL_ARGS_ASSERT_CX_POPWHEN;
1616             assert(CxTYPE(cx) == CXt_WHEN);
1617              
1618             PERL_UNUSED_ARG(cx);
1619             PERL_UNUSED_CONTEXT;
1620             /* currently NOOP */
1621             }
1622              
1623              
1624             PERL_STATIC_INLINE void
1625             S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1626             {
1627             PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1628              
1629             cx->blk_givwhen.leave_op = cLOGOP->op_other;
1630             cx->blk_givwhen.defsv_save = orig_defsv;
1631             }
1632              
1633              
1634             PERL_STATIC_INLINE void
1635             S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1636             {
1637             SV *sv;
1638              
1639             PERL_ARGS_ASSERT_CX_POPGIVEN;
1640             assert(CxTYPE(cx) == CXt_GIVEN);
1641              
1642             sv = GvSV(PL_defgv);
1643             GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1644             cx->blk_givwhen.defsv_save = NULL;
1645             SvREFCNT_dec(sv);
1646             }
1647              
1648             /* ------------------ util.h ------------------------------------------- */
1649              
1650             /*
1651             =head1 Miscellaneous Functions
1652              
1653             =for apidoc foldEQ
1654              
1655             Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1656             same
1657             case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1658             match themselves and their opposite case counterparts. Non-cased and non-ASCII
1659             range bytes match only themselves.
1660              
1661             =cut
1662             */
1663              
1664             PERL_STATIC_INLINE I32
1665             Perl_foldEQ(const char *s1, const char *s2, I32 len)
1666             {
1667             const U8 *a = (const U8 *)s1;
1668             const U8 *b = (const U8 *)s2;
1669              
1670             PERL_ARGS_ASSERT_FOLDEQ;
1671              
1672             assert(len >= 0);
1673              
1674             while (len--) {
1675             if (*a != *b && *a != PL_fold[*b])
1676             return 0;
1677             a++,b++;
1678             }
1679             return 1;
1680             }
1681              
1682             PERL_STATIC_INLINE I32
1683             Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1684             {
1685             /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1686             * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1687             * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1688             * does it check that the strings each have at least 'len' characters */
1689              
1690             const U8 *a = (const U8 *)s1;
1691             const U8 *b = (const U8 *)s2;
1692              
1693             PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1694              
1695             assert(len >= 0);
1696              
1697             while (len--) {
1698             if (*a != *b && *a != PL_fold_latin1[*b]) {
1699             return 0;
1700             }
1701             a++, b++;
1702             }
1703             return 1;
1704             }
1705              
1706             /*
1707             =for apidoc foldEQ_locale
1708              
1709             Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1710             same case-insensitively in the current locale; false otherwise.
1711              
1712             =cut
1713             */
1714              
1715             PERL_STATIC_INLINE I32
1716             Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1717             {
1718             dVAR;
1719             const U8 *a = (const U8 *)s1;
1720             const U8 *b = (const U8 *)s2;
1721              
1722             PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1723              
1724             assert(len >= 0);
1725              
1726             while (len--) {
1727             if (*a != *b && *a != PL_fold_locale[*b])
1728             return 0;
1729             a++,b++;
1730             }
1731             return 1;
1732             }
1733              
1734             /*
1735             * ex: set ts=8 sts=4 sw=4 et:
1736             */