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