This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Slightly simplify utf8_to_uvuni_buf()
[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
1e599354
KW
353/*
354=for apidoc is_utf8_invariant_string
355
356Returns true iff the first C<len> bytes of the string C<s> are the same
357regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
358EBCDIC machines). That is, if they are UTF-8 invariant. On ASCII-ish
359machines, all the ASCII characters and only the ASCII characters fit this
360definition. On EBCDIC machines, the ASCII-range characters are invariant, but
361so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
362EBCDIC).
363
364If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
365use this option, that C<s> can't have embedded C<NUL> characters and has to
366have a terminating C<NUL> byte).
367
368See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
369L</is_utf8_string_loc>().
370
371=cut
372*/
373
374PERL_STATIC_INLINE bool
375S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
376{
377 const U8* const send = s + (len ? len : strlen((const char *)s));
378 const U8* x = s;
379
380 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
381
382 for (; x < send; ++x) {
383 if (!UTF8_IS_INVARIANT(*x))
384 return FALSE;
385 }
386
387 return TRUE;
388}
389
c8028aa6
TC
390/* ------------------------------- perl.h ----------------------------- */
391
392/*
dcccc8ff
KW
393=head1 Miscellaneous Functions
394
41188aa0 395=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 396
6602b933 397Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 398If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
399
400Return TRUE if the name is safe.
401
796b6530 402Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
403
404=cut
405*/
406
407PERL_STATIC_INLINE bool
41188aa0 408S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
409 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
410 * perl itself uses xce*() functions which accept 8-bit strings.
411 */
412
413 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
414
6c4650b3 415 if (len > 1) {
c8028aa6 416 char *null_at;
41188aa0 417 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 418 SETERRNO(ENOENT, LIB_INVARG);
1d505182 419 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 420 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 421 what, op_name, pv, null_at+1);
c8028aa6
TC
422 return FALSE;
423 }
424 }
425
426 return TRUE;
427}
428
429/*
7cb3f959
TC
430
431Return true if the supplied filename has a newline character
fa6c7d00 432immediately before the first (hopefully only) NUL.
7cb3f959
TC
433
434My original look at this incorrectly used the len from SvPV(), but
435that's incorrect, since we allow for a NUL in pv[len-1].
436
437So instead, strlen() and work from there.
438
439This allow for the user reading a filename, forgetting to chomp it,
440then calling:
441
442 open my $foo, "$file\0";
443
444*/
445
446#ifdef PERL_CORE
447
448PERL_STATIC_INLINE bool
449S_should_warn_nl(const char *pv) {
450 STRLEN len;
451
452 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
453
454 len = strlen(pv);
455
456 return len > 0 && pv[len-1] == '\n';
457}
458
459#endif
460
81d52ecd
JH
461/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
462
463#define MAX_CHARSET_NAME_LENGTH 2
464
465PERL_STATIC_INLINE const char *
466get_regex_charset_name(const U32 flags, STRLEN* const lenp)
467{
468 /* Returns a string that corresponds to the name of the regex character set
469 * given by 'flags', and *lenp is set the length of that string, which
470 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
471
472 *lenp = 1;
473 switch (get_regex_charset(flags)) {
474 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
475 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
476 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
477 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
478 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
479 *lenp = 2;
480 return ASCII_MORE_RESTRICT_PAT_MODS;
481 }
482 /* The NOT_REACHED; hides an assert() which has a rather complex
483 * definition in perl.h. */
484 NOT_REACHED; /* NOTREACHED */
485 return "?"; /* Unknown */
486}
487
7cb3f959 488/*
ed382232
TC
489
490Return false if any get magic is on the SV other than taint magic.
491
492*/
493
494PERL_STATIC_INLINE bool
495S_sv_only_taint_gmagic(SV *sv) {
496 MAGIC *mg = SvMAGIC(sv);
497
498 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
499
500 while (mg) {
501 if (mg->mg_type != PERL_MAGIC_taint
502 && !(mg->mg_flags & MGf_GSKIP)
503 && mg->mg_virtual->svt_get) {
504 return FALSE;
505 }
506 mg = mg->mg_moremagic;
507 }
508
509 return TRUE;
510}
511
ed8ff0f3
DM
512/* ------------------ cop.h ------------------------------------------- */
513
514
515/* Enter a block. Push a new base context and return its address. */
516
517PERL_STATIC_INLINE PERL_CONTEXT *
518S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
519{
520 PERL_CONTEXT * cx;
521
522 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
523
524 CXINC;
525 cx = CX_CUR();
526 cx->cx_type = type;
527 cx->blk_gimme = gimme;
528 cx->blk_oldsaveix = saveix;
4caf7d8c 529 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 530 cx->blk_oldcop = PL_curcop;
4caf7d8c 531 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
532 cx->blk_oldscopesp = PL_scopestack_ix;
533 cx->blk_oldpm = PL_curpm;
ce8bb8d8 534 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
535
536 PL_tmps_floor = PL_tmps_ix;
537 CX_DEBUG(cx, "PUSH");
538 return cx;
539}
540
541
542/* Exit a block (RETURN and LAST). */
543
544PERL_STATIC_INLINE void
545S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
546{
547 PERL_ARGS_ASSERT_CX_POPBLOCK;
548
549 CX_DEBUG(cx, "POP");
550 /* these 3 are common to cx_popblock and cx_topblock */
551 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
552 PL_scopestack_ix = cx->blk_oldscopesp;
553 PL_curpm = cx->blk_oldpm;
554
555 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
556 * and leaves a CX entry lying around for repeated use, so
557 * skip for multicall */ \
558 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
559 || PL_savestack_ix == cx->blk_oldsaveix);
560 PL_curcop = cx->blk_oldcop;
ce8bb8d8 561 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
562}
563
564/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
565 * Whereas cx_popblock() restores the state to the point just before
566 * cx_pushblock() was called, cx_topblock() restores it to the point just
567 * *after* cx_pushblock() was called. */
568
569PERL_STATIC_INLINE void
570S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
571{
572 PERL_ARGS_ASSERT_CX_TOPBLOCK;
573
574 CX_DEBUG(cx, "TOP");
575 /* these 3 are common to cx_popblock and cx_topblock */
576 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
577 PL_scopestack_ix = cx->blk_oldscopesp;
578 PL_curpm = cx->blk_oldpm;
579
580 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
581}
582
583
a73d8813
DM
584PERL_STATIC_INLINE void
585S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
586{
587 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
588
589 PERL_ARGS_ASSERT_CX_PUSHSUB;
590
3f6bd23a 591 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
592 cx->blk_sub.cv = cv;
593 cx->blk_sub.olddepth = CvDEPTH(cv);
594 cx->blk_sub.prevcomppad = PL_comppad;
595 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
596 cx->blk_sub.retop = retop;
597 SvREFCNT_inc_simple_void_NN(cv);
598 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
599}
600
601
602/* subsets of cx_popsub() */
603
604PERL_STATIC_INLINE void
605S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
606{
607 CV *cv;
608
609 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
610 assert(CxTYPE(cx) == CXt_SUB);
611
612 PL_comppad = cx->blk_sub.prevcomppad;
613 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
614 cv = cx->blk_sub.cv;
615 CvDEPTH(cv) = cx->blk_sub.olddepth;
616 cx->blk_sub.cv = NULL;
617 SvREFCNT_dec(cv);
618}
619
620
621/* handle the @_ part of leaving a sub */
622
623PERL_STATIC_INLINE void
624S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
625{
626 AV *av;
627
628 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
629 assert(CxTYPE(cx) == CXt_SUB);
630 assert(AvARRAY(MUTABLE_AV(
631 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
632 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
633
634 CX_POP_SAVEARRAY(cx);
635 av = MUTABLE_AV(PAD_SVl(0));
636 if (UNLIKELY(AvREAL(av)))
637 /* abandon @_ if it got reified */
638 clear_defarray(av, 0);
639 else {
640 CLEAR_ARGARRAY(av);
641 }
642}
643
644
645PERL_STATIC_INLINE void
646S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
647{
648 PERL_ARGS_ASSERT_CX_POPSUB;
649 assert(CxTYPE(cx) == CXt_SUB);
650
3f6bd23a 651 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
652
653 if (CxHASARGS(cx))
654 cx_popsub_args(cx);
655 cx_popsub_common(cx);
656}
657
658
6a7d52cc
DM
659PERL_STATIC_INLINE void
660S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
661{
662 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
663
664 cx->blk_format.cv = cv;
665 cx->blk_format.retop = retop;
666 cx->blk_format.gv = gv;
667 cx->blk_format.dfoutgv = PL_defoutgv;
668 cx->blk_format.prevcomppad = PL_comppad;
669 cx->blk_u16 = 0;
670
671 SvREFCNT_inc_simple_void_NN(cv);
672 CvDEPTH(cv)++;
673 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
674}
675
676
677PERL_STATIC_INLINE void
678S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
679{
680 CV *cv;
681 GV *dfout;
682
683 PERL_ARGS_ASSERT_CX_POPFORMAT;
684 assert(CxTYPE(cx) == CXt_FORMAT);
685
686 dfout = cx->blk_format.dfoutgv;
687 setdefout(dfout);
688 cx->blk_format.dfoutgv = NULL;
689 SvREFCNT_dec_NN(dfout);
690
691 PL_comppad = cx->blk_format.prevcomppad;
692 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
693 cv = cx->blk_format.cv;
694 cx->blk_format.cv = NULL;
695 --CvDEPTH(cv);
696 SvREFCNT_dec_NN(cv);
697}
698
699
13febba5
DM
700PERL_STATIC_INLINE void
701S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
702{
703 PERL_ARGS_ASSERT_CX_PUSHEVAL;
704
705 cx->blk_eval.retop = retop;
706 cx->blk_eval.old_namesv = namesv;
707 cx->blk_eval.old_eval_root = PL_eval_root;
708 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
709 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
710 cx->blk_eval.cur_top_env = PL_top_env;
711
712 assert(!(PL_in_eval & ~ 0x7F));
713 assert(!(PL_op->op_type & ~0x1FF));
714 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
715}
716
717
718PERL_STATIC_INLINE void
719S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
720{
721 SV *sv;
722
723 PERL_ARGS_ASSERT_CX_POPEVAL;
724 assert(CxTYPE(cx) == CXt_EVAL);
725
726 PL_in_eval = CxOLD_IN_EVAL(cx);
727 PL_eval_root = cx->blk_eval.old_eval_root;
728 sv = cx->blk_eval.cur_text;
729 if (sv && SvSCREAM(sv)) {
730 cx->blk_eval.cur_text = NULL;
731 SvREFCNT_dec_NN(sv);
732 }
733
734 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
735 if (sv) {
736 cx->blk_eval.old_namesv = NULL;
737 SvREFCNT_dec_NN(sv);
738 }
13febba5 739}
6a7d52cc 740
a73d8813 741
d1b6bf72
DM
742/* push a plain loop, i.e.
743 * { block }
744 * while (cond) { block }
745 * for (init;cond;continue) { block }
746 * This loop can be last/redo'ed etc.
747 */
748
749PERL_STATIC_INLINE void
750S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
751{
752 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
753 cx->blk_loop.my_op = cLOOP;
754}
755
756
757/* push a true for loop, i.e.
758 * for var (list) { block }
759 */
760
761PERL_STATIC_INLINE void
762S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
763{
764 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
765
766 /* this one line is common with cx_pushloop_plain */
767 cx->blk_loop.my_op = cLOOP;
768
769 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
770 cx->blk_loop.itersave = itersave;
771#ifdef USE_ITHREADS
772 cx->blk_loop.oldcomppad = PL_comppad;
773#endif
774}
775
776
777/* pop all loop types, including plain */
778
779PERL_STATIC_INLINE void
780S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
781{
782 PERL_ARGS_ASSERT_CX_POPLOOP;
783
784 assert(CxTYPE_is_LOOP(cx));
785 if ( CxTYPE(cx) == CXt_LOOP_ARY
786 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
787 {
788 /* Free ary or cur. This assumes that state_u.ary.ary
789 * aligns with state_u.lazysv.cur. See cx_dup() */
790 SV *sv = cx->blk_loop.state_u.lazysv.cur;
791 cx->blk_loop.state_u.lazysv.cur = NULL;
792 SvREFCNT_dec_NN(sv);
793 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
794 sv = cx->blk_loop.state_u.lazysv.end;
795 cx->blk_loop.state_u.lazysv.end = NULL;
796 SvREFCNT_dec_NN(sv);
797 }
798 }
799 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
800 SV *cursv;
801 SV **svp = (cx)->blk_loop.itervar_u.svp;
802 if ((cx->cx_type & CXp_FOR_GV))
803 svp = &GvSV((GV*)svp);
804 cursv = *svp;
805 *svp = cx->blk_loop.itersave;
806 cx->blk_loop.itersave = NULL;
807 SvREFCNT_dec(cursv);
808 }
809}
810
2a7b7c61
DM
811
812PERL_STATIC_INLINE void
813S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
814{
815 PERL_ARGS_ASSERT_CX_PUSHWHEN;
816
817 cx->blk_givwhen.leave_op = cLOGOP->op_other;
818}
819
820
821PERL_STATIC_INLINE void
822S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
823{
824 PERL_ARGS_ASSERT_CX_POPWHEN;
825 assert(CxTYPE(cx) == CXt_WHEN);
826
827 PERL_UNUSED_ARG(cx);
59a14f30 828 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
829 /* currently NOOP */
830}
831
832
833PERL_STATIC_INLINE void
834S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
835{
836 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
837
838 cx->blk_givwhen.leave_op = cLOGOP->op_other;
839 cx->blk_givwhen.defsv_save = orig_defsv;
840}
841
842
843PERL_STATIC_INLINE void
844S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
845{
846 SV *sv;
847
848 PERL_ARGS_ASSERT_CX_POPGIVEN;
849 assert(CxTYPE(cx) == CXt_GIVEN);
850
851 sv = GvSV(PL_defgv);
852 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
853 cx->blk_givwhen.defsv_save = NULL;
854 SvREFCNT_dec(sv);
855}
856
ed382232 857/*
c8028aa6
TC
858 * ex: set ts=8 sts=4 sw=4 et:
859 */