This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(perl #129000) create a safer utf8_hop()
[perl5.git] / inline.h
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 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     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 S_croak_memory_wrap(void)
250 {
251     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     return (U8 *)s;
920 }
921
922 /*
923 =for apidoc utf8_hop_forward
924
925 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
926 forward.
927
928 C<off> must be non-negative.
929
930 C<s> must be before or equal to C<end>.
931
932 When moving forward it will not move beyond C<end>.
933
934 Will not exceed this limit even if the string is not valid "UTF-8".
935
936 =cut
937 */
938
939 PERL_STATIC_INLINE U8 *
940 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
941 {
942     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
943
944     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
945      * the bitops (especially ~) can create illegal UTF-8.
946      * In other words: in Perl UTF-8 is not just for Unicode. */
947
948     assert(s <= end);
949     assert(off >= 0);
950
951     while (off--) {
952         STRLEN skip = UTF8SKIP(s);
953         if ((STRLEN)(end - s) <= skip)
954             return (U8 *)end;
955         s += skip;
956     }
957
958     return (U8 *)s;
959 }
960
961 /*
962 =for apidoc utf8_hop_back
963
964 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
965 backward.
966
967 C<off> must be non-positive.
968
969 C<s> must be after or equal to C<start>.
970
971 When moving backward it will not move before C<start>.
972
973 Will not exceed this limit even if the string is not valid "UTF-8".
974
975 =cut
976 */
977
978 PERL_STATIC_INLINE U8 *
979 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
980 {
981     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
982
983     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
984      * the bitops (especially ~) can create illegal UTF-8.
985      * In other words: in Perl UTF-8 is not just for Unicode. */
986
987     assert(start <= s);
988     assert(off <= 0);
989
990     while (off++ && s > start) {
991         s--;
992         while (UTF8_IS_CONTINUATION(*s) && s > start)
993             s--;
994     }
995     
996     return (U8 *)s;
997 }
998
999 /*
1000 =for apidoc utf8_hop_safe
1001
1002 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1003 either forward or backward.
1004
1005 When moving backward it will not move before C<start>.
1006
1007 When moving forward it will not move beyond C<end>.
1008
1009 Will not exceed those limits even if the string is not valid "UTF-8".
1010
1011 =cut
1012 */
1013
1014 PERL_STATIC_INLINE U8 *
1015 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1016 {
1017     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1018
1019     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1020      * the bitops (especially ~) can create illegal UTF-8.
1021      * In other words: in Perl UTF-8 is not just for Unicode. */
1022
1023     assert(start <= s && s <= end);
1024
1025     if (off >= 0) {
1026         return utf8_hop_forward(s, off, end);
1027     }
1028     else {
1029         return utf8_hop_back(s, off, start);
1030     }
1031 }
1032
1033 /*
1034
1035 =for apidoc is_utf8_valid_partial_char
1036
1037 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1038 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1039 points.  Otherwise, it returns 1 if there exists at least one non-empty
1040 sequence of bytes that when appended to sequence C<s>, starting at position
1041 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1042 otherwise returns 0.
1043
1044 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1045 point.
1046
1047 This is useful when a fixed-length buffer is being tested for being well-formed
1048 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1049 it is split somewhere in the middle of the final code point's UTF-8
1050 representation.  (Presumably when the buffer is refreshed with the next chunk
1051 of data, the new first bytes will complete the partial code point.)   This
1052 function is used to verify that the final bytes in the current buffer are in
1053 fact the legal beginning of some code point, so that if they aren't, the
1054 failure can be signalled without having to wait for the next read.
1055
1056 =cut
1057 */
1058 #define is_utf8_valid_partial_char(s, e)                                    \
1059                                 is_utf8_valid_partial_char_flags(s, e, 0)
1060
1061 /*
1062
1063 =for apidoc is_utf8_valid_partial_char_flags
1064
1065 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1066 or not the input is a valid UTF-8 encoded partial character, but it takes an
1067 extra parameter, C<flags>, which can further restrict which code points are
1068 considered valid.
1069
1070 If C<flags> is 0, this behaves identically to
1071 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1072 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1073 there is any sequence of bytes that can complete the input partial character in
1074 such a way that a non-prohibited character is formed, the function returns
1075 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1076 partial character input.  But many  of the other possible excluded types can be
1077 determined from just the first one or two bytes.
1078
1079 =cut
1080  */
1081
1082 PERL_STATIC_INLINE bool
1083 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1084 {
1085     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1086
1087     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1088                           |UTF8_DISALLOW_ABOVE_31_BIT)));
1089
1090     if (s >= e || s + UTF8SKIP(s) <= e) {
1091         return FALSE;
1092     }
1093
1094     return cBOOL(_is_utf8_char_helper(s, e, flags));
1095 }
1096
1097 /*
1098
1099 =for apidoc is_utf8_fixed_width_buf_flags
1100
1101 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1102 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1103 otherwise it returns FALSE.
1104
1105 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1106 without restriction.  If the final few bytes of the buffer do not form a
1107 complete code point, this will return TRUE anyway, provided that
1108 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1109
1110 If C<flags> in non-zero, it can be any combination of the
1111 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1112 same meanings.
1113
1114 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1115 returns FALSE if the final few bytes of the string don't form a complete code
1116 point.
1117
1118 =cut
1119  */
1120 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1121                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1122
1123 /*
1124
1125 =for apidoc is_utf8_fixed_width_buf_loc_flags
1126
1127 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1128 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1129 to the beginning of any partial character at the end of the buffer; if there is
1130 no partial character C<*ep> will contain C<s>+C<len>.
1131
1132 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1133
1134 =cut
1135 */
1136
1137 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1138                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1139
1140 /*
1141
1142 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1143
1144 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1145 complete, valid characters found in the C<el> pointer.
1146
1147 =cut
1148 */
1149
1150 PERL_STATIC_INLINE bool
1151 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1152                                        const STRLEN len,
1153                                        const U8 **ep,
1154                                        STRLEN *el,
1155                                        const U32 flags)
1156 {
1157     const U8 * maybe_partial;
1158
1159     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1160
1161     if (! ep) {
1162         ep  = &maybe_partial;
1163     }
1164
1165     /* If it's entirely valid, return that; otherwise see if the only error is
1166      * that the final few bytes are for a partial character */
1167     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1168            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1169 }
1170
1171 /* ------------------------------- perl.h ----------------------------- */
1172
1173 /*
1174 =head1 Miscellaneous Functions
1175
1176 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1177
1178 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1179 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1180
1181 Return TRUE if the name is safe.
1182
1183 Used by the C<IS_SAFE_SYSCALL()> macro.
1184
1185 =cut
1186 */
1187
1188 PERL_STATIC_INLINE bool
1189 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1190     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1191      * perl itself uses xce*() functions which accept 8-bit strings.
1192      */
1193
1194     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1195
1196     if (len > 1) {
1197         char *null_at;
1198         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1199                 SETERRNO(ENOENT, LIB_INVARG);
1200                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1201                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1202                                    what, op_name, pv, null_at+1);
1203                 return FALSE;
1204         }
1205     }
1206
1207     return TRUE;
1208 }
1209
1210 /*
1211
1212 Return true if the supplied filename has a newline character
1213 immediately before the first (hopefully only) NUL.
1214
1215 My original look at this incorrectly used the len from SvPV(), but
1216 that's incorrect, since we allow for a NUL in pv[len-1].
1217
1218 So instead, strlen() and work from there.
1219
1220 This allow for the user reading a filename, forgetting to chomp it,
1221 then calling:
1222
1223   open my $foo, "$file\0";
1224
1225 */
1226
1227 #ifdef PERL_CORE
1228
1229 PERL_STATIC_INLINE bool
1230 S_should_warn_nl(const char *pv) {
1231     STRLEN len;
1232
1233     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1234
1235     len = strlen(pv);
1236
1237     return len > 0 && pv[len-1] == '\n';
1238 }
1239
1240 #endif
1241
1242 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1243
1244 #define MAX_CHARSET_NAME_LENGTH 2
1245
1246 PERL_STATIC_INLINE const char *
1247 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1248 {
1249     /* Returns a string that corresponds to the name of the regex character set
1250      * given by 'flags', and *lenp is set the length of that string, which
1251      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1252
1253     *lenp = 1;
1254     switch (get_regex_charset(flags)) {
1255         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1256         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
1257         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1258         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1259         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1260             *lenp = 2;
1261             return ASCII_MORE_RESTRICT_PAT_MODS;
1262     }
1263     /* The NOT_REACHED; hides an assert() which has a rather complex
1264      * definition in perl.h. */
1265     NOT_REACHED; /* NOTREACHED */
1266     return "?";     /* Unknown */
1267 }
1268
1269 /*
1270
1271 Return false if any get magic is on the SV other than taint magic.
1272
1273 */
1274
1275 PERL_STATIC_INLINE bool
1276 S_sv_only_taint_gmagic(SV *sv) {
1277     MAGIC *mg = SvMAGIC(sv);
1278
1279     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1280
1281     while (mg) {
1282         if (mg->mg_type != PERL_MAGIC_taint
1283             && !(mg->mg_flags & MGf_GSKIP)
1284             && mg->mg_virtual->svt_get) {
1285             return FALSE;
1286         }
1287         mg = mg->mg_moremagic;
1288     }
1289
1290     return TRUE;
1291 }
1292
1293 /* ------------------ cop.h ------------------------------------------- */
1294
1295
1296 /* Enter a block. Push a new base context and return its address. */
1297
1298 PERL_STATIC_INLINE PERL_CONTEXT *
1299 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1300 {
1301     PERL_CONTEXT * cx;
1302
1303     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1304
1305     CXINC;
1306     cx = CX_CUR();
1307     cx->cx_type        = type;
1308     cx->blk_gimme      = gimme;
1309     cx->blk_oldsaveix  = saveix;
1310     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
1311     cx->blk_oldcop     = PL_curcop;
1312     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
1313     cx->blk_oldscopesp = PL_scopestack_ix;
1314     cx->blk_oldpm      = PL_curpm;
1315     cx->blk_old_tmpsfloor = PL_tmps_floor;
1316
1317     PL_tmps_floor        = PL_tmps_ix;
1318     CX_DEBUG(cx, "PUSH");
1319     return cx;
1320 }
1321
1322
1323 /* Exit a block (RETURN and LAST). */
1324
1325 PERL_STATIC_INLINE void
1326 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1327 {
1328     PERL_ARGS_ASSERT_CX_POPBLOCK;
1329
1330     CX_DEBUG(cx, "POP");
1331     /* these 3 are common to cx_popblock and cx_topblock */
1332     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1333     PL_scopestack_ix = cx->blk_oldscopesp;
1334     PL_curpm         = cx->blk_oldpm;
1335
1336     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1337      * and leaves a CX entry lying around for repeated use, so
1338      * skip for multicall */                  \
1339     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1340             || PL_savestack_ix == cx->blk_oldsaveix);
1341     PL_curcop     = cx->blk_oldcop;
1342     PL_tmps_floor = cx->blk_old_tmpsfloor;
1343 }
1344
1345 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1346  * Whereas cx_popblock() restores the state to the point just before
1347  * cx_pushblock() was called,  cx_topblock() restores it to the point just
1348  * *after* cx_pushblock() was called. */
1349
1350 PERL_STATIC_INLINE void
1351 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1352 {
1353     PERL_ARGS_ASSERT_CX_TOPBLOCK;
1354
1355     CX_DEBUG(cx, "TOP");
1356     /* these 3 are common to cx_popblock and cx_topblock */
1357     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1358     PL_scopestack_ix = cx->blk_oldscopesp;
1359     PL_curpm         = cx->blk_oldpm;
1360
1361     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
1362 }
1363
1364
1365 PERL_STATIC_INLINE void
1366 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1367 {
1368     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1369
1370     PERL_ARGS_ASSERT_CX_PUSHSUB;
1371
1372     PERL_DTRACE_PROBE_ENTRY(cv);
1373     cx->blk_sub.cv = cv;
1374     cx->blk_sub.olddepth = CvDEPTH(cv);
1375     cx->blk_sub.prevcomppad = PL_comppad;
1376     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1377     cx->blk_sub.retop = retop;
1378     SvREFCNT_inc_simple_void_NN(cv);
1379     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1380 }
1381
1382
1383 /* subsets of cx_popsub() */
1384
1385 PERL_STATIC_INLINE void
1386 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1387 {
1388     CV *cv;
1389
1390     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1391     assert(CxTYPE(cx) == CXt_SUB);
1392
1393     PL_comppad = cx->blk_sub.prevcomppad;
1394     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1395     cv = cx->blk_sub.cv;
1396     CvDEPTH(cv) = cx->blk_sub.olddepth;
1397     cx->blk_sub.cv = NULL;
1398     SvREFCNT_dec(cv);
1399 }
1400
1401
1402 /* handle the @_ part of leaving a sub */
1403
1404 PERL_STATIC_INLINE void
1405 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1406 {
1407     AV *av;
1408
1409     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1410     assert(CxTYPE(cx) == CXt_SUB);
1411     assert(AvARRAY(MUTABLE_AV(
1412         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1413                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1414
1415     CX_POP_SAVEARRAY(cx);
1416     av = MUTABLE_AV(PAD_SVl(0));
1417     if (UNLIKELY(AvREAL(av)))
1418         /* abandon @_ if it got reified */
1419         clear_defarray(av, 0);
1420     else {
1421         CLEAR_ARGARRAY(av);
1422     }
1423 }
1424
1425
1426 PERL_STATIC_INLINE void
1427 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1428 {
1429     PERL_ARGS_ASSERT_CX_POPSUB;
1430     assert(CxTYPE(cx) == CXt_SUB);
1431
1432     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1433
1434     if (CxHASARGS(cx))
1435         cx_popsub_args(cx);
1436     cx_popsub_common(cx);
1437 }
1438
1439
1440 PERL_STATIC_INLINE void
1441 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1442 {
1443     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1444
1445     cx->blk_format.cv          = cv;
1446     cx->blk_format.retop       = retop;
1447     cx->blk_format.gv          = gv;
1448     cx->blk_format.dfoutgv     = PL_defoutgv;
1449     cx->blk_format.prevcomppad = PL_comppad;
1450     cx->blk_u16                = 0;
1451
1452     SvREFCNT_inc_simple_void_NN(cv);
1453     CvDEPTH(cv)++;
1454     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1455 }
1456
1457
1458 PERL_STATIC_INLINE void
1459 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1460 {
1461     CV *cv;
1462     GV *dfout;
1463
1464     PERL_ARGS_ASSERT_CX_POPFORMAT;
1465     assert(CxTYPE(cx) == CXt_FORMAT);
1466
1467     dfout = cx->blk_format.dfoutgv;
1468     setdefout(dfout);
1469     cx->blk_format.dfoutgv = NULL;
1470     SvREFCNT_dec_NN(dfout);
1471
1472     PL_comppad = cx->blk_format.prevcomppad;
1473     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1474     cv = cx->blk_format.cv;
1475     cx->blk_format.cv = NULL;
1476     --CvDEPTH(cv);
1477     SvREFCNT_dec_NN(cv);
1478 }
1479
1480
1481 PERL_STATIC_INLINE void
1482 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1483 {
1484     PERL_ARGS_ASSERT_CX_PUSHEVAL;
1485
1486     cx->blk_eval.retop         = retop;
1487     cx->blk_eval.old_namesv    = namesv;
1488     cx->blk_eval.old_eval_root = PL_eval_root;
1489     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
1490     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
1491     cx->blk_eval.cur_top_env   = PL_top_env;
1492
1493     assert(!(PL_in_eval     & ~ 0x7F));
1494     assert(!(PL_op->op_type & ~0x1FF));
1495     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
1496 }
1497
1498
1499 PERL_STATIC_INLINE void
1500 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1501 {
1502     SV *sv;
1503
1504     PERL_ARGS_ASSERT_CX_POPEVAL;
1505     assert(CxTYPE(cx) == CXt_EVAL);
1506
1507     PL_in_eval = CxOLD_IN_EVAL(cx);
1508     PL_eval_root = cx->blk_eval.old_eval_root;
1509     sv = cx->blk_eval.cur_text;
1510     if (sv && SvSCREAM(sv)) {
1511         cx->blk_eval.cur_text = NULL;
1512         SvREFCNT_dec_NN(sv);
1513     }
1514
1515     sv = cx->blk_eval.old_namesv;
1516     if (sv) {
1517         cx->blk_eval.old_namesv = NULL;
1518         SvREFCNT_dec_NN(sv);
1519     }
1520 }
1521
1522
1523 /* push a plain loop, i.e.
1524  *     { block }
1525  *     while (cond) { block }
1526  *     for (init;cond;continue) { block }
1527  * This loop can be last/redo'ed etc.
1528  */
1529
1530 PERL_STATIC_INLINE void
1531 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1532 {
1533     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1534     cx->blk_loop.my_op = cLOOP;
1535 }
1536
1537
1538 /* push a true for loop, i.e.
1539  *     for var (list) { block }
1540  */
1541
1542 PERL_STATIC_INLINE void
1543 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1544 {
1545     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1546
1547     /* this one line is common with cx_pushloop_plain */
1548     cx->blk_loop.my_op = cLOOP;
1549
1550     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1551     cx->blk_loop.itersave      = itersave;
1552 #ifdef USE_ITHREADS
1553     cx->blk_loop.oldcomppad = PL_comppad;
1554 #endif
1555 }
1556
1557
1558 /* pop all loop types, including plain */
1559
1560 PERL_STATIC_INLINE void
1561 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1562 {
1563     PERL_ARGS_ASSERT_CX_POPLOOP;
1564
1565     assert(CxTYPE_is_LOOP(cx));
1566     if (  CxTYPE(cx) == CXt_LOOP_ARY
1567        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1568     {
1569         /* Free ary or cur. This assumes that state_u.ary.ary
1570          * aligns with state_u.lazysv.cur. See cx_dup() */
1571         SV *sv = cx->blk_loop.state_u.lazysv.cur;
1572         cx->blk_loop.state_u.lazysv.cur = NULL;
1573         SvREFCNT_dec_NN(sv);
1574         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1575             sv = cx->blk_loop.state_u.lazysv.end;
1576             cx->blk_loop.state_u.lazysv.end = NULL;
1577             SvREFCNT_dec_NN(sv);
1578         }
1579     }
1580     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1581         SV *cursv;
1582         SV **svp = (cx)->blk_loop.itervar_u.svp;
1583         if ((cx->cx_type & CXp_FOR_GV))
1584             svp = &GvSV((GV*)svp);
1585         cursv = *svp;
1586         *svp = cx->blk_loop.itersave;
1587         cx->blk_loop.itersave = NULL;
1588         SvREFCNT_dec(cursv);
1589     }
1590 }
1591
1592
1593 PERL_STATIC_INLINE void
1594 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1595 {
1596     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1597
1598     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1599 }
1600
1601
1602 PERL_STATIC_INLINE void
1603 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1604 {
1605     PERL_ARGS_ASSERT_CX_POPWHEN;
1606     assert(CxTYPE(cx) == CXt_WHEN);
1607
1608     PERL_UNUSED_ARG(cx);
1609     PERL_UNUSED_CONTEXT;
1610     /* currently NOOP */
1611 }
1612
1613
1614 PERL_STATIC_INLINE void
1615 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1616 {
1617     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1618
1619     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1620     cx->blk_givwhen.defsv_save = orig_defsv;
1621 }
1622
1623
1624 PERL_STATIC_INLINE void
1625 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1626 {
1627     SV *sv;
1628
1629     PERL_ARGS_ASSERT_CX_POPGIVEN;
1630     assert(CxTYPE(cx) == CXt_GIVEN);
1631
1632     sv = GvSV(PL_defgv);
1633     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1634     cx->blk_givwhen.defsv_save = NULL;
1635     SvREFCNT_dec(sv);
1636 }
1637
1638 /*
1639  * ex: set ts=8 sts=4 sw=4 et:
1640  */