This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Reword description of is_utf8_valid_partial_char
[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 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     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 iff 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).  That is, if they are UTF-8 invariant.  On ASCII-ish
329 machines, all the ASCII characters and only the ASCII characters fit this
330 definition.  On EBCDIC machines, the ASCII-range characters are invariant, but
331 so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
332 EBCDIC).
333
334 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
335 use this option, that C<s> can't have embedded C<NUL> characters and has to
336 have a terminating C<NUL> byte).
337
338 See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
339 L</is_utf8_string_loc>().
340
341 =cut
342 */
343
344 PERL_STATIC_INLINE bool
345 S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
346 {
347     const U8* const send = s + (len ? len : strlen((const char *)s));
348     const U8* x = s;
349
350     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
351
352     for (; x < send; ++x) {
353         if (!UTF8_IS_INVARIANT(*x))
354             return FALSE;
355     }
356
357     return TRUE;
358 }
359
360 /*
361 =for apidoc is_utf8_string
362
363 Returns true if the first C<len> bytes of string C<s> form a valid
364 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated
365 using C<strlen(s)> (which means if you use this option, that C<s> can't have
366 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
367 that all characters being ASCII constitute 'a valid UTF-8 string'.
368
369 See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
370 L</is_utf8_string_loc>().
371
372 =cut
373 */
374
375 PERL_STATIC_INLINE bool
376 Perl_is_utf8_string(const U8 *s, STRLEN len)
377 {
378     /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
379      * Be aware of possible changes to that */
380
381     const U8* const send = s + (len ? len : strlen((const char *)s));
382     const U8* x = s;
383
384     PERL_ARGS_ASSERT_IS_UTF8_STRING;
385
386     while (x < send) {
387         STRLEN len = isUTF8_CHAR(x, send);
388         if (UNLIKELY(! len)) {
389             return FALSE;
390         }
391         x += len;
392     }
393
394     return TRUE;
395 }
396
397 /*
398 Implemented as a macro in utf8.h
399
400 =for apidoc is_utf8_string_loc
401
402 Like L</is_utf8_string> but stores the location of the failure (in the
403 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
404 "utf8ness success") in the C<ep>.
405
406 See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
407
408 =for apidoc is_utf8_string_loclen
409
410 Like L</is_utf8_string>() but stores the location of the failure (in the
411 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
412 "utf8ness success") in the C<ep>, and the number of UTF-8
413 encoded characters in the C<el>.
414
415 See also L</is_utf8_string_loc>() and L</is_utf8_string>().
416
417 =cut
418 */
419
420 PERL_STATIC_INLINE bool
421 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
422 {
423     const U8* const send = s + (len ? len : strlen((const char *)s));
424     const U8* x = s;
425     STRLEN outlen = 0;
426
427     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
428
429     while (x < send) {
430         STRLEN len = isUTF8_CHAR(x, send);
431         if (UNLIKELY(! len)) {
432             break;
433         }
434         x += len;
435         outlen++;
436     }
437
438     if (el)
439         *el = outlen;
440
441     if (ep) {
442         *ep = x;
443     }
444
445     return (x == send);
446 }
447
448 /*
449 =for apidoc utf8_distance
450
451 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
452 and C<b>.
453
454 WARNING: use only if you *know* that the pointers point inside the
455 same UTF-8 buffer.
456
457 =cut
458 */
459
460 PERL_STATIC_INLINE IV
461 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
462 {
463     PERL_ARGS_ASSERT_UTF8_DISTANCE;
464
465     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
466 }
467
468 /*
469 =for apidoc utf8_hop
470
471 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
472 forward or backward.
473
474 WARNING: do not use the following unless you *know* C<off> is within
475 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
476 on the first byte of character or just after the last byte of a character.
477
478 =cut
479 */
480
481 PERL_STATIC_INLINE U8 *
482 Perl_utf8_hop(const U8 *s, SSize_t off)
483 {
484     PERL_ARGS_ASSERT_UTF8_HOP;
485
486     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
487      * the bitops (especially ~) can create illegal UTF-8.
488      * In other words: in Perl UTF-8 is not just for Unicode. */
489
490     if (off >= 0) {
491         while (off--)
492             s += UTF8SKIP(s);
493     }
494     else {
495         while (off++) {
496             s--;
497             while (UTF8_IS_CONTINUATION(*s))
498                 s--;
499         }
500     }
501     return (U8 *)s;
502 }
503
504 /*
505
506 =for apidoc is_utf8_valid_partial_char
507
508 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
509 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
510 points.  Otherwise, it returns 1 if there exists at least one non-empty
511 sequence of bytes that when appended to sequence C<s>, starting at position
512 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
513 otherwise returns 0.
514
515 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
516 point.
517
518 This is useful when a fixed-length buffer is being tested for being well-formed
519 UTF-8, but the final few bytes in it don't comprise a full character; that is,
520 it is split somewhere in the middle of the final code point's UTF-8
521 representation.  (Presumably when the buffer is refreshed with the next chunk
522 of data, the new first bytes will complete the partial code point.)   This
523 function is used to verify that the final bytes in the current buffer are in
524 fact the legal beginning of some code point, so that if they aren't, the
525 failure can be signalled without having to wait for the next read.
526
527 =cut
528 */
529 PERL_STATIC_INLINE bool
530 S_is_utf8_valid_partial_char(const U8 * const s, const U8 * const e)
531 {
532
533     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR;
534
535     if (s >= e || s + UTF8SKIP(s) <= e) {
536         return FALSE;
537     }
538
539     return cBOOL(_is_utf8_char_helper(s, e, 0));
540 }
541
542 /* ------------------------------- perl.h ----------------------------- */
543
544 /*
545 =head1 Miscellaneous Functions
546
547 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
548
549 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
550 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
551
552 Return TRUE if the name is safe.
553
554 Used by the C<IS_SAFE_SYSCALL()> macro.
555
556 =cut
557 */
558
559 PERL_STATIC_INLINE bool
560 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
561     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
562      * perl itself uses xce*() functions which accept 8-bit strings.
563      */
564
565     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
566
567     if (len > 1) {
568         char *null_at;
569         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
570                 SETERRNO(ENOENT, LIB_INVARG);
571                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
572                                    "Invalid \\0 character in %s for %s: %s\\0%s",
573                                    what, op_name, pv, null_at+1);
574                 return FALSE;
575         }
576     }
577
578     return TRUE;
579 }
580
581 /*
582
583 Return true if the supplied filename has a newline character
584 immediately before the first (hopefully only) NUL.
585
586 My original look at this incorrectly used the len from SvPV(), but
587 that's incorrect, since we allow for a NUL in pv[len-1].
588
589 So instead, strlen() and work from there.
590
591 This allow for the user reading a filename, forgetting to chomp it,
592 then calling:
593
594   open my $foo, "$file\0";
595
596 */
597
598 #ifdef PERL_CORE
599
600 PERL_STATIC_INLINE bool
601 S_should_warn_nl(const char *pv) {
602     STRLEN len;
603
604     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
605
606     len = strlen(pv);
607
608     return len > 0 && pv[len-1] == '\n';
609 }
610
611 #endif
612
613 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
614
615 #define MAX_CHARSET_NAME_LENGTH 2
616
617 PERL_STATIC_INLINE const char *
618 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
619 {
620     /* Returns a string that corresponds to the name of the regex character set
621      * given by 'flags', and *lenp is set the length of that string, which
622      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
623
624     *lenp = 1;
625     switch (get_regex_charset(flags)) {
626         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
627         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
628         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
629         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
630         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
631             *lenp = 2;
632             return ASCII_MORE_RESTRICT_PAT_MODS;
633     }
634     /* The NOT_REACHED; hides an assert() which has a rather complex
635      * definition in perl.h. */
636     NOT_REACHED; /* NOTREACHED */
637     return "?";     /* Unknown */
638 }
639
640 /*
641
642 Return false if any get magic is on the SV other than taint magic.
643
644 */
645
646 PERL_STATIC_INLINE bool
647 S_sv_only_taint_gmagic(SV *sv) {
648     MAGIC *mg = SvMAGIC(sv);
649
650     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
651
652     while (mg) {
653         if (mg->mg_type != PERL_MAGIC_taint
654             && !(mg->mg_flags & MGf_GSKIP)
655             && mg->mg_virtual->svt_get) {
656             return FALSE;
657         }
658         mg = mg->mg_moremagic;
659     }
660
661     return TRUE;
662 }
663
664 /* ------------------ cop.h ------------------------------------------- */
665
666
667 /* Enter a block. Push a new base context and return its address. */
668
669 PERL_STATIC_INLINE PERL_CONTEXT *
670 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
671 {
672     PERL_CONTEXT * cx;
673
674     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
675
676     CXINC;
677     cx = CX_CUR();
678     cx->cx_type        = type;
679     cx->blk_gimme      = gimme;
680     cx->blk_oldsaveix  = saveix;
681     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
682     cx->blk_oldcop     = PL_curcop;
683     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
684     cx->blk_oldscopesp = PL_scopestack_ix;
685     cx->blk_oldpm      = PL_curpm;
686     cx->blk_old_tmpsfloor = PL_tmps_floor;
687
688     PL_tmps_floor        = PL_tmps_ix;
689     CX_DEBUG(cx, "PUSH");
690     return cx;
691 }
692
693
694 /* Exit a block (RETURN and LAST). */
695
696 PERL_STATIC_INLINE void
697 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
698 {
699     PERL_ARGS_ASSERT_CX_POPBLOCK;
700
701     CX_DEBUG(cx, "POP");
702     /* these 3 are common to cx_popblock and cx_topblock */
703     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
704     PL_scopestack_ix = cx->blk_oldscopesp;
705     PL_curpm         = cx->blk_oldpm;
706
707     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
708      * and leaves a CX entry lying around for repeated use, so
709      * skip for multicall */                  \
710     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
711             || PL_savestack_ix == cx->blk_oldsaveix);
712     PL_curcop     = cx->blk_oldcop;
713     PL_tmps_floor = cx->blk_old_tmpsfloor;
714 }
715
716 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
717  * Whereas cx_popblock() restores the state to the point just before
718  * cx_pushblock() was called,  cx_topblock() restores it to the point just
719  * *after* cx_pushblock() was called. */
720
721 PERL_STATIC_INLINE void
722 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
723 {
724     PERL_ARGS_ASSERT_CX_TOPBLOCK;
725
726     CX_DEBUG(cx, "TOP");
727     /* these 3 are common to cx_popblock and cx_topblock */
728     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
729     PL_scopestack_ix = cx->blk_oldscopesp;
730     PL_curpm         = cx->blk_oldpm;
731
732     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
733 }
734
735
736 PERL_STATIC_INLINE void
737 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
738 {
739     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
740
741     PERL_ARGS_ASSERT_CX_PUSHSUB;
742
743     PERL_DTRACE_PROBE_ENTRY(cv);
744     cx->blk_sub.cv = cv;
745     cx->blk_sub.olddepth = CvDEPTH(cv);
746     cx->blk_sub.prevcomppad = PL_comppad;
747     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
748     cx->blk_sub.retop = retop;
749     SvREFCNT_inc_simple_void_NN(cv);
750     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
751 }
752
753
754 /* subsets of cx_popsub() */
755
756 PERL_STATIC_INLINE void
757 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
758 {
759     CV *cv;
760
761     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
762     assert(CxTYPE(cx) == CXt_SUB);
763
764     PL_comppad = cx->blk_sub.prevcomppad;
765     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
766     cv = cx->blk_sub.cv;
767     CvDEPTH(cv) = cx->blk_sub.olddepth;
768     cx->blk_sub.cv = NULL;
769     SvREFCNT_dec(cv);
770 }
771
772
773 /* handle the @_ part of leaving a sub */
774
775 PERL_STATIC_INLINE void
776 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
777 {
778     AV *av;
779
780     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
781     assert(CxTYPE(cx) == CXt_SUB);
782     assert(AvARRAY(MUTABLE_AV(
783         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
784                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
785
786     CX_POP_SAVEARRAY(cx);
787     av = MUTABLE_AV(PAD_SVl(0));
788     if (UNLIKELY(AvREAL(av)))
789         /* abandon @_ if it got reified */
790         clear_defarray(av, 0);
791     else {
792         CLEAR_ARGARRAY(av);
793     }
794 }
795
796
797 PERL_STATIC_INLINE void
798 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
799 {
800     PERL_ARGS_ASSERT_CX_POPSUB;
801     assert(CxTYPE(cx) == CXt_SUB);
802
803     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
804
805     if (CxHASARGS(cx))
806         cx_popsub_args(cx);
807     cx_popsub_common(cx);
808 }
809
810
811 PERL_STATIC_INLINE void
812 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
813 {
814     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
815
816     cx->blk_format.cv          = cv;
817     cx->blk_format.retop       = retop;
818     cx->blk_format.gv          = gv;
819     cx->blk_format.dfoutgv     = PL_defoutgv;
820     cx->blk_format.prevcomppad = PL_comppad;
821     cx->blk_u16                = 0;
822
823     SvREFCNT_inc_simple_void_NN(cv);
824     CvDEPTH(cv)++;
825     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
826 }
827
828
829 PERL_STATIC_INLINE void
830 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
831 {
832     CV *cv;
833     GV *dfout;
834
835     PERL_ARGS_ASSERT_CX_POPFORMAT;
836     assert(CxTYPE(cx) == CXt_FORMAT);
837
838     dfout = cx->blk_format.dfoutgv;
839     setdefout(dfout);
840     cx->blk_format.dfoutgv = NULL;
841     SvREFCNT_dec_NN(dfout);
842
843     PL_comppad = cx->blk_format.prevcomppad;
844     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
845     cv = cx->blk_format.cv;
846     cx->blk_format.cv = NULL;
847     --CvDEPTH(cv);
848     SvREFCNT_dec_NN(cv);
849 }
850
851
852 PERL_STATIC_INLINE void
853 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
854 {
855     PERL_ARGS_ASSERT_CX_PUSHEVAL;
856
857     cx->blk_eval.retop         = retop;
858     cx->blk_eval.old_namesv    = namesv;
859     cx->blk_eval.old_eval_root = PL_eval_root;
860     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
861     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
862     cx->blk_eval.cur_top_env   = PL_top_env;
863
864     assert(!(PL_in_eval     & ~ 0x7F));
865     assert(!(PL_op->op_type & ~0x1FF));
866     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
867 }
868
869
870 PERL_STATIC_INLINE void
871 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
872 {
873     SV *sv;
874
875     PERL_ARGS_ASSERT_CX_POPEVAL;
876     assert(CxTYPE(cx) == CXt_EVAL);
877
878     PL_in_eval = CxOLD_IN_EVAL(cx);
879     PL_eval_root = cx->blk_eval.old_eval_root;
880     sv = cx->blk_eval.cur_text;
881     if (sv && SvSCREAM(sv)) {
882         cx->blk_eval.cur_text = NULL;
883         SvREFCNT_dec_NN(sv);
884     }
885
886     sv = cx->blk_eval.old_namesv;
887     if (sv) {
888         cx->blk_eval.old_namesv = NULL;
889         SvREFCNT_dec_NN(sv);
890     }
891 }
892
893
894 /* push a plain loop, i.e.
895  *     { block }
896  *     while (cond) { block }
897  *     for (init;cond;continue) { block }
898  * This loop can be last/redo'ed etc.
899  */
900
901 PERL_STATIC_INLINE void
902 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
903 {
904     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
905     cx->blk_loop.my_op = cLOOP;
906 }
907
908
909 /* push a true for loop, i.e.
910  *     for var (list) { block }
911  */
912
913 PERL_STATIC_INLINE void
914 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
915 {
916     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
917
918     /* this one line is common with cx_pushloop_plain */
919     cx->blk_loop.my_op = cLOOP;
920
921     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
922     cx->blk_loop.itersave      = itersave;
923 #ifdef USE_ITHREADS
924     cx->blk_loop.oldcomppad = PL_comppad;
925 #endif
926 }
927
928
929 /* pop all loop types, including plain */
930
931 PERL_STATIC_INLINE void
932 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
933 {
934     PERL_ARGS_ASSERT_CX_POPLOOP;
935
936     assert(CxTYPE_is_LOOP(cx));
937     if (  CxTYPE(cx) == CXt_LOOP_ARY
938        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
939     {
940         /* Free ary or cur. This assumes that state_u.ary.ary
941          * aligns with state_u.lazysv.cur. See cx_dup() */
942         SV *sv = cx->blk_loop.state_u.lazysv.cur;
943         cx->blk_loop.state_u.lazysv.cur = NULL;
944         SvREFCNT_dec_NN(sv);
945         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
946             sv = cx->blk_loop.state_u.lazysv.end;
947             cx->blk_loop.state_u.lazysv.end = NULL;
948             SvREFCNT_dec_NN(sv);
949         }
950     }
951     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
952         SV *cursv;
953         SV **svp = (cx)->blk_loop.itervar_u.svp;
954         if ((cx->cx_type & CXp_FOR_GV))
955             svp = &GvSV((GV*)svp);
956         cursv = *svp;
957         *svp = cx->blk_loop.itersave;
958         cx->blk_loop.itersave = NULL;
959         SvREFCNT_dec(cursv);
960     }
961 }
962
963
964 PERL_STATIC_INLINE void
965 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
966 {
967     PERL_ARGS_ASSERT_CX_PUSHWHEN;
968
969     cx->blk_givwhen.leave_op = cLOGOP->op_other;
970 }
971
972
973 PERL_STATIC_INLINE void
974 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
975 {
976     PERL_ARGS_ASSERT_CX_POPWHEN;
977     assert(CxTYPE(cx) == CXt_WHEN);
978
979     PERL_UNUSED_ARG(cx);
980     PERL_UNUSED_CONTEXT;
981     /* currently NOOP */
982 }
983
984
985 PERL_STATIC_INLINE void
986 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
987 {
988     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
989
990     cx->blk_givwhen.leave_op = cLOGOP->op_other;
991     cx->blk_givwhen.defsv_save = orig_defsv;
992 }
993
994
995 PERL_STATIC_INLINE void
996 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
997 {
998     SV *sv;
999
1000     PERL_ARGS_ASSERT_CX_POPGIVEN;
1001     assert(CxTYPE(cx) == CXt_GIVEN);
1002
1003     sv = GvSV(PL_defgv);
1004     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1005     cx->blk_givwhen.defsv_save = NULL;
1006     SvREFCNT_dec(sv);
1007 }
1008
1009 /*
1010  * ex: set ts=8 sts=4 sw=4 et:
1011  */