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 /* ------------------------------- pp.h ------------------------------- */
 129
 130 PERL_STATIC_INLINE I32
 131 S_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
 140 PERL_STATIC_INLINE I32
 141 S_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
 151 /* ----------------------------- regexp.h ----------------------------- */
 152
 153 PERL_STATIC_INLINE struct regexp *
 154 S_ReANY(const REGEXP * const re)
 155 {
 156     assert(isREGEXP(re));
 157     return re->sv_u.svu_rx;
 158 }
 159
 160 /* ------------------------------- sv.h ------------------------------- */
 161
 162 PERL_STATIC_INLINE SV *
 163 S_SvREFCNT_inc(SV *sv)
 164 {
 165     if (LIKELY(sv != NULL))
 166         SvREFCNT(sv)++;
 167     return sv;
 168 }
 169 PERL_STATIC_INLINE SV *
 170 S_SvREFCNT_inc_NN(SV *sv)
 171 {
 172     SvREFCNT(sv)++;
 173     return sv;
 174 }
 175 PERL_STATIC_INLINE void
 176 S_SvREFCNT_inc_void(SV *sv)
 177 {
 178     if (LIKELY(sv != NULL))
 179         SvREFCNT(sv)++;
 180 }
 181 PERL_STATIC_INLINE void
 182 S_SvREFCNT_dec(pTHX_ SV *sv)
 183 {
 184     if (LIKELY(sv != NULL)) {
 185         U32 rc = SvREFCNT(sv);
 186         if (LIKELY(rc > 1))
 187             SvREFCNT(sv) = rc - 1;
 188         else
 189             Perl_sv_free2(aTHX_ sv, rc);
 190     }
 191 }
 192
 193 PERL_STATIC_INLINE void
 194 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
 195 {
 196     U32 rc = SvREFCNT(sv);
 197     if (LIKELY(rc > 1))
 198         SvREFCNT(sv) = rc - 1;
 199     else
 200         Perl_sv_free2(aTHX_ sv, rc);
 201 }
 202
 203 PERL_STATIC_INLINE void
 204 SvAMAGIC_on(SV *sv)
 205 {
 206     assert(SvROK(sv));
 207     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 208 }
 209 PERL_STATIC_INLINE void
 210 SvAMAGIC_off(SV *sv)
 211 {
 212     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
 213         HvAMAGIC_off(SvSTASH(SvRV(sv)));
 214 }
 215
 216 PERL_STATIC_INLINE U32
 217 S_SvPADSTALE_on(SV *sv)
 218 {
 219     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 220     return SvFLAGS(sv) |= SVs_PADSTALE;
 221 }
 222 PERL_STATIC_INLINE U32
 223 S_SvPADSTALE_off(SV *sv)
 224 {
 225     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 226     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 227 }
 228 #if defined(PERL_CORE) || defined (PERL_EXT)
 229 PERL_STATIC_INLINE STRLEN
 230 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 231 {
 232     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 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
 241
 242 /* ------------------------------- handy.h ------------------------------- */
 243
 244 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 245 #ifdef GCC_DIAG_PRAGMA
 246 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
 247 #endif
 248 static void
 249 S_croak_memory_wrap(void)
 250 {
 251     Perl_croak_nocontext("%s",PL_memory_wrap);
 252 }
 253 #ifdef GCC_DIAG_PRAGMA
 254 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
 255 #endif
 256
 257 /* ------------------------------- utf8.h ------------------------------- */
 258
 259 PERL_STATIC_INLINE void
 260 S_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
 265     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 266
 267     if (NATIVE_BYTE_IS_INVARIANT(byte))
 268         *(*dest)++ = byte;
 269     else {
 270         *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
 271         *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
 272     }
 273 }
 274
 275 /*
 276
 277 A helper function for the macro isUTF8_CHAR(), which should be used instead of
 278 this function.  The macro will handle smaller code points directly saving time,
 279 using this function as a fall-back for higher code points.
 280
 281 Tests if the first bytes of string C<s> form a valid UTF-8 character.  0 is
 282 returned if the bytes starting at C<s> up to but not including C<e> do not form a
 283 complete well-formed UTF-8 character; otherwise the number of bytes in the
 284 character is returned.
 285
 286 Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
 287 character.
 288
 289 =cut */
 290 PERL_STATIC_INLINE STRLEN
 291 S__is_utf8_char_slow(const U8 *s, const U8 *e)
 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
 299     assert(e >= s);
 300     utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
 301
 302     return (actual_len == (STRLEN) -1) ? 0 : actual_len;
 303 }
 304
 305 /* ------------------------------- perl.h ----------------------------- */
 306
 307 /*
 308 =head1 Miscellaneous Functions
 309
 310 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 311
 312 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
 313 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
 314
 315 Return TRUE if the name is safe.
 316
 317 Used by the C<IS_SAFE_SYSCALL()> macro.
 318
 319 =cut
 320 */
 321
 322 PERL_STATIC_INLINE bool
 323 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
 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
 330     if (len > 1) {
 331         char *null_at;
 332         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
 333                 SETERRNO(ENOENT, LIB_INVARG);
 334                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
 335                                    "Invalid \\0 character in %s for %s: %s\\0%s",
 336                                    what, op_name, pv, null_at+1);
 337                 return FALSE;
 338         }
 339     }
 340
 341     return TRUE;
 342 }
 343
 344 /*
 345
 346 Return true if the supplied filename has a newline character
 347 immediately before the first (hopefully only) NUL.
 348
 349 My original look at this incorrectly used the len from SvPV(), but
 350 that's incorrect, since we allow for a NUL in pv[len-1].
 351
 352 So instead, strlen() and work from there.
 353
 354 This allow for the user reading a filename, forgetting to chomp it,
 355 then calling:
 356
 357   open my $foo, "$file\0";
 358
 359 */
 360
 361 #ifdef PERL_CORE
 362
 363 PERL_STATIC_INLINE bool
 364 S_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
 376 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 377
 378 #define MAX_CHARSET_NAME_LENGTH 2
 379
 380 PERL_STATIC_INLINE const char *
 381 get_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
 403 /*
 404
 405 Return false if any get magic is on the SV other than taint magic.
 406
 407 */
 408
 409 PERL_STATIC_INLINE bool
 410 S_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
 427 /* ------------------ cop.h ------------------------------------------- */
 428
 429
 430 /* Enter a block. Push a new base context and return its address. */
 431
 432 PERL_STATIC_INLINE PERL_CONTEXT *
 433 S_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;
 444     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
 445     cx->blk_oldcop     = PL_curcop;
 446     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
 447     cx->blk_oldscopesp = PL_scopestack_ix;
 448     cx->blk_oldpm      = PL_curpm;
 449     cx->blk_old_tmpsfloor = PL_tmps_floor;
 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
 459 PERL_STATIC_INLINE void
 460 S_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;
 476     PL_tmps_floor = cx->blk_old_tmpsfloor;
 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
 484 PERL_STATIC_INLINE void
 485 S_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
 499 PERL_STATIC_INLINE void
 500 S_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
 506     PERL_DTRACE_PROBE_ENTRY(cv);
 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
 519 PERL_STATIC_INLINE void
 520 S_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
 538 PERL_STATIC_INLINE void
 539 S_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
 560 PERL_STATIC_INLINE void
 561 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 562 {
 563     PERL_ARGS_ASSERT_CX_POPSUB;
 564     assert(CxTYPE(cx) == CXt_SUB);
 565
 566     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
 567
 568     if (CxHASARGS(cx))
 569         cx_popsub_args(cx);
 570     cx_popsub_common(cx);
 571 }
 572
 573
 574 PERL_STATIC_INLINE void
 575 S_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
 592 PERL_STATIC_INLINE void
 593 S_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
 615 PERL_STATIC_INLINE void
 616 S_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
 633 PERL_STATIC_INLINE void
 634 S_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;
 650     if (sv) {
 651         cx->blk_eval.old_namesv = NULL;
 652         SvREFCNT_dec_NN(sv);
 653     }
 654 }
 655
 656
 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
 664 PERL_STATIC_INLINE void
 665 S_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
 676 PERL_STATIC_INLINE void
 677 S_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
 694 PERL_STATIC_INLINE void
 695 S_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
 726
 727 PERL_STATIC_INLINE void
 728 S_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
 736 PERL_STATIC_INLINE void
 737 S_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);
 743     PERL_UNUSED_CONTEXT;
 744     /* currently NOOP */
 745 }
 746
 747
 748 PERL_STATIC_INLINE void
 749 S_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
 758 PERL_STATIC_INLINE void
 759 S_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
 775 /*
 776  * ex: set ts=8 sts=4 sw=4 et:
 777  */