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