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