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