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 first (hopefully only) 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 = (I32)(sp - PL_stack_base); 422 cx->blk_oldcop = PL_curcop; 423 cx->blk_oldmarksp = (I32)(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 PERL_DTRACE_PROBE_ENTRY(cv); 484 cx->blk_sub.cv = cv; 485 cx->blk_sub.olddepth = CvDEPTH(cv); 486 cx->blk_sub.prevcomppad = PL_comppad; 487 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; 488 cx->blk_sub.retop = retop; 489 SvREFCNT_inc_simple_void_NN(cv); 490 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF); 491 } 492 493 494 /* subsets of cx_popsub() */ 495 496 PERL_STATIC_INLINE void 497 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx) 498 { 499 CV *cv; 500 501 PERL_ARGS_ASSERT_CX_POPSUB_COMMON; 502 assert(CxTYPE(cx) == CXt_SUB); 503 504 PL_comppad = cx->blk_sub.prevcomppad; 505 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; 506 cv = cx->blk_sub.cv; 507 CvDEPTH(cv) = cx->blk_sub.olddepth; 508 cx->blk_sub.cv = NULL; 509 SvREFCNT_dec(cv); 510 } 511 512 513 /* handle the @_ part of leaving a sub */ 514 515 PERL_STATIC_INLINE void 516 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx) 517 { 518 AV *av; 519 520 PERL_ARGS_ASSERT_CX_POPSUB_ARGS; 521 assert(CxTYPE(cx) == CXt_SUB); 522 assert(AvARRAY(MUTABLE_AV( 523 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ 524 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); 525 526 CX_POP_SAVEARRAY(cx); 527 av = MUTABLE_AV(PAD_SVl(0)); 528 if (UNLIKELY(AvREAL(av))) 529 /* abandon @_ if it got reified */ 530 clear_defarray(av, 0); 531 else { 532 CLEAR_ARGARRAY(av); 533 } 534 } 535 536 537 PERL_STATIC_INLINE void 538 S_cx_popsub(pTHX_ PERL_CONTEXT *cx) 539 { 540 PERL_ARGS_ASSERT_CX_POPSUB; 541 assert(CxTYPE(cx) == CXt_SUB); 542 543 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv); 544 545 if (CxHASARGS(cx)) 546 cx_popsub_args(cx); 547 cx_popsub_common(cx); 548 } 549 550 551 PERL_STATIC_INLINE void 552 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv) 553 { 554 PERL_ARGS_ASSERT_CX_PUSHFORMAT; 555 556 cx->blk_format.cv = cv; 557 cx->blk_format.retop = retop; 558 cx->blk_format.gv = gv; 559 cx->blk_format.dfoutgv = PL_defoutgv; 560 cx->blk_format.prevcomppad = PL_comppad; 561 cx->blk_u16 = 0; 562 563 SvREFCNT_inc_simple_void_NN(cv); 564 CvDEPTH(cv)++; 565 SvREFCNT_inc_void(cx->blk_format.dfoutgv); 566 } 567 568 569 PERL_STATIC_INLINE void 570 S_cx_popformat(pTHX_ PERL_CONTEXT *cx) 571 { 572 CV *cv; 573 GV *dfout; 574 575 PERL_ARGS_ASSERT_CX_POPFORMAT; 576 assert(CxTYPE(cx) == CXt_FORMAT); 577 578 dfout = cx->blk_format.dfoutgv; 579 setdefout(dfout); 580 cx->blk_format.dfoutgv = NULL; 581 SvREFCNT_dec_NN(dfout); 582 583 PL_comppad = cx->blk_format.prevcomppad; 584 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; 585 cv = cx->blk_format.cv; 586 cx->blk_format.cv = NULL; 587 --CvDEPTH(cv); 588 SvREFCNT_dec_NN(cv); 589 } 590 591 592 PERL_STATIC_INLINE void 593 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv) 594 { 595 PERL_ARGS_ASSERT_CX_PUSHEVAL; 596 597 cx->blk_eval.retop = retop; 598 cx->blk_eval.old_namesv = namesv; 599 cx->blk_eval.old_eval_root = PL_eval_root; 600 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL; 601 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */ 602 cx->blk_eval.cur_top_env = PL_top_env; 603 604 assert(!(PL_in_eval & ~ 0x7F)); 605 assert(!(PL_op->op_type & ~0x1FF)); 606 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); 607 } 608 609 610 PERL_STATIC_INLINE void 611 S_cx_popeval(pTHX_ PERL_CONTEXT *cx) 612 { 613 SV *sv; 614 615 PERL_ARGS_ASSERT_CX_POPEVAL; 616 assert(CxTYPE(cx) == CXt_EVAL); 617 618 PL_in_eval = CxOLD_IN_EVAL(cx); 619 PL_eval_root = cx->blk_eval.old_eval_root; 620 sv = cx->blk_eval.cur_text; 621 if (sv && SvSCREAM(sv)) { 622 cx->blk_eval.cur_text = NULL; 623 SvREFCNT_dec_NN(sv); 624 } 625 626 sv = cx->blk_eval.old_namesv; 627 if (sv && !SvTEMP(sv))/* TEMP implies cx_popeval() re-entrantly called */ 628 sv_2mortal(sv); 629 } 630 631 632 /* push a plain loop, i.e. 633 * { block } 634 * while (cond) { block } 635 * for (init;cond;continue) { block } 636 * This loop can be last/redo'ed etc. 637 */ 638 639 PERL_STATIC_INLINE void 640 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx) 641 { 642 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN; 643 cx->blk_loop.my_op = cLOOP; 644 } 645 646 647 /* push a true for loop, i.e. 648 * for var (list) { block } 649 */ 650 651 PERL_STATIC_INLINE void 652 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave) 653 { 654 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR; 655 656 /* this one line is common with cx_pushloop_plain */ 657 cx->blk_loop.my_op = cLOOP; 658 659 cx->blk_loop.itervar_u.svp = (SV**)itervarp; 660 cx->blk_loop.itersave = itersave; 661 #ifdef USE_ITHREADS 662 cx->blk_loop.oldcomppad = PL_comppad; 663 #endif 664 } 665 666 667 /* pop all loop types, including plain */ 668 669 PERL_STATIC_INLINE void 670 S_cx_poploop(pTHX_ PERL_CONTEXT *cx) 671 { 672 PERL_ARGS_ASSERT_CX_POPLOOP; 673 674 assert(CxTYPE_is_LOOP(cx)); 675 if ( CxTYPE(cx) == CXt_LOOP_ARY 676 || CxTYPE(cx) == CXt_LOOP_LAZYSV) 677 { 678 /* Free ary or cur. This assumes that state_u.ary.ary 679 * aligns with state_u.lazysv.cur. See cx_dup() */ 680 SV *sv = cx->blk_loop.state_u.lazysv.cur; 681 cx->blk_loop.state_u.lazysv.cur = NULL; 682 SvREFCNT_dec_NN(sv); 683 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { 684 sv = cx->blk_loop.state_u.lazysv.end; 685 cx->blk_loop.state_u.lazysv.end = NULL; 686 SvREFCNT_dec_NN(sv); 687 } 688 } 689 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) { 690 SV *cursv; 691 SV **svp = (cx)->blk_loop.itervar_u.svp; 692 if ((cx->cx_type & CXp_FOR_GV)) 693 svp = &GvSV((GV*)svp); 694 cursv = *svp; 695 *svp = cx->blk_loop.itersave; 696 cx->blk_loop.itersave = NULL; 697 SvREFCNT_dec(cursv); 698 } 699 } 700 701 702 PERL_STATIC_INLINE void 703 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx) 704 { 705 PERL_ARGS_ASSERT_CX_PUSHWHEN; 706 707 cx->blk_givwhen.leave_op = cLOGOP->op_other; 708 } 709 710 711 PERL_STATIC_INLINE void 712 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx) 713 { 714 PERL_ARGS_ASSERT_CX_POPWHEN; 715 assert(CxTYPE(cx) == CXt_WHEN); 716 717 PERL_UNUSED_ARG(cx); 718 /* currently NOOP */ 719 } 720 721 722 PERL_STATIC_INLINE void 723 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv) 724 { 725 PERL_ARGS_ASSERT_CX_PUSHGIVEN; 726 727 cx->blk_givwhen.leave_op = cLOGOP->op_other; 728 cx->blk_givwhen.defsv_save = orig_defsv; 729 } 730 731 732 PERL_STATIC_INLINE void 733 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx) 734 { 735 SV *sv; 736 737 PERL_ARGS_ASSERT_CX_POPGIVEN; 738 assert(CxTYPE(cx) == CXt_GIVEN); 739 740 sv = GvSV(PL_defgv); 741 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save; 742 cx->blk_givwhen.defsv_save = NULL; 743 SvREFCNT_dec(sv); 744 } 745 746 747 748 749 /* 750 * ex: set ts=8 sts=4 sw=4 et: 751 */ 752