1 /* scope.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * For the fashion of Minas Tirith was such that it was built on seven 13 * levels... 14 * 15 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"] 16 */ 17 18 /* This file contains functions to manipulate several of Perl's stacks; 19 * in particular it contains code to push various types of things onto 20 * the savestack, then to pop them off and perform the correct restorative 21 * action for each one. This corresponds to the cleanup Perl does at 22 * each scope exit. 23 */ 24 25 #include "EXTERN.h" 26 #define PERL_IN_SCOPE_C 27 #include "perl.h" 28 29 SV** 30 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) 31 { 32 SSize_t extra; 33 SSize_t current = (p - PL_stack_base); 34 35 PERL_ARGS_ASSERT_STACK_GROW; 36 37 if (UNLIKELY(n < 0)) 38 Perl_croak(aTHX_ 39 "panic: stack_grow() negative count (%"IVdf")", (IV)n); 40 41 PL_stack_sp = sp; 42 extra = 43 #ifdef STRESS_REALLOC 44 1; 45 #else 46 128; 47 #endif 48 /* If the total might wrap, panic instead. This is really testing 49 * that (current + n + extra < SSize_t_MAX), but done in a way that 50 * can't wrap */ 51 if (UNLIKELY( current > SSize_t_MAX - extra 52 || current + extra > SSize_t_MAX - n 53 )) 54 /* diag_listed_as: Out of memory during %s extend */ 55 Perl_croak(aTHX_ "Out of memory during stack extend"); 56 57 av_extend(PL_curstack, current + n + extra); 58 return PL_stack_sp; 59 } 60 61 #ifndef STRESS_REALLOC 62 #define GROW(old) ((old) * 3 / 2) 63 #else 64 #define GROW(old) ((old) + 1) 65 #endif 66 67 PERL_SI * 68 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) 69 { 70 PERL_SI *si; 71 Newx(si, 1, PERL_SI); 72 si->si_stack = newAV(); 73 AvREAL_off(si->si_stack); 74 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); 75 AvALLOC(si->si_stack)[0] = &PL_sv_undef; 76 AvFILLp(si->si_stack) = 0; 77 si->si_prev = 0; 78 si->si_next = 0; 79 si->si_cxmax = cxitems - 1; 80 si->si_cxix = -1; 81 si->si_type = PERLSI_UNDEF; 82 Newx(si->si_cxstack, cxitems, PERL_CONTEXT); 83 /* Without any kind of initialising CX_PUSHSUBST() 84 * in pp_subst() will read uninitialised heap. */ 85 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT); 86 return si; 87 } 88 89 I32 90 Perl_cxinc(pTHX) 91 { 92 const IV old_max = cxstack_max; 93 cxstack_max = GROW(cxstack_max); 94 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); 95 /* Without any kind of initialising deep enough recursion 96 * will end up reading uninitialised PERL_CONTEXTs. */ 97 PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT); 98 return cxstack_ix + 1; 99 } 100 101 void 102 Perl_push_scope(pTHX) 103 { 104 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) { 105 PL_scopestack_max = GROW(PL_scopestack_max); 106 Renew(PL_scopestack, PL_scopestack_max, I32); 107 #ifdef DEBUGGING 108 Renew(PL_scopestack_name, PL_scopestack_max, const char*); 109 #endif 110 } 111 #ifdef DEBUGGING 112 PL_scopestack_name[PL_scopestack_ix] = "unknown"; 113 #endif 114 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; 115 116 } 117 118 void 119 Perl_pop_scope(pTHX) 120 { 121 const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; 122 LEAVE_SCOPE(oldsave); 123 } 124 125 I32 * 126 Perl_markstack_grow(pTHX) 127 { 128 const I32 oldmax = PL_markstack_max - PL_markstack; 129 const I32 newmax = GROW(oldmax); 130 131 Renew(PL_markstack, newmax, I32); 132 PL_markstack_max = PL_markstack + newmax; 133 PL_markstack_ptr = PL_markstack + oldmax; 134 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, 135 "MARK grow %p %"IVdf" by %"IVdf"\n", 136 PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax))); 137 return PL_markstack_ptr; 138 } 139 140 void 141 Perl_savestack_grow(pTHX) 142 { 143 PL_savestack_max = GROW(PL_savestack_max); 144 /* Note that we allocate SS_MAXPUSH slots higher than ss_max 145 * so that SS_ADD_END(), SSGROW() etc can do a simper check */ 146 Renew(PL_savestack, PL_savestack_max + SS_MAXPUSH, ANY); 147 } 148 149 void 150 Perl_savestack_grow_cnt(pTHX_ I32 need) 151 { 152 PL_savestack_max = PL_savestack_ix + need; 153 /* Note that we allocate SS_MAXPUSH slots higher than ss_max 154 * so that SS_ADD_END(), SSGROW() etc can do a simper check */ 155 Renew(PL_savestack, PL_savestack_max + SS_MAXPUSH, ANY); 156 } 157 158 #undef GROW 159 160 /* The original function was called Perl_tmps_grow and was removed from public 161 API, Perl_tmps_grow_p is the replacement and it used in public macros but 162 isn't public itself. 163 164 Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by, 165 where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max 166 Upon return, PL_tmps_stack[ix] will be a valid address. For machine code 167 optimization and register usage reasons, the proposed ix passed into 168 tmps_grow is returned to the caller which the caller can then use to write 169 an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in 170 pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of 171 tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller 172 must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is 173 appropriate. The assignment to PL_temps_ix can happen before or after 174 tmps_grow call since tmps_grow doesn't look at PL_tmps_ix. 175 */ 176 177 SSize_t 178 Perl_tmps_grow_p(pTHX_ SSize_t ix) 179 { 180 SSize_t extend_to = ix; 181 #ifndef STRESS_REALLOC 182 if (ix - PL_tmps_max < 128) 183 extend_to += (PL_tmps_max < 512) ? 128 : 512; 184 #endif 185 PL_tmps_max = extend_to + 1; 186 Renew(PL_tmps_stack, PL_tmps_max, SV*); 187 return ix; 188 } 189 190 191 void 192 Perl_free_tmps(pTHX) 193 { 194 /* XXX should tmps_floor live in cxstack? */ 195 const SSize_t myfloor = PL_tmps_floor; 196 while (PL_tmps_ix > myfloor) { /* clean up after last statement */ 197 SV* const sv = PL_tmps_stack[PL_tmps_ix--]; 198 #ifdef PERL_POISON 199 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); 200 #endif 201 if (LIKELY(sv)) { 202 SvTEMP_off(sv); 203 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ 204 } 205 } 206 } 207 208 STATIC SV * 209 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) 210 { 211 SV * osv; 212 SV *sv; 213 214 PERL_ARGS_ASSERT_SAVE_SCALAR_AT; 215 216 osv = *sptr; 217 if (flags & SAVEf_KEEPOLDELEM) 218 sv = osv; 219 else { 220 sv = (*sptr = newSV(0)); 221 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) 222 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC)); 223 } 224 225 return sv; 226 } 227 228 void 229 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) 230 { 231 dSS_ADD; 232 SS_ADD_PTR(ptr1); 233 SS_ADD_PTR(ptr2); 234 SS_ADD_UV(type); 235 SS_ADD_END(3); 236 } 237 238 SV * 239 Perl_save_scalar(pTHX_ GV *gv) 240 { 241 SV ** const sptr = &GvSVn(gv); 242 243 PERL_ARGS_ASSERT_SAVE_SCALAR; 244 245 if (UNLIKELY(SvGMAGICAL(*sptr))) { 246 PL_localizing = 1; 247 (void)mg_get(*sptr); 248 PL_localizing = 0; 249 } 250 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV); 251 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 252 } 253 254 /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to 255 * restore a global SV to its prior contents, freeing new value. */ 256 void 257 Perl_save_generic_svref(pTHX_ SV **sptr) 258 { 259 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; 260 261 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); 262 } 263 264 /* Like save_pptr(), but also Safefree()s the new value if it is different 265 * from the old one. Can be used to restore a global char* to its prior 266 * contents, freeing new value. */ 267 void 268 Perl_save_generic_pvref(pTHX_ char **str) 269 { 270 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; 271 272 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); 273 } 274 275 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). 276 * Can be used to restore a shared global char* to its prior 277 * contents, freeing new value. */ 278 void 279 Perl_save_shared_pvref(pTHX_ char **str) 280 { 281 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; 282 283 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); 284 } 285 286 /* set the SvFLAGS specified by mask to the values in val */ 287 288 void 289 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) 290 { 291 dSS_ADD; 292 293 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; 294 295 SS_ADD_PTR(sv); 296 SS_ADD_INT(mask); 297 SS_ADD_INT(val); 298 SS_ADD_UV(SAVEt_SET_SVFLAGS); 299 SS_ADD_END(4); 300 } 301 302 /* 303 =for apidoc save_gp 304 305 Saves the current GP of gv on the save stack to be restored on scope exit. 306 307 If empty is true, replace the GP with a new GP. 308 309 If empty is false, mark gv with GVf_INTRO so the next reference 310 assigned is localized, which is how C< local *foo = $someref; > works. 311 312 =cut 313 */ 314 315 void 316 Perl_save_gp(pTHX_ GV *gv, I32 empty) 317 { 318 PERL_ARGS_ASSERT_SAVE_GP; 319 320 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); 321 322 if (empty) { 323 GP *gp = Perl_newGP(aTHX_ gv); 324 HV * const stash = GvSTASH(gv); 325 bool isa_changed = 0; 326 327 if (stash && HvENAME(stash)) { 328 if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3)) 329 isa_changed = TRUE; 330 else if (GvCVu(gv)) 331 /* taking a method out of circulation ("local")*/ 332 mro_method_changed_in(stash); 333 } 334 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { 335 gp->gp_io = newIO(); 336 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; 337 } 338 GvGP_set(gv,gp); 339 if (isa_changed) mro_isa_changed_in(stash); 340 } 341 else { 342 gp_ref(GvGP(gv)); 343 GvINTRO_on(gv); 344 } 345 } 346 347 AV * 348 Perl_save_ary(pTHX_ GV *gv) 349 { 350 AV * const oav = GvAVn(gv); 351 AV *av; 352 353 PERL_ARGS_ASSERT_SAVE_ARY; 354 355 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav))) 356 av_reify(oav); 357 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV); 358 359 GvAV(gv) = NULL; 360 av = GvAVn(gv); 361 if (UNLIKELY(SvMAGIC(oav))) 362 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); 363 return av; 364 } 365 366 HV * 367 Perl_save_hash(pTHX_ GV *gv) 368 { 369 HV *ohv, *hv; 370 371 PERL_ARGS_ASSERT_SAVE_HASH; 372 373 save_pushptrptr( 374 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV 375 ); 376 377 GvHV(gv) = NULL; 378 hv = GvHVn(gv); 379 if (UNLIKELY(SvMAGIC(ohv))) 380 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); 381 return hv; 382 } 383 384 void 385 Perl_save_item(pTHX_ SV *item) 386 { 387 SV * const sv = newSVsv(item); 388 389 PERL_ARGS_ASSERT_SAVE_ITEM; 390 391 save_pushptrptr(item, /* remember the pointer */ 392 sv, /* remember the value */ 393 SAVEt_ITEM); 394 } 395 396 void 397 Perl_save_bool(pTHX_ bool *boolp) 398 { 399 dSS_ADD; 400 401 PERL_ARGS_ASSERT_SAVE_BOOL; 402 403 SS_ADD_PTR(boolp); 404 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8)); 405 SS_ADD_END(2); 406 } 407 408 void 409 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) 410 { 411 dSS_ADD; 412 413 SS_ADD_INT(i); 414 SS_ADD_PTR(ptr); 415 SS_ADD_UV(type); 416 SS_ADD_END(3); 417 } 418 419 void 420 Perl_save_int(pTHX_ int *intp) 421 { 422 const int i = *intp; 423 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL); 424 int size = 2; 425 dSS_ADD; 426 427 PERL_ARGS_ASSERT_SAVE_INT; 428 429 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) { 430 SS_ADD_INT(i); 431 type = SAVEt_INT; 432 size++; 433 } 434 SS_ADD_PTR(intp); 435 SS_ADD_UV(type); 436 SS_ADD_END(size); 437 } 438 439 void 440 Perl_save_I8(pTHX_ I8 *bytep) 441 { 442 dSS_ADD; 443 444 PERL_ARGS_ASSERT_SAVE_I8; 445 446 SS_ADD_PTR(bytep); 447 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8)); 448 SS_ADD_END(2); 449 } 450 451 void 452 Perl_save_I16(pTHX_ I16 *intp) 453 { 454 dSS_ADD; 455 456 PERL_ARGS_ASSERT_SAVE_I16; 457 458 SS_ADD_PTR(intp); 459 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8)); 460 SS_ADD_END(2); 461 } 462 463 void 464 Perl_save_I32(pTHX_ I32 *intp) 465 { 466 const I32 i = *intp; 467 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL); 468 int size = 2; 469 dSS_ADD; 470 471 PERL_ARGS_ASSERT_SAVE_I32; 472 473 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) { 474 SS_ADD_INT(i); 475 type = SAVEt_I32; 476 size++; 477 } 478 SS_ADD_PTR(intp); 479 SS_ADD_UV(type); 480 SS_ADD_END(size); 481 } 482 483 void 484 Perl_save_strlen(pTHX_ STRLEN *ptr) 485 { 486 dSS_ADD; 487 488 PERL_ARGS_ASSERT_SAVE_STRLEN; 489 490 SS_ADD_IV(*ptr); 491 SS_ADD_PTR(ptr); 492 SS_ADD_UV(SAVEt_STRLEN); 493 SS_ADD_END(3); 494 } 495 496 /* Cannot use save_sptr() to store a char* since the SV** cast will 497 * force word-alignment and we'll miss the pointer. 498 */ 499 void 500 Perl_save_pptr(pTHX_ char **pptr) 501 { 502 PERL_ARGS_ASSERT_SAVE_PPTR; 503 504 save_pushptrptr(*pptr, pptr, SAVEt_PPTR); 505 } 506 507 void 508 Perl_save_vptr(pTHX_ void *ptr) 509 { 510 PERL_ARGS_ASSERT_SAVE_VPTR; 511 512 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); 513 } 514 515 void 516 Perl_save_sptr(pTHX_ SV **sptr) 517 { 518 PERL_ARGS_ASSERT_SAVE_SPTR; 519 520 save_pushptrptr(*sptr, sptr, SAVEt_SPTR); 521 } 522 523 void 524 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) 525 { 526 dSS_ADD; 527 528 ASSERT_CURPAD_ACTIVE("save_padsv"); 529 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off])); 530 SS_ADD_PTR(PL_comppad); 531 SS_ADD_UV((UV)off); 532 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE); 533 SS_ADD_END(4); 534 } 535 536 void 537 Perl_save_hptr(pTHX_ HV **hptr) 538 { 539 PERL_ARGS_ASSERT_SAVE_HPTR; 540 541 save_pushptrptr(*hptr, hptr, SAVEt_HPTR); 542 } 543 544 void 545 Perl_save_aptr(pTHX_ AV **aptr) 546 { 547 PERL_ARGS_ASSERT_SAVE_APTR; 548 549 save_pushptrptr(*aptr, aptr, SAVEt_APTR); 550 } 551 552 void 553 Perl_save_pushptr(pTHX_ void *const ptr, const int type) 554 { 555 dSS_ADD; 556 SS_ADD_PTR(ptr); 557 SS_ADD_UV(type); 558 SS_ADD_END(2); 559 } 560 561 void 562 Perl_save_clearsv(pTHX_ SV **svp) 563 { 564 const UV offset = svp - PL_curpad; 565 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT; 566 567 PERL_ARGS_ASSERT_SAVE_CLEARSV; 568 569 ASSERT_CURPAD_ACTIVE("save_clearsv"); 570 SvPADSTALE_off(*svp); /* mark lexical as active */ 571 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) { 572 Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)", 573 offset, svp, PL_curpad); 574 } 575 576 { 577 dSS_ADD; 578 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV); 579 SS_ADD_END(1); 580 } 581 } 582 583 void 584 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) 585 { 586 PERL_ARGS_ASSERT_SAVE_DELETE; 587 588 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); 589 } 590 591 void 592 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) 593 { 594 STRLEN len; 595 I32 klen; 596 const char *key; 597 598 PERL_ARGS_ASSERT_SAVE_HDELETE; 599 600 key = SvPV_const(keysv, len); 601 klen = SvUTF8(keysv) ? -(I32)len : (I32)len; 602 SvREFCNT_inc_simple_void_NN(hv); 603 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE); 604 } 605 606 void 607 Perl_save_adelete(pTHX_ AV *av, SSize_t key) 608 { 609 dSS_ADD; 610 611 PERL_ARGS_ASSERT_SAVE_ADELETE; 612 613 SvREFCNT_inc_void(av); 614 SS_ADD_UV(key); 615 SS_ADD_PTR(av); 616 SS_ADD_IV(SAVEt_ADELETE); 617 SS_ADD_END(3); 618 } 619 620 void 621 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) 622 { 623 dSS_ADD; 624 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; 625 626 SS_ADD_DPTR(f); 627 SS_ADD_PTR(p); 628 SS_ADD_UV(SAVEt_DESTRUCTOR); 629 SS_ADD_END(3); 630 } 631 632 void 633 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) 634 { 635 dSS_ADD; 636 637 SS_ADD_DXPTR(f); 638 SS_ADD_PTR(p); 639 SS_ADD_UV(SAVEt_DESTRUCTOR_X); 640 SS_ADD_END(3); 641 } 642 643 void 644 Perl_save_hints(pTHX) 645 { 646 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); 647 if (PL_hints & HINT_LOCALIZE_HH) { 648 HV *oldhh = GvHV(PL_hintgv); 649 save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS); 650 GvHV(PL_hintgv) = NULL; /* in case copying dies */ 651 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh); 652 } else { 653 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS); 654 } 655 } 656 657 static void 658 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, 659 const int type) 660 { 661 dSS_ADD; 662 SS_ADD_PTR(ptr1); 663 SS_ADD_INT(i); 664 SS_ADD_PTR(ptr2); 665 SS_ADD_UV(type); 666 SS_ADD_END(4); 667 } 668 669 void 670 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, 671 const U32 flags) 672 { 673 dSS_ADD; 674 SV *sv; 675 676 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; 677 678 SvGETMAGIC(*sptr); 679 SS_ADD_PTR(SvREFCNT_inc_simple(av)); 680 SS_ADD_IV(idx); 681 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 682 SS_ADD_UV(SAVEt_AELEM); 683 SS_ADD_END(4); 684 /* The array needs to hold a reference count on its new element, so it 685 must be AvREAL. */ 686 if (UNLIKELY(!AvREAL(av) && AvREIFY(av))) 687 av_reify(av); 688 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ 689 if (flags & SAVEf_KEEPOLDELEM) 690 return; 691 sv = *sptr; 692 /* If we're localizing a tied array element, this new sv 693 * won't actually be stored in the array - so it won't get 694 * reaped when the localize ends. Ensure it gets reaped by 695 * mortifying it instead. DAPM */ 696 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) 697 sv_2mortal(sv); 698 } 699 700 void 701 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) 702 { 703 SV *sv; 704 705 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS; 706 707 SvGETMAGIC(*sptr); 708 { 709 dSS_ADD; 710 SS_ADD_PTR(SvREFCNT_inc_simple(hv)); 711 SS_ADD_PTR(newSVsv(key)); 712 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 713 SS_ADD_UV(SAVEt_HELEM); 714 SS_ADD_END(4); 715 } 716 save_scalar_at(sptr, flags); 717 if (flags & SAVEf_KEEPOLDELEM) 718 return; 719 sv = *sptr; 720 /* If we're localizing a tied hash element, this new sv 721 * won't actually be stored in the hash - so it won't get 722 * reaped when the localize ends. Ensure it gets reaped by 723 * mortifying it instead. DAPM */ 724 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))) 725 sv_2mortal(sv); 726 } 727 728 SV* 729 Perl_save_svref(pTHX_ SV **sptr) 730 { 731 PERL_ARGS_ASSERT_SAVE_SVREF; 732 733 SvGETMAGIC(*sptr); 734 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF); 735 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 736 } 737 738 739 void 740 Perl_savetmps(pTHX) 741 { 742 dSS_ADD; 743 SS_ADD_IV(PL_tmps_floor); 744 PL_tmps_floor = PL_tmps_ix; 745 SS_ADD_UV(SAVEt_TMPSFLOOR); 746 SS_ADD_END(2); 747 } 748 749 750 I32 751 Perl_save_alloc(pTHX_ I32 size, I32 pad) 752 { 753 const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] 754 - (char*)PL_savestack); 755 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); 756 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT; 757 758 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)) 759 Perl_croak(aTHX_ 760 "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")", 761 elems, (IV)size, (IV)pad); 762 763 SSGROW(elems + 1); 764 765 PL_savestack_ix += elems; 766 SSPUSHUV(SAVEt_ALLOC | elems_shifted); 767 return start; 768 } 769 770 771 772 #define ARG0_SV MUTABLE_SV(arg0.any_ptr) 773 #define ARG0_AV MUTABLE_AV(arg0.any_ptr) 774 #define ARG0_HV MUTABLE_HV(arg0.any_ptr) 775 #define ARG0_PTR arg0.any_ptr 776 #define ARG0_PV (char*)(arg0.any_ptr) 777 #define ARG0_PVP (char**)(arg0.any_ptr) 778 #define ARG0_I32 (arg0.any_i32) 779 780 #define ARG1_SV MUTABLE_SV(arg1.any_ptr) 781 #define ARG1_AV MUTABLE_AV(arg1.any_ptr) 782 #define ARG1_GV MUTABLE_GV(arg1.any_ptr) 783 #define ARG1_SVP (SV**)(arg1.any_ptr) 784 #define ARG1_PVP (char**)(arg1.any_ptr) 785 #define ARG1_PTR arg1.any_ptr 786 #define ARG1_PV (char*)(arg1.any_ptr) 787 #define ARG1_I32 (arg1.any_i32) 788 789 #define ARG2_SV MUTABLE_SV(arg2.any_ptr) 790 #define ARG2_AV MUTABLE_AV(arg2.any_ptr) 791 #define ARG2_HV MUTABLE_HV(arg2.any_ptr) 792 #define ARG2_GV MUTABLE_GV(arg2.any_ptr) 793 #define ARG2_PV (char*)(arg2.any_ptr) 794 795 void 796 Perl_leave_scope(pTHX_ I32 base) 797 { 798 /* Localise the effects of the TAINT_NOT inside the loop. */ 799 bool was = TAINT_get; 800 801 I32 i; 802 SV *sv; 803 804 ANY arg0, arg1, arg2; 805 806 /* these initialisations are logically unnecessary, but they shut up 807 * spurious 'may be used uninitialized' compiler warnings */ 808 arg0.any_ptr = NULL; 809 arg1.any_ptr = NULL; 810 arg2.any_ptr = NULL; 811 812 if (UNLIKELY(base < -1)) 813 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); 814 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n", 815 (long)PL_savestack_ix, (long)base)); 816 while (PL_savestack_ix > base) { 817 UV uv; 818 U8 type; 819 820 SV *refsv; 821 SV **svp; 822 823 TAINT_NOT; 824 825 { 826 I32 ix = PL_savestack_ix - 1; 827 ANY *p = &PL_savestack[ix]; 828 uv = p->any_uv; 829 type = (U8)uv & SAVE_MASK; 830 if (type > SAVEt_ARG0_MAX) { 831 ANY *p0 = p; 832 arg0 = *--p; 833 if (type > SAVEt_ARG1_MAX) { 834 arg1 = *--p; 835 if (type > SAVEt_ARG2_MAX) { 836 arg2 = *--p; 837 } 838 } 839 ix -= (p0 - p); 840 } 841 PL_savestack_ix = ix; 842 } 843 844 switch (type) { 845 case SAVEt_ITEM: /* normal string */ 846 sv_replace(ARG1_SV, ARG0_SV); 847 if (UNLIKELY(SvSMAGICAL(ARG1_SV))) { 848 PL_localizing = 2; 849 mg_set(ARG1_SV); 850 PL_localizing = 0; 851 } 852 break; 853 854 /* This would be a mathom, but Perl_save_svref() calls a static 855 function, S_save_scalar_at(), so has to stay in this file. */ 856 case SAVEt_SVREF: /* scalar reference */ 857 svp = ARG1_SVP; 858 refsv = NULL; /* what to refcnt_dec */ 859 goto restore_sv; 860 861 case SAVEt_SV: /* scalar reference */ 862 svp = &GvSV(ARG1_GV); 863 refsv = ARG1_SV; /* what to refcnt_dec */ 864 restore_sv: 865 { 866 SV * const sv = *svp; 867 *svp = ARG0_SV; 868 SvREFCNT_dec(sv); 869 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) { 870 /* mg_set could die, skipping the freeing of ARG0_SV and 871 * refsv; Ensure that they're always freed in that case */ 872 dSS_ADD; 873 SS_ADD_PTR(ARG0_SV); 874 SS_ADD_UV(SAVEt_FREESV); 875 SS_ADD_PTR(refsv); 876 SS_ADD_UV(SAVEt_FREESV); 877 SS_ADD_END(4); 878 PL_localizing = 2; 879 mg_set(ARG0_SV); 880 PL_localizing = 0; 881 break; 882 } 883 SvREFCNT_dec_NN(ARG0_SV); 884 SvREFCNT_dec(refsv); 885 break; 886 } 887 case SAVEt_GENERIC_PVREF: /* generic pv */ 888 if (*ARG0_PVP != ARG1_PV) { 889 Safefree(*ARG0_PVP); 890 *ARG0_PVP = ARG1_PV; 891 } 892 break; 893 case SAVEt_SHARED_PVREF: /* shared pv */ 894 if (*ARG1_PVP != ARG0_PV) { 895 #ifdef NETWARE 896 PerlMem_free(*ARG1_PVP); 897 #else 898 PerlMemShared_free(*ARG1_PVP); 899 #endif 900 *ARG1_PVP = ARG0_PV; 901 } 902 break; 903 case SAVEt_GVSV: /* scalar slot in GV */ 904 svp = &GvSV(ARG1_GV); 905 goto restore_svp; 906 case SAVEt_GENERIC_SVREF: /* generic sv */ 907 svp = ARG1_SVP; 908 restore_svp: 909 { 910 SV * const sv = *svp; 911 *svp = ARG0_SV; 912 SvREFCNT_dec(sv); 913 SvREFCNT_dec(ARG0_SV); 914 break; 915 } 916 case SAVEt_GVSLOT: /* any slot in GV */ 917 { 918 HV *const hv = GvSTASH(ARG2_GV); 919 svp = ARG1_SVP; 920 if (hv && HvENAME(hv) && ( 921 (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV) 922 || (*svp && SvTYPE(*svp) == SVt_PVCV) 923 )) 924 { 925 if ((char *)svp < (char *)GvGP(ARG2_GV) 926 || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp) 927 || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */ 928 PL_sub_generation++; 929 else mro_method_changed_in(hv); 930 } 931 goto restore_svp; 932 } 933 case SAVEt_AV: /* array reference */ 934 SvREFCNT_dec(GvAV(ARG1_GV)); 935 GvAV(ARG1_GV) = ARG0_AV; 936 avhv_common: 937 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) { 938 /* mg_set might die, so make sure ARG1 isn't leaked */ 939 dSS_ADD; 940 SS_ADD_PTR(ARG1_SV); 941 SS_ADD_UV(SAVEt_FREESV); 942 SS_ADD_END(2); 943 PL_localizing = 2; 944 mg_set(ARG0_SV); 945 PL_localizing = 0; 946 break; 947 } 948 SvREFCNT_dec_NN(ARG1_GV); 949 break; 950 case SAVEt_HV: /* hash reference */ 951 SvREFCNT_dec(GvHV(ARG1_GV)); 952 GvHV(ARG1_GV) = ARG0_HV; 953 goto avhv_common; 954 955 case SAVEt_INT_SMALL: 956 *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT); 957 break; 958 case SAVEt_INT: /* int reference */ 959 *(int*)ARG0_PTR = (int)ARG1_I32; 960 break; 961 case SAVEt_STRLEN: /* STRLEN/size_t ref */ 962 *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv; 963 break; 964 case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */ 965 PL_tmps_floor = (SSize_t)arg0.any_iv; 966 break; 967 case SAVEt_BOOL: /* bool reference */ 968 *(bool*)ARG0_PTR = cBOOL(uv >> 8); 969 #ifdef NO_TAINT_SUPPORT 970 PERL_UNUSED_VAR(was); 971 #else 972 if (UNLIKELY(ARG0_PTR == &(TAINT_get))) { 973 /* If we don't update <was>, to reflect what was saved on the 974 * stack for PL_tainted, then we will overwrite this attempt to 975 * restore it when we exit this routine. Note that this won't 976 * work if this value was saved in a wider-than necessary type, 977 * such as I32 */ 978 was = *(bool*)ARG0_PTR; 979 } 980 #endif 981 break; 982 case SAVEt_I32_SMALL: 983 *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT); 984 break; 985 case SAVEt_I32: /* I32 reference */ 986 #ifdef PERL_DEBUG_READONLY_OPS 987 if (*(I32*)ARG0_PTR != ARG1_I32) 988 #endif 989 *(I32*)ARG0_PTR = ARG1_I32; 990 break; 991 case SAVEt_SPTR: /* SV* reference */ 992 *(SV**)(ARG0_PTR)= ARG1_SV; 993 break; 994 case SAVEt_VPTR: /* random* reference */ 995 case SAVEt_PPTR: /* char* reference */ 996 *ARG0_PVP = ARG1_PV; 997 break; 998 case SAVEt_HPTR: /* HV* reference */ 999 *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR); 1000 break; 1001 case SAVEt_APTR: /* AV* reference */ 1002 *(AV**)ARG0_PTR = ARG1_AV; 1003 break; 1004 case SAVEt_GP: /* scalar reference */ 1005 { 1006 HV *hv; 1007 /* possibly taking a method out of circulation */ 1008 const bool had_method = !!GvCVu(ARG1_GV); 1009 gp_free(ARG1_GV); 1010 GvGP_set(ARG1_GV, (GP*)ARG0_PTR); 1011 if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) { 1012 if ( GvNAMELEN(ARG1_GV) == 3 1013 && strnEQ(GvNAME(ARG1_GV), "ISA", 3) 1014 ) 1015 mro_isa_changed_in(hv); 1016 else if (had_method || GvCVu(ARG1_GV)) 1017 /* putting a method back into circulation ("local")*/ 1018 gv_method_changed(ARG1_GV); 1019 } 1020 SvREFCNT_dec_NN(ARG1_GV); 1021 break; 1022 } 1023 case SAVEt_FREESV: 1024 SvREFCNT_dec(ARG0_SV); 1025 break; 1026 case SAVEt_FREEPADNAME: 1027 PadnameREFCNT_dec((PADNAME *)ARG0_PTR); 1028 break; 1029 case SAVEt_FREECOPHH: 1030 cophh_free((COPHH *)ARG0_PTR); 1031 break; 1032 case SAVEt_MORTALIZESV: 1033 sv_2mortal(ARG0_SV); 1034 break; 1035 case SAVEt_FREEOP: 1036 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); 1037 op_free((OP*)ARG0_PTR); 1038 break; 1039 case SAVEt_FREEPV: 1040 Safefree(ARG0_PTR); 1041 break; 1042 1043 case SAVEt_CLEARPADRANGE: 1044 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK); 1045 svp = &PL_curpad[uv >> 1046 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1; 1047 goto clearsv; 1048 case SAVEt_CLEARSV: 1049 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT]; 1050 i = 1; 1051 clearsv: 1052 for (; i; i--, svp--) { 1053 sv = *svp; 1054 1055 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1056 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n", 1057 PTR2UV(PL_comppad), PTR2UV(PL_curpad), 1058 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), 1059 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" 1060 )); 1061 1062 /* Can clear pad variable in place? */ 1063 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) { 1064 1065 /* these flags are the union of all the relevant flags 1066 * in the individual conditions within */ 1067 if (UNLIKELY(SvFLAGS(sv) & ( 1068 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/ 1069 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */ 1070 | SVf_OOK 1071 | SVf_THINKFIRST))) 1072 { 1073 /* if a my variable that was made readonly is 1074 * going out of scope, we want to remove the 1075 * readonlyness so that it can go out of scope 1076 * quietly 1077 */ 1078 if (SvREADONLY(sv)) 1079 SvREADONLY_off(sv); 1080 1081 if (SvOOK(sv)) { /* OOK or HvAUX */ 1082 if (SvTYPE(sv) == SVt_PVHV) 1083 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); 1084 else 1085 sv_backoff(sv); 1086 } 1087 1088 if (SvMAGICAL(sv)) { 1089 /* note that backrefs (either in HvAUX or magic) 1090 * must be removed before other magic */ 1091 sv_unmagic(sv, PERL_MAGIC_backref); 1092 if (SvTYPE(sv) != SVt_PVCV) 1093 mg_free(sv); 1094 } 1095 if (SvTHINKFIRST(sv)) 1096 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF 1097 |SV_COW_DROP_PV); 1098 1099 } 1100 switch (SvTYPE(sv)) { 1101 case SVt_NULL: 1102 break; 1103 case SVt_PVAV: 1104 av_clear(MUTABLE_AV(sv)); 1105 break; 1106 case SVt_PVHV: 1107 hv_clear(MUTABLE_HV(sv)); 1108 break; 1109 case SVt_PVCV: 1110 { 1111 HEK *hek = 1112 CvNAMED(sv) 1113 ? CvNAME_HEK((CV *)sv) 1114 : GvNAME_HEK(CvGV(sv)); 1115 assert(hek); 1116 (void)share_hek_hek(hek); 1117 cv_undef((CV *)sv); 1118 CvNAME_HEK_set(sv, hek); 1119 CvLEXICAL_on(sv); 1120 break; 1121 } 1122 default: 1123 /* This looks odd, but these two macros are for use in 1124 expressions and finish with a trailing comma, so 1125 adding a ; after them would be wrong. */ 1126 assert_not_ROK(sv) 1127 assert_not_glob(sv) 1128 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8); 1129 break; 1130 } 1131 SvPADTMP_off(sv); 1132 SvPADSTALE_on(sv); /* mark as no longer live */ 1133 } 1134 else { /* Someone has a claim on this, so abandon it. */ 1135 switch (SvTYPE(sv)) { /* Console ourselves with a new value */ 1136 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break; 1137 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break; 1138 case SVt_PVCV: 1139 { 1140 HEK * const hek = CvNAMED(sv) 1141 ? CvNAME_HEK((CV *)sv) 1142 : GvNAME_HEK(CvGV(sv)); 1143 1144 /* Create a stub */ 1145 *svp = newSV_type(SVt_PVCV); 1146 1147 /* Share name */ 1148 CvNAME_HEK_set(*svp, 1149 share_hek_hek(hek)); 1150 CvLEXICAL_on(*svp); 1151 break; 1152 } 1153 default: *svp = newSV(0); break; 1154 } 1155 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */ 1156 /* preserve pad nature, but also mark as not live 1157 * for any closure capturing */ 1158 SvFLAGS(*svp) |= SVs_PADSTALE; 1159 } 1160 } 1161 break; 1162 case SAVEt_DELETE: 1163 (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD); 1164 SvREFCNT_dec(ARG0_HV); 1165 Safefree(arg2.any_ptr); 1166 break; 1167 case SAVEt_ADELETE: 1168 (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD); 1169 SvREFCNT_dec(ARG0_AV); 1170 break; 1171 case SAVEt_DESTRUCTOR_X: 1172 (*arg1.any_dxptr)(aTHX_ ARG0_PTR); 1173 break; 1174 case SAVEt_REGCONTEXT: 1175 /* regexp must have croaked */ 1176 case SAVEt_ALLOC: 1177 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT; 1178 break; 1179 case SAVEt_STACK_POS: /* Position on Perl stack */ 1180 PL_stack_sp = PL_stack_base + arg0.any_i32; 1181 break; 1182 case SAVEt_AELEM: /* array element */ 1183 svp = av_fetch(ARG2_AV, arg1.any_iv, 1); 1184 if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */ 1185 SvREFCNT_dec(ARG0_SV); 1186 if (LIKELY(svp)) { 1187 SV * const sv = *svp; 1188 if (LIKELY(sv && sv != &PL_sv_undef)) { 1189 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied))) 1190 SvREFCNT_inc_void_NN(sv); 1191 refsv = ARG2_SV; 1192 goto restore_sv; 1193 } 1194 } 1195 SvREFCNT_dec(ARG2_AV); 1196 SvREFCNT_dec(ARG0_SV); 1197 break; 1198 case SAVEt_HELEM: /* hash element */ 1199 { 1200 HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0); 1201 SvREFCNT_dec(ARG1_SV); 1202 if (LIKELY(he)) { 1203 const SV * const oval = HeVAL(he); 1204 if (LIKELY(oval && oval != &PL_sv_undef)) { 1205 svp = &HeVAL(he); 1206 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied))) 1207 SvREFCNT_inc_void(*svp); 1208 refsv = ARG2_SV; /* what to refcnt_dec */ 1209 goto restore_sv; 1210 } 1211 } 1212 SvREFCNT_dec(ARG2_HV); 1213 SvREFCNT_dec(ARG0_SV); 1214 break; 1215 } 1216 case SAVEt_OP: 1217 PL_op = (OP*)ARG0_PTR; 1218 break; 1219 case SAVEt_HINTS: 1220 if ((PL_hints & HINT_LOCALIZE_HH)) { 1221 while (GvHV(PL_hintgv)) { 1222 HV *hv = GvHV(PL_hintgv); 1223 GvHV(PL_hintgv) = NULL; 1224 SvREFCNT_dec(MUTABLE_SV(hv)); 1225 } 1226 } 1227 cophh_free(CopHINTHASH_get(&PL_compiling)); 1228 CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR); 1229 *(I32*)&PL_hints = ARG1_I32; 1230 if (PL_hints & HINT_LOCALIZE_HH) { 1231 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); 1232 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR); 1233 } 1234 if (!GvHV(PL_hintgv)) { 1235 /* Need to add a new one manually, else rv2hv can 1236 add one via GvHVn and it won't have the magic set. */ 1237 HV *const hv = newHV(); 1238 hv_magic(hv, NULL, PERL_MAGIC_hints); 1239 GvHV(PL_hintgv) = hv; 1240 } 1241 assert(GvHV(PL_hintgv)); 1242 break; 1243 case SAVEt_COMPPAD: 1244 PL_comppad = (PAD*)ARG0_PTR; 1245 if (LIKELY(PL_comppad)) 1246 PL_curpad = AvARRAY(PL_comppad); 1247 else 1248 PL_curpad = NULL; 1249 break; 1250 case SAVEt_PADSV_AND_MORTALIZE: 1251 { 1252 SV **svp; 1253 assert (ARG1_PTR); 1254 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv; 1255 /* This mortalizing used to be done by CX_POOPLOOP() via 1256 itersave. But as we have all the information here, we 1257 can do it here, save even having to have itersave in 1258 the struct. 1259 */ 1260 sv_2mortal(*svp); 1261 *svp = ARG2_SV; 1262 } 1263 break; 1264 case SAVEt_SAVESWITCHSTACK: 1265 { 1266 dSP; 1267 SWITCHSTACK(ARG0_AV, ARG1_AV); 1268 PL_curstackinfo->si_stack = ARG1_AV; 1269 } 1270 break; 1271 case SAVEt_SET_SVFLAGS: 1272 SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32); 1273 SvFLAGS(ARG2_SV) |= (U32)ARG0_I32; 1274 break; 1275 1276 /* These are only saved in mathoms.c */ 1277 case SAVEt_NSTAB: 1278 (void)sv_clear(ARG0_SV); 1279 break; 1280 case SAVEt_LONG: /* long reference */ 1281 *(long*)ARG0_PTR = arg1.any_long; 1282 break; 1283 case SAVEt_IV: /* IV reference */ 1284 *(IV*)ARG0_PTR = arg1.any_iv; 1285 break; 1286 1287 case SAVEt_I16: /* I16 reference */ 1288 *(I16*)ARG0_PTR = (I16)(uv >> 8); 1289 break; 1290 case SAVEt_I8: /* I8 reference */ 1291 *(I8*)ARG0_PTR = (I8)(uv >> 8); 1292 break; 1293 case SAVEt_DESTRUCTOR: 1294 (*arg1.any_dptr)(ARG0_PTR); 1295 break; 1296 case SAVEt_COMPILE_WARNINGS: 1297 if (!specialWARN(PL_compiling.cop_warnings)) 1298 PerlMemShared_free(PL_compiling.cop_warnings); 1299 1300 PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR; 1301 break; 1302 case SAVEt_PARSER: 1303 parser_free((yy_parser *) ARG0_PTR); 1304 break; 1305 case SAVEt_READONLY_OFF: 1306 SvREADONLY_off(ARG0_SV); 1307 break; 1308 default: 1309 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type); 1310 } 1311 } 1312 1313 TAINT_set(was); 1314 } 1315 1316 void 1317 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) 1318 { 1319 PERL_ARGS_ASSERT_CX_DUMP; 1320 1321 #ifdef DEBUGGING 1322 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); 1323 if (CxTYPE(cx) != CXt_SUBST) { 1324 const char *gimme_text; 1325 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); 1326 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n", 1327 PTR2UV(cx->blk_oldcop)); 1328 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); 1329 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); 1330 PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix); 1331 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n", 1332 PTR2UV(cx->blk_oldpm)); 1333 switch (cx->blk_gimme) { 1334 case G_VOID: 1335 gimme_text = "VOID"; 1336 break; 1337 case G_SCALAR: 1338 gimme_text = "SCALAR"; 1339 break; 1340 case G_ARRAY: 1341 gimme_text = "LIST"; 1342 break; 1343 default: 1344 gimme_text = "UNKNOWN"; 1345 break; 1346 } 1347 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text); 1348 } 1349 switch (CxTYPE(cx)) { 1350 case CXt_NULL: 1351 case CXt_BLOCK: 1352 break; 1353 case CXt_FORMAT: 1354 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n", 1355 PTR2UV(cx->blk_format.cv)); 1356 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n", 1357 PTR2UV(cx->blk_format.gv)); 1358 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n", 1359 PTR2UV(cx->blk_format.dfoutgv)); 1360 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n", 1361 (int)CxHASARGS(cx)); 1362 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n", 1363 PTR2UV(cx->blk_format.retop)); 1364 break; 1365 case CXt_SUB: 1366 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", 1367 PTR2UV(cx->blk_sub.cv)); 1368 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", 1369 (long)cx->blk_sub.olddepth); 1370 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", 1371 (int)CxHASARGS(cx)); 1372 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); 1373 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", 1374 PTR2UV(cx->blk_sub.retop)); 1375 break; 1376 case CXt_EVAL: 1377 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", 1378 (long)CxOLD_IN_EVAL(cx)); 1379 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", 1380 PL_op_name[CxOLD_OP_TYPE(cx)], 1381 PL_op_desc[CxOLD_OP_TYPE(cx)]); 1382 if (cx->blk_eval.old_namesv) 1383 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", 1384 SvPVX_const(cx->blk_eval.old_namesv)); 1385 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n", 1386 PTR2UV(cx->blk_eval.old_eval_root)); 1387 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n", 1388 PTR2UV(cx->blk_eval.retop)); 1389 break; 1390 1391 case CXt_LOOP_PLAIN: 1392 case CXt_LOOP_LAZYIV: 1393 case CXt_LOOP_LAZYSV: 1394 case CXt_LOOP_LIST: 1395 case CXt_LOOP_ARY: 1396 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); 1397 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n", 1398 PTR2UV(cx->blk_loop.my_op)); 1399 if (CxTYPE(cx) != CXt_LOOP_PLAIN) { 1400 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", 1401 PTR2UV(CxITERVAR(cx))); 1402 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n", 1403 PTR2UV(cx->blk_loop.itersave)); 1404 /* XXX: not accurate for LAZYSV/IV/LIST */ 1405 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n", 1406 PTR2UV(cx->blk_loop.state_u.ary.ary)); 1407 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", 1408 (long)cx->blk_loop.state_u.ary.ix); 1409 } 1410 break; 1411 1412 case CXt_SUBST: 1413 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", 1414 (long)cx->sb_iters); 1415 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", 1416 (long)cx->sb_maxiters); 1417 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", 1418 (long)cx->sb_rflags); 1419 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", 1420 (long)CxONCE(cx)); 1421 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", 1422 cx->sb_orig); 1423 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n", 1424 PTR2UV(cx->sb_dstr)); 1425 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n", 1426 PTR2UV(cx->sb_targ)); 1427 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n", 1428 PTR2UV(cx->sb_s)); 1429 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n", 1430 PTR2UV(cx->sb_m)); 1431 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n", 1432 PTR2UV(cx->sb_strend)); 1433 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n", 1434 PTR2UV(cx->sb_rxres)); 1435 break; 1436 } 1437 #else 1438 PERL_UNUSED_CONTEXT; 1439 PERL_UNUSED_ARG(cx); 1440 #endif /* DEBUGGING */ 1441 } 1442 1443 /* 1444 * ex: set ts=8 sts=4 sw=4 et: 1445 */ 1446