This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Clarify comments for valid_utf8_to_uvchr()
[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
55d09dc8
KW
259PERL_STATIC_INLINE void
260S_append_utf8_from_native_byte(const U8 byte, U8** dest)
261{
262 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
263 * encoded string at '*dest', updating '*dest' to include it */
264
55d09dc8
KW
265 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
266
6f2d5cbc 267 if (NATIVE_BYTE_IS_INVARIANT(byte))
9ff651ce 268 *(*dest)++ = byte;
55d09dc8 269 else {
9ff651ce
KW
270 *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
271 *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
272 }
273}
274
e123187a 275/*
f2645549 276
6302f837
KW
277A helper function for the macro isUTF8_CHAR(), which should be used instead of
278this function. The macro will handle smaller code points directly saving time,
279using this function as a fall-back for higher code points.
f2645549 280
6302f837
KW
281Tests if the first bytes of string C<s> form a valid UTF-8 character. 0 is
282returned if the bytes starting at C<s> up to but not including C<e> do not form a
283complete well-formed UTF-8 character; otherwise the number of bytes in the
284character is returned.
f2645549 285
6302f837
KW
286Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
287character.
e123187a
KW
288
289=cut */
290PERL_STATIC_INLINE STRLEN
6302f837 291S__is_utf8_char_slow(const U8 *s, const U8 *e)
e123187a
KW
292{
293 dTHX; /* The function called below requires thread context */
294
295 STRLEN actual_len;
296
297 PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW;
298
6302f837
KW
299 assert(e >= s);
300 utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
e123187a
KW
301
302 return (actual_len == (STRLEN) -1) ? 0 : actual_len;
303}
304
c8028aa6
TC
305/* ------------------------------- perl.h ----------------------------- */
306
307/*
dcccc8ff
KW
308=head1 Miscellaneous Functions
309
41188aa0 310=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 311
6602b933 312Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 313If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
314
315Return TRUE if the name is safe.
316
796b6530 317Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
318
319=cut
320*/
321
322PERL_STATIC_INLINE bool
41188aa0 323S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
324 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
325 * perl itself uses xce*() functions which accept 8-bit strings.
326 */
327
328 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
329
6c4650b3 330 if (len > 1) {
c8028aa6 331 char *null_at;
41188aa0 332 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 333 SETERRNO(ENOENT, LIB_INVARG);
1d505182 334 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 335 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 336 what, op_name, pv, null_at+1);
c8028aa6
TC
337 return FALSE;
338 }
339 }
340
341 return TRUE;
342}
343
344/*
7cb3f959
TC
345
346Return true if the supplied filename has a newline character
fa6c7d00 347immediately before the first (hopefully only) NUL.
7cb3f959
TC
348
349My original look at this incorrectly used the len from SvPV(), but
350that's incorrect, since we allow for a NUL in pv[len-1].
351
352So instead, strlen() and work from there.
353
354This allow for the user reading a filename, forgetting to chomp it,
355then calling:
356
357 open my $foo, "$file\0";
358
359*/
360
361#ifdef PERL_CORE
362
363PERL_STATIC_INLINE bool
364S_should_warn_nl(const char *pv) {
365 STRLEN len;
366
367 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
368
369 len = strlen(pv);
370
371 return len > 0 && pv[len-1] == '\n';
372}
373
374#endif
375
81d52ecd
JH
376/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
377
378#define MAX_CHARSET_NAME_LENGTH 2
379
380PERL_STATIC_INLINE const char *
381get_regex_charset_name(const U32 flags, STRLEN* const lenp)
382{
383 /* Returns a string that corresponds to the name of the regex character set
384 * given by 'flags', and *lenp is set the length of that string, which
385 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
386
387 *lenp = 1;
388 switch (get_regex_charset(flags)) {
389 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
390 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
391 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
392 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
393 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
394 *lenp = 2;
395 return ASCII_MORE_RESTRICT_PAT_MODS;
396 }
397 /* The NOT_REACHED; hides an assert() which has a rather complex
398 * definition in perl.h. */
399 NOT_REACHED; /* NOTREACHED */
400 return "?"; /* Unknown */
401}
402
7cb3f959 403/*
ed382232
TC
404
405Return false if any get magic is on the SV other than taint magic.
406
407*/
408
409PERL_STATIC_INLINE bool
410S_sv_only_taint_gmagic(SV *sv) {
411 MAGIC *mg = SvMAGIC(sv);
412
413 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
414
415 while (mg) {
416 if (mg->mg_type != PERL_MAGIC_taint
417 && !(mg->mg_flags & MGf_GSKIP)
418 && mg->mg_virtual->svt_get) {
419 return FALSE;
420 }
421 mg = mg->mg_moremagic;
422 }
423
424 return TRUE;
425}
426
ed8ff0f3
DM
427/* ------------------ cop.h ------------------------------------------- */
428
429
430/* Enter a block. Push a new base context and return its address. */
431
432PERL_STATIC_INLINE PERL_CONTEXT *
433S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
434{
435 PERL_CONTEXT * cx;
436
437 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
438
439 CXINC;
440 cx = CX_CUR();
441 cx->cx_type = type;
442 cx->blk_gimme = gimme;
443 cx->blk_oldsaveix = saveix;
4caf7d8c 444 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 445 cx->blk_oldcop = PL_curcop;
4caf7d8c 446 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
447 cx->blk_oldscopesp = PL_scopestack_ix;
448 cx->blk_oldpm = PL_curpm;
ce8bb8d8 449 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
450
451 PL_tmps_floor = PL_tmps_ix;
452 CX_DEBUG(cx, "PUSH");
453 return cx;
454}
455
456
457/* Exit a block (RETURN and LAST). */
458
459PERL_STATIC_INLINE void
460S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
461{
462 PERL_ARGS_ASSERT_CX_POPBLOCK;
463
464 CX_DEBUG(cx, "POP");
465 /* these 3 are common to cx_popblock and cx_topblock */
466 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
467 PL_scopestack_ix = cx->blk_oldscopesp;
468 PL_curpm = cx->blk_oldpm;
469
470 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
471 * and leaves a CX entry lying around for repeated use, so
472 * skip for multicall */ \
473 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
474 || PL_savestack_ix == cx->blk_oldsaveix);
475 PL_curcop = cx->blk_oldcop;
ce8bb8d8 476 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
477}
478
479/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
480 * Whereas cx_popblock() restores the state to the point just before
481 * cx_pushblock() was called, cx_topblock() restores it to the point just
482 * *after* cx_pushblock() was called. */
483
484PERL_STATIC_INLINE void
485S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
486{
487 PERL_ARGS_ASSERT_CX_TOPBLOCK;
488
489 CX_DEBUG(cx, "TOP");
490 /* these 3 are common to cx_popblock and cx_topblock */
491 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
492 PL_scopestack_ix = cx->blk_oldscopesp;
493 PL_curpm = cx->blk_oldpm;
494
495 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
496}
497
498
a73d8813
DM
499PERL_STATIC_INLINE void
500S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
501{
502 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
503
504 PERL_ARGS_ASSERT_CX_PUSHSUB;
505
3f6bd23a 506 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
507 cx->blk_sub.cv = cv;
508 cx->blk_sub.olddepth = CvDEPTH(cv);
509 cx->blk_sub.prevcomppad = PL_comppad;
510 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
511 cx->blk_sub.retop = retop;
512 SvREFCNT_inc_simple_void_NN(cv);
513 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
514}
515
516
517/* subsets of cx_popsub() */
518
519PERL_STATIC_INLINE void
520S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
521{
522 CV *cv;
523
524 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
525 assert(CxTYPE(cx) == CXt_SUB);
526
527 PL_comppad = cx->blk_sub.prevcomppad;
528 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
529 cv = cx->blk_sub.cv;
530 CvDEPTH(cv) = cx->blk_sub.olddepth;
531 cx->blk_sub.cv = NULL;
532 SvREFCNT_dec(cv);
533}
534
535
536/* handle the @_ part of leaving a sub */
537
538PERL_STATIC_INLINE void
539S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
540{
541 AV *av;
542
543 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
544 assert(CxTYPE(cx) == CXt_SUB);
545 assert(AvARRAY(MUTABLE_AV(
546 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
547 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
548
549 CX_POP_SAVEARRAY(cx);
550 av = MUTABLE_AV(PAD_SVl(0));
551 if (UNLIKELY(AvREAL(av)))
552 /* abandon @_ if it got reified */
553 clear_defarray(av, 0);
554 else {
555 CLEAR_ARGARRAY(av);
556 }
557}
558
559
560PERL_STATIC_INLINE void
561S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
562{
563 PERL_ARGS_ASSERT_CX_POPSUB;
564 assert(CxTYPE(cx) == CXt_SUB);
565
3f6bd23a 566 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
567
568 if (CxHASARGS(cx))
569 cx_popsub_args(cx);
570 cx_popsub_common(cx);
571}
572
573
6a7d52cc
DM
574PERL_STATIC_INLINE void
575S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
576{
577 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
578
579 cx->blk_format.cv = cv;
580 cx->blk_format.retop = retop;
581 cx->blk_format.gv = gv;
582 cx->blk_format.dfoutgv = PL_defoutgv;
583 cx->blk_format.prevcomppad = PL_comppad;
584 cx->blk_u16 = 0;
585
586 SvREFCNT_inc_simple_void_NN(cv);
587 CvDEPTH(cv)++;
588 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
589}
590
591
592PERL_STATIC_INLINE void
593S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
594{
595 CV *cv;
596 GV *dfout;
597
598 PERL_ARGS_ASSERT_CX_POPFORMAT;
599 assert(CxTYPE(cx) == CXt_FORMAT);
600
601 dfout = cx->blk_format.dfoutgv;
602 setdefout(dfout);
603 cx->blk_format.dfoutgv = NULL;
604 SvREFCNT_dec_NN(dfout);
605
606 PL_comppad = cx->blk_format.prevcomppad;
607 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
608 cv = cx->blk_format.cv;
609 cx->blk_format.cv = NULL;
610 --CvDEPTH(cv);
611 SvREFCNT_dec_NN(cv);
612}
613
614
13febba5
DM
615PERL_STATIC_INLINE void
616S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
617{
618 PERL_ARGS_ASSERT_CX_PUSHEVAL;
619
620 cx->blk_eval.retop = retop;
621 cx->blk_eval.old_namesv = namesv;
622 cx->blk_eval.old_eval_root = PL_eval_root;
623 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
624 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
625 cx->blk_eval.cur_top_env = PL_top_env;
626
627 assert(!(PL_in_eval & ~ 0x7F));
628 assert(!(PL_op->op_type & ~0x1FF));
629 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
630}
631
632
633PERL_STATIC_INLINE void
634S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
635{
636 SV *sv;
637
638 PERL_ARGS_ASSERT_CX_POPEVAL;
639 assert(CxTYPE(cx) == CXt_EVAL);
640
641 PL_in_eval = CxOLD_IN_EVAL(cx);
642 PL_eval_root = cx->blk_eval.old_eval_root;
643 sv = cx->blk_eval.cur_text;
644 if (sv && SvSCREAM(sv)) {
645 cx->blk_eval.cur_text = NULL;
646 SvREFCNT_dec_NN(sv);
647 }
648
649 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
650 if (sv) {
651 cx->blk_eval.old_namesv = NULL;
652 SvREFCNT_dec_NN(sv);
653 }
13febba5 654}
6a7d52cc 655
a73d8813 656
d1b6bf72
DM
657/* push a plain loop, i.e.
658 * { block }
659 * while (cond) { block }
660 * for (init;cond;continue) { block }
661 * This loop can be last/redo'ed etc.
662 */
663
664PERL_STATIC_INLINE void
665S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
666{
667 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
668 cx->blk_loop.my_op = cLOOP;
669}
670
671
672/* push a true for loop, i.e.
673 * for var (list) { block }
674 */
675
676PERL_STATIC_INLINE void
677S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
678{
679 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
680
681 /* this one line is common with cx_pushloop_plain */
682 cx->blk_loop.my_op = cLOOP;
683
684 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
685 cx->blk_loop.itersave = itersave;
686#ifdef USE_ITHREADS
687 cx->blk_loop.oldcomppad = PL_comppad;
688#endif
689}
690
691
692/* pop all loop types, including plain */
693
694PERL_STATIC_INLINE void
695S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
696{
697 PERL_ARGS_ASSERT_CX_POPLOOP;
698
699 assert(CxTYPE_is_LOOP(cx));
700 if ( CxTYPE(cx) == CXt_LOOP_ARY
701 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
702 {
703 /* Free ary or cur. This assumes that state_u.ary.ary
704 * aligns with state_u.lazysv.cur. See cx_dup() */
705 SV *sv = cx->blk_loop.state_u.lazysv.cur;
706 cx->blk_loop.state_u.lazysv.cur = NULL;
707 SvREFCNT_dec_NN(sv);
708 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
709 sv = cx->blk_loop.state_u.lazysv.end;
710 cx->blk_loop.state_u.lazysv.end = NULL;
711 SvREFCNT_dec_NN(sv);
712 }
713 }
714 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
715 SV *cursv;
716 SV **svp = (cx)->blk_loop.itervar_u.svp;
717 if ((cx->cx_type & CXp_FOR_GV))
718 svp = &GvSV((GV*)svp);
719 cursv = *svp;
720 *svp = cx->blk_loop.itersave;
721 cx->blk_loop.itersave = NULL;
722 SvREFCNT_dec(cursv);
723 }
724}
725
2a7b7c61
DM
726
727PERL_STATIC_INLINE void
728S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
729{
730 PERL_ARGS_ASSERT_CX_PUSHWHEN;
731
732 cx->blk_givwhen.leave_op = cLOGOP->op_other;
733}
734
735
736PERL_STATIC_INLINE void
737S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
738{
739 PERL_ARGS_ASSERT_CX_POPWHEN;
740 assert(CxTYPE(cx) == CXt_WHEN);
741
742 PERL_UNUSED_ARG(cx);
59a14f30 743 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
744 /* currently NOOP */
745}
746
747
748PERL_STATIC_INLINE void
749S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
750{
751 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
752
753 cx->blk_givwhen.leave_op = cLOGOP->op_other;
754 cx->blk_givwhen.defsv_save = orig_defsv;
755}
756
757
758PERL_STATIC_INLINE void
759S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
760{
761 SV *sv;
762
763 PERL_ARGS_ASSERT_CX_POPGIVEN;
764 assert(CxTYPE(cx) == CXt_GIVEN);
765
766 sv = GvSV(PL_defgv);
767 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
768 cx->blk_givwhen.defsv_save = NULL;
769 SvREFCNT_dec(sv);
770}
771
772
773
774
ed382232 775/*
c8028aa6
TC
776 * ex: set ts=8 sts=4 sw=4 et:
777 */