This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
CoreList: fix release date on v5.24.0
[perl5.git] / inline.h
CommitLineData
25468daa
FC
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 */
27669aa4 14
be3a7a5d
KW
15/* ------------------------------- av.h ------------------------------- */
16
c70927a6 17PERL_STATIC_INLINE SSize_t
be3a7a5d
KW
18S_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
1afe1db1
FC
26/* ------------------------------- cv.h ------------------------------- */
27
ae77754a
FC
28PERL_STATIC_INLINE GV *
29S_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
1afe1db1
FC
36PERL_STATIC_INLINE I32 *
37S_CvDEPTHp(const CV * const sv)
38{
39 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
8de47657 40 return &((XPVCV*)SvANY(sv))->xcv_depth;
1afe1db1
FC
41}
42
d16269d8
PM
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
5b67adb8 54#ifdef PERL_CORE
d16269d8
PM
55PERL_STATIC_INLINE char *
56S_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}
5b67adb8 71#endif
d16269d8 72
25fdce4a
FC
73/* ------------------------------- mg.h ------------------------------- */
74
75#if defined(PERL_CORE) || defined(PERL_EXT)
76/* assumes get-magic and stringification have already occurred */
77PERL_STATIC_INLINE STRLEN
78S_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
03414f05
FC
93/* ------------------------------- pad.h ------------------------------ */
94
95#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96PERL_STATIC_INLINE bool
97PadnameIN_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
8d919b0a
FC
128/* ----------------------------- regexp.h ----------------------------- */
129
130PERL_STATIC_INLINE struct regexp *
131S_ReANY(const REGEXP * const re)
132{
133 assert(isREGEXP(re));
134 return re->sv_u.svu_rx;
135}
136
27669aa4
FC
137/* ------------------------------- sv.h ------------------------------- */
138
139PERL_STATIC_INLINE SV *
140S_SvREFCNT_inc(SV *sv)
141{
2439e033 142 if (LIKELY(sv != NULL))
27669aa4
FC
143 SvREFCNT(sv)++;
144 return sv;
145}
146PERL_STATIC_INLINE SV *
147S_SvREFCNT_inc_NN(SV *sv)
148{
149 SvREFCNT(sv)++;
150 return sv;
151}
152PERL_STATIC_INLINE void
153S_SvREFCNT_inc_void(SV *sv)
154{
2439e033 155 if (LIKELY(sv != NULL))
27669aa4
FC
156 SvREFCNT(sv)++;
157}
75e16a44
FC
158PERL_STATIC_INLINE void
159S_SvREFCNT_dec(pTHX_ SV *sv)
160{
2439e033 161 if (LIKELY(sv != NULL)) {
75a9bf96 162 U32 rc = SvREFCNT(sv);
79e2a32a 163 if (LIKELY(rc > 1))
75a9bf96
DM
164 SvREFCNT(sv) = rc - 1;
165 else
166 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
167 }
168}
541377b1
FC
169
170PERL_STATIC_INLINE void
4a9a56a7
DM
171S_SvREFCNT_dec_NN(pTHX_ SV *sv)
172{
173 U32 rc = SvREFCNT(sv);
79e2a32a 174 if (LIKELY(rc > 1))
4a9a56a7
DM
175 SvREFCNT(sv) = rc - 1;
176 else
177 Perl_sv_free2(aTHX_ sv, rc);
178}
179
180PERL_STATIC_INLINE void
541377b1
FC
181SvAMAGIC_on(SV *sv)
182{
183 assert(SvROK(sv));
184 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
185}
186PERL_STATIC_INLINE void
187SvAMAGIC_off(SV *sv)
188{
189 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
190 HvAMAGIC_off(SvSTASH(SvRV(sv)));
191}
192
193PERL_STATIC_INLINE U32
541377b1
FC
194S_SvPADSTALE_on(SV *sv)
195{
c0683843 196 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
197 return SvFLAGS(sv) |= SVs_PADSTALE;
198}
199PERL_STATIC_INLINE U32
200S_SvPADSTALE_off(SV *sv)
201{
c0683843 202 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
203 return SvFLAGS(sv) &= ~SVs_PADSTALE;
204}
25fdce4a 205#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 206PERL_STATIC_INLINE STRLEN
6964422a 207S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 208{
25fdce4a 209 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
210 if (SvGAMAGIC(sv)) {
211 U8 *hopped = utf8_hop((U8 *)pv, pos);
212 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
213 return (STRLEN)(hopped - (U8 *)pv);
214 }
215 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
216}
217#endif
f019c49e 218
d1decf2b
TC
219/* ------------------------------- handy.h ------------------------------- */
220
221/* saves machine code for a common noreturn idiom typically used in Newx*() */
c1d6452f 222#ifdef GCC_DIAG_PRAGMA
6ab56f1e 223GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
c1d6452f 224#endif
d1decf2b
TC
225static void
226S_croak_memory_wrap(void)
227{
228 Perl_croak_nocontext("%s",PL_memory_wrap);
229}
c1d6452f 230#ifdef GCC_DIAG_PRAGMA
6ab56f1e 231GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
c1d6452f 232#endif
d1decf2b 233
a8a2ceaa
KW
234/* ------------------------------- utf8.h ------------------------------- */
235
55d09dc8
KW
236PERL_STATIC_INLINE void
237S_append_utf8_from_native_byte(const U8 byte, U8** dest)
238{
239 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
240 * encoded string at '*dest', updating '*dest' to include it */
241
55d09dc8
KW
242 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
243
6f2d5cbc 244 if (NATIVE_BYTE_IS_INVARIANT(byte))
9ff651ce 245 *(*dest)++ = byte;
55d09dc8 246 else {
9ff651ce
KW
247 *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
248 *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
249 }
250}
251
e123187a 252/*
f2645549 253
6302f837
KW
254A helper function for the macro isUTF8_CHAR(), which should be used instead of
255this function. The macro will handle smaller code points directly saving time,
256using this function as a fall-back for higher code points.
f2645549 257
6302f837
KW
258Tests if the first bytes of string C<s> form a valid UTF-8 character. 0 is
259returned if the bytes starting at C<s> up to but not including C<e> do not form a
260complete well-formed UTF-8 character; otherwise the number of bytes in the
261character is returned.
f2645549 262
6302f837
KW
263Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
264character.
e123187a
KW
265
266=cut */
267PERL_STATIC_INLINE STRLEN
6302f837 268S__is_utf8_char_slow(const U8 *s, const U8 *e)
e123187a
KW
269{
270 dTHX; /* The function called below requires thread context */
271
272 STRLEN actual_len;
273
274 PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW;
275
6302f837
KW
276 assert(e >= s);
277 utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
e123187a
KW
278
279 return (actual_len == (STRLEN) -1) ? 0 : actual_len;
280}
281
c8028aa6
TC
282/* ------------------------------- perl.h ----------------------------- */
283
284/*
dcccc8ff
KW
285=head1 Miscellaneous Functions
286
41188aa0 287=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 288
6602b933 289Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 290If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
291
292Return TRUE if the name is safe.
293
796b6530 294Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
295
296=cut
297*/
298
299PERL_STATIC_INLINE bool
41188aa0 300S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
301 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
302 * perl itself uses xce*() functions which accept 8-bit strings.
303 */
304
305 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
306
6c4650b3 307 if (len > 1) {
c8028aa6 308 char *null_at;
41188aa0 309 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 310 SETERRNO(ENOENT, LIB_INVARG);
1d505182 311 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 312 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 313 what, op_name, pv, null_at+1);
c8028aa6
TC
314 return FALSE;
315 }
316 }
317
318 return TRUE;
319}
320
321/*
7cb3f959
TC
322
323Return true if the supplied filename has a newline character
fa6c7d00 324immediately before the first (hopefully only) NUL.
7cb3f959
TC
325
326My original look at this incorrectly used the len from SvPV(), but
327that's incorrect, since we allow for a NUL in pv[len-1].
328
329So instead, strlen() and work from there.
330
331This allow for the user reading a filename, forgetting to chomp it,
332then calling:
333
334 open my $foo, "$file\0";
335
336*/
337
338#ifdef PERL_CORE
339
340PERL_STATIC_INLINE bool
341S_should_warn_nl(const char *pv) {
342 STRLEN len;
343
344 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
345
346 len = strlen(pv);
347
348 return len > 0 && pv[len-1] == '\n';
349}
350
351#endif
352
81d52ecd
JH
353/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
354
355#define MAX_CHARSET_NAME_LENGTH 2
356
357PERL_STATIC_INLINE const char *
358get_regex_charset_name(const U32 flags, STRLEN* const lenp)
359{
360 /* Returns a string that corresponds to the name of the regex character set
361 * given by 'flags', and *lenp is set the length of that string, which
362 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
363
364 *lenp = 1;
365 switch (get_regex_charset(flags)) {
366 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
367 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
368 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
369 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
370 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
371 *lenp = 2;
372 return ASCII_MORE_RESTRICT_PAT_MODS;
373 }
374 /* The NOT_REACHED; hides an assert() which has a rather complex
375 * definition in perl.h. */
376 NOT_REACHED; /* NOTREACHED */
377 return "?"; /* Unknown */
378}
379
7cb3f959 380/*
ed382232
TC
381
382Return false if any get magic is on the SV other than taint magic.
383
384*/
385
386PERL_STATIC_INLINE bool
387S_sv_only_taint_gmagic(SV *sv) {
388 MAGIC *mg = SvMAGIC(sv);
389
390 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
391
392 while (mg) {
393 if (mg->mg_type != PERL_MAGIC_taint
394 && !(mg->mg_flags & MGf_GSKIP)
395 && mg->mg_virtual->svt_get) {
396 return FALSE;
397 }
398 mg = mg->mg_moremagic;
399 }
400
401 return TRUE;
402}
403
ed8ff0f3
DM
404/* ------------------ cop.h ------------------------------------------- */
405
406
407/* Enter a block. Push a new base context and return its address. */
408
409PERL_STATIC_INLINE PERL_CONTEXT *
410S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
411{
412 PERL_CONTEXT * cx;
413
414 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
415
416 CXINC;
417 cx = CX_CUR();
418 cx->cx_type = type;
419 cx->blk_gimme = gimme;
420 cx->blk_oldsaveix = saveix;
4caf7d8c 421 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 422 cx->blk_oldcop = PL_curcop;
4caf7d8c 423 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
424 cx->blk_oldscopesp = PL_scopestack_ix;
425 cx->blk_oldpm = PL_curpm;
ce8bb8d8 426 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
427
428 PL_tmps_floor = PL_tmps_ix;
429 CX_DEBUG(cx, "PUSH");
430 return cx;
431}
432
433
434/* Exit a block (RETURN and LAST). */
435
436PERL_STATIC_INLINE void
437S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
438{
439 PERL_ARGS_ASSERT_CX_POPBLOCK;
440
441 CX_DEBUG(cx, "POP");
442 /* these 3 are common to cx_popblock and cx_topblock */
443 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
444 PL_scopestack_ix = cx->blk_oldscopesp;
445 PL_curpm = cx->blk_oldpm;
446
447 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
448 * and leaves a CX entry lying around for repeated use, so
449 * skip for multicall */ \
450 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
451 || PL_savestack_ix == cx->blk_oldsaveix);
452 PL_curcop = cx->blk_oldcop;
ce8bb8d8 453 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
454}
455
456/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
457 * Whereas cx_popblock() restores the state to the point just before
458 * cx_pushblock() was called, cx_topblock() restores it to the point just
459 * *after* cx_pushblock() was called. */
460
461PERL_STATIC_INLINE void
462S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
463{
464 PERL_ARGS_ASSERT_CX_TOPBLOCK;
465
466 CX_DEBUG(cx, "TOP");
467 /* these 3 are common to cx_popblock and cx_topblock */
468 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
469 PL_scopestack_ix = cx->blk_oldscopesp;
470 PL_curpm = cx->blk_oldpm;
471
472 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
473}
474
475
a73d8813
DM
476PERL_STATIC_INLINE void
477S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
478{
479 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
480
481 PERL_ARGS_ASSERT_CX_PUSHSUB;
482
3f6bd23a 483 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
484 cx->blk_sub.cv = cv;
485 cx->blk_sub.olddepth = CvDEPTH(cv);
486 cx->blk_sub.prevcomppad = PL_comppad;
487 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
488 cx->blk_sub.retop = retop;
489 SvREFCNT_inc_simple_void_NN(cv);
490 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
491}
492
493
494/* subsets of cx_popsub() */
495
496PERL_STATIC_INLINE void
497S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
498{
499 CV *cv;
500
501 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
502 assert(CxTYPE(cx) == CXt_SUB);
503
504 PL_comppad = cx->blk_sub.prevcomppad;
505 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
506 cv = cx->blk_sub.cv;
507 CvDEPTH(cv) = cx->blk_sub.olddepth;
508 cx->blk_sub.cv = NULL;
509 SvREFCNT_dec(cv);
510}
511
512
513/* handle the @_ part of leaving a sub */
514
515PERL_STATIC_INLINE void
516S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
517{
518 AV *av;
519
520 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
521 assert(CxTYPE(cx) == CXt_SUB);
522 assert(AvARRAY(MUTABLE_AV(
523 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
524 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
525
526 CX_POP_SAVEARRAY(cx);
527 av = MUTABLE_AV(PAD_SVl(0));
528 if (UNLIKELY(AvREAL(av)))
529 /* abandon @_ if it got reified */
530 clear_defarray(av, 0);
531 else {
532 CLEAR_ARGARRAY(av);
533 }
534}
535
536
537PERL_STATIC_INLINE void
538S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
539{
540 PERL_ARGS_ASSERT_CX_POPSUB;
541 assert(CxTYPE(cx) == CXt_SUB);
542
3f6bd23a 543 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
544
545 if (CxHASARGS(cx))
546 cx_popsub_args(cx);
547 cx_popsub_common(cx);
548}
549
550
6a7d52cc
DM
551PERL_STATIC_INLINE void
552S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
553{
554 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
555
556 cx->blk_format.cv = cv;
557 cx->blk_format.retop = retop;
558 cx->blk_format.gv = gv;
559 cx->blk_format.dfoutgv = PL_defoutgv;
560 cx->blk_format.prevcomppad = PL_comppad;
561 cx->blk_u16 = 0;
562
563 SvREFCNT_inc_simple_void_NN(cv);
564 CvDEPTH(cv)++;
565 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
566}
567
568
569PERL_STATIC_INLINE void
570S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
571{
572 CV *cv;
573 GV *dfout;
574
575 PERL_ARGS_ASSERT_CX_POPFORMAT;
576 assert(CxTYPE(cx) == CXt_FORMAT);
577
578 dfout = cx->blk_format.dfoutgv;
579 setdefout(dfout);
580 cx->blk_format.dfoutgv = NULL;
581 SvREFCNT_dec_NN(dfout);
582
583 PL_comppad = cx->blk_format.prevcomppad;
584 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
585 cv = cx->blk_format.cv;
586 cx->blk_format.cv = NULL;
587 --CvDEPTH(cv);
588 SvREFCNT_dec_NN(cv);
589}
590
591
13febba5
DM
592PERL_STATIC_INLINE void
593S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
594{
595 PERL_ARGS_ASSERT_CX_PUSHEVAL;
596
597 cx->blk_eval.retop = retop;
598 cx->blk_eval.old_namesv = namesv;
599 cx->blk_eval.old_eval_root = PL_eval_root;
600 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
601 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
602 cx->blk_eval.cur_top_env = PL_top_env;
603
604 assert(!(PL_in_eval & ~ 0x7F));
605 assert(!(PL_op->op_type & ~0x1FF));
606 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
607}
608
609
610PERL_STATIC_INLINE void
611S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
612{
613 SV *sv;
614
615 PERL_ARGS_ASSERT_CX_POPEVAL;
616 assert(CxTYPE(cx) == CXt_EVAL);
617
618 PL_in_eval = CxOLD_IN_EVAL(cx);
619 PL_eval_root = cx->blk_eval.old_eval_root;
620 sv = cx->blk_eval.cur_text;
621 if (sv && SvSCREAM(sv)) {
622 cx->blk_eval.cur_text = NULL;
623 SvREFCNT_dec_NN(sv);
624 }
625
626 sv = cx->blk_eval.old_namesv;
627 if (sv && !SvTEMP(sv))/* TEMP implies cx_popeval() re-entrantly called */
628 sv_2mortal(sv);
629}
6a7d52cc 630
a73d8813 631
d1b6bf72
DM
632/* push a plain loop, i.e.
633 * { block }
634 * while (cond) { block }
635 * for (init;cond;continue) { block }
636 * This loop can be last/redo'ed etc.
637 */
638
639PERL_STATIC_INLINE void
640S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
641{
642 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
643 cx->blk_loop.my_op = cLOOP;
644}
645
646
647/* push a true for loop, i.e.
648 * for var (list) { block }
649 */
650
651PERL_STATIC_INLINE void
652S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
653{
654 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
655
656 /* this one line is common with cx_pushloop_plain */
657 cx->blk_loop.my_op = cLOOP;
658
659 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
660 cx->blk_loop.itersave = itersave;
661#ifdef USE_ITHREADS
662 cx->blk_loop.oldcomppad = PL_comppad;
663#endif
664}
665
666
667/* pop all loop types, including plain */
668
669PERL_STATIC_INLINE void
670S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
671{
672 PERL_ARGS_ASSERT_CX_POPLOOP;
673
674 assert(CxTYPE_is_LOOP(cx));
675 if ( CxTYPE(cx) == CXt_LOOP_ARY
676 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
677 {
678 /* Free ary or cur. This assumes that state_u.ary.ary
679 * aligns with state_u.lazysv.cur. See cx_dup() */
680 SV *sv = cx->blk_loop.state_u.lazysv.cur;
681 cx->blk_loop.state_u.lazysv.cur = NULL;
682 SvREFCNT_dec_NN(sv);
683 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
684 sv = cx->blk_loop.state_u.lazysv.end;
685 cx->blk_loop.state_u.lazysv.end = NULL;
686 SvREFCNT_dec_NN(sv);
687 }
688 }
689 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
690 SV *cursv;
691 SV **svp = (cx)->blk_loop.itervar_u.svp;
692 if ((cx->cx_type & CXp_FOR_GV))
693 svp = &GvSV((GV*)svp);
694 cursv = *svp;
695 *svp = cx->blk_loop.itersave;
696 cx->blk_loop.itersave = NULL;
697 SvREFCNT_dec(cursv);
698 }
699}
700
2a7b7c61
DM
701
702PERL_STATIC_INLINE void
703S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
704{
705 PERL_ARGS_ASSERT_CX_PUSHWHEN;
706
707 cx->blk_givwhen.leave_op = cLOGOP->op_other;
708}
709
710
711PERL_STATIC_INLINE void
712S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
713{
714 PERL_ARGS_ASSERT_CX_POPWHEN;
715 assert(CxTYPE(cx) == CXt_WHEN);
716
717 PERL_UNUSED_ARG(cx);
718 /* currently NOOP */
719}
720
721
722PERL_STATIC_INLINE void
723S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
724{
725 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
726
727 cx->blk_givwhen.leave_op = cLOGOP->op_other;
728 cx->blk_givwhen.defsv_save = orig_defsv;
729}
730
731
732PERL_STATIC_INLINE void
733S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
734{
735 SV *sv;
736
737 PERL_ARGS_ASSERT_CX_POPGIVEN;
738 assert(CxTYPE(cx) == CXt_GIVEN);
739
740 sv = GvSV(PL_defgv);
741 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
742 cx->blk_givwhen.defsv_save = NULL;
743 SvREFCNT_dec(sv);
744}
745
746
747
748
ed382232 749/*
c8028aa6
TC
750 * ex: set ts=8 sts=4 sw=4 et:
751 */