inline.h

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