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