File Coverage

/usr/local/lib/perl5/5.26.1/x86_64-linux/CORE/inline.h
Criterion Covered Total %
statement 6 8 75.0
branch 1 2 50.0
condition n/a
subroutine n/a
pod n/a
total 7 10 70.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 22628           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 22628           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 763           S_SvREFCNT_inc(SV *sv)
164             {
165 763 50         if (LIKELY(sv != NULL))
166 763           SvREFCNT(sv)++;
167 763           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             */
1737