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