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, int n) 31 { 32 dVAR; 33 34 PERL_ARGS_ASSERT_STACK_GROW; 35 36 PL_stack_sp = sp; 37 #ifndef STRESS_REALLOC 38 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); 39 #else 40 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1); 41 #endif 42 return PL_stack_sp; 43 } 44 45 #ifndef STRESS_REALLOC 46 #define GROW(old) ((old) * 3 / 2) 47 #else 48 #define GROW(old) ((old) + 1) 49 #endif 50 51 PERL_SI * 52 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) 53 { 54 dVAR; 55 PERL_SI *si; 56 Newx(si, 1, PERL_SI); 57 si->si_stack = newAV(); 58 AvREAL_off(si->si_stack); 59 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); 60 AvALLOC(si->si_stack)[0] = &PL_sv_undef; 61 AvFILLp(si->si_stack) = 0; 62 si->si_prev = 0; 63 si->si_next = 0; 64 si->si_cxmax = cxitems - 1; 65 si->si_cxix = -1; 66 si->si_type = PERLSI_UNDEF; 67 Newx(si->si_cxstack, cxitems, PERL_CONTEXT); 68 /* Without any kind of initialising PUSHSUBST() 69 * in pp_subst() will read uninitialised heap. */ 70 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT); 71 return si; 72 } 73 74 I32 75 Perl_cxinc(pTHX) 76 { 77 dVAR; 78 const IV old_max = cxstack_max; 79 cxstack_max = GROW(cxstack_max); 80 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */ 81 /* Without any kind of initialising deep enough recursion 82 * will end up reading uninitialised PERL_CONTEXTs. */ 83 PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT); 84 return cxstack_ix + 1; 85 } 86 87 void 88 Perl_push_scope(pTHX) 89 { 90 dVAR; 91 if (PL_scopestack_ix == PL_scopestack_max) { 92 PL_scopestack_max = GROW(PL_scopestack_max); 93 Renew(PL_scopestack, PL_scopestack_max, I32); 94 } 95 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; 96 97 } 98 99 void 100 Perl_pop_scope(pTHX) 101 { 102 dVAR; 103 const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; 104 LEAVE_SCOPE(oldsave); 105 } 106 107 void 108 Perl_markstack_grow(pTHX) 109 { 110 dVAR; 111 const I32 oldmax = PL_markstack_max - PL_markstack; 112 const I32 newmax = GROW(oldmax); 113 114 Renew(PL_markstack, newmax, I32); 115 PL_markstack_ptr = PL_markstack + oldmax; 116 PL_markstack_max = PL_markstack + newmax; 117 } 118 119 void 120 Perl_savestack_grow(pTHX) 121 { 122 dVAR; 123 PL_savestack_max = GROW(PL_savestack_max) + 4; 124 Renew(PL_savestack, PL_savestack_max, ANY); 125 } 126 127 void 128 Perl_savestack_grow_cnt(pTHX_ I32 need) 129 { 130 dVAR; 131 PL_savestack_max = PL_savestack_ix + need; 132 Renew(PL_savestack, PL_savestack_max, ANY); 133 } 134 135 #undef GROW 136 137 void 138 Perl_tmps_grow(pTHX_ I32 n) 139 { 140 dVAR; 141 #ifndef STRESS_REALLOC 142 if (n < 128) 143 n = (PL_tmps_max < 512) ? 128 : 512; 144 #endif 145 PL_tmps_max = PL_tmps_ix + n + 1; 146 Renew(PL_tmps_stack, PL_tmps_max, SV*); 147 } 148 149 150 void 151 Perl_free_tmps(pTHX) 152 { 153 dVAR; 154 /* XXX should tmps_floor live in cxstack? */ 155 const I32 myfloor = PL_tmps_floor; 156 while (PL_tmps_ix > myfloor) { /* clean up after last statement */ 157 SV* const sv = PL_tmps_stack[PL_tmps_ix]; 158 PL_tmps_stack[PL_tmps_ix--] = NULL; 159 if (sv && sv != &PL_sv_undef) { 160 SvTEMP_off(sv); 161 SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */ 162 } 163 } 164 } 165 166 STATIC SV * 167 S_save_scalar_at(pTHX_ SV **sptr) 168 { 169 dVAR; 170 SV * const osv = *sptr; 171 register SV * const sv = *sptr = newSV(0); 172 173 PERL_ARGS_ASSERT_SAVE_SCALAR_AT; 174 175 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { 176 if (SvGMAGICAL(osv)) { 177 const bool oldtainted = PL_tainted; 178 SvFLAGS(osv) |= (SvFLAGS(osv) & 179 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 180 PL_tainted = oldtainted; 181 } 182 mg_localize(osv, sv); 183 } 184 return sv; 185 } 186 187 void 188 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) 189 { 190 dVAR; 191 SSCHECK(3); 192 SSPUSHPTR(ptr1); 193 SSPUSHPTR(ptr2); 194 SSPUSHINT(type); 195 } 196 197 SV * 198 Perl_save_scalar(pTHX_ GV *gv) 199 { 200 dVAR; 201 SV ** const sptr = &GvSVn(gv); 202 203 PERL_ARGS_ASSERT_SAVE_SCALAR; 204 205 PL_localizing = 1; 206 SvGETMAGIC(*sptr); 207 PL_localizing = 0; 208 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV); 209 return save_scalar_at(sptr); 210 } 211 212 /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to 213 * restore a global SV to its prior contents, freeing new value. */ 214 void 215 Perl_save_generic_svref(pTHX_ SV **sptr) 216 { 217 dVAR; 218 219 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; 220 221 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); 222 } 223 224 /* Like save_pptr(), but also Safefree()s the new value if it is different 225 * from the old one. Can be used to restore a global char* to its prior 226 * contents, freeing new value. */ 227 void 228 Perl_save_generic_pvref(pTHX_ char **str) 229 { 230 dVAR; 231 232 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; 233 234 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); 235 } 236 237 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). 238 * Can be used to restore a shared global char* to its prior 239 * contents, freeing new value. */ 240 void 241 Perl_save_shared_pvref(pTHX_ char **str) 242 { 243 dVAR; 244 245 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; 246 247 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); 248 } 249 250 /* set the SvFLAGS specified by mask to the values in val */ 251 252 void 253 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) 254 { 255 dVAR; 256 257 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; 258 259 SSCHECK(4); 260 SSPUSHPTR(sv); 261 SSPUSHINT(mask); 262 SSPUSHINT(val); 263 SSPUSHINT(SAVEt_SET_SVFLAGS); 264 } 265 266 void 267 Perl_save_gp(pTHX_ GV *gv, I32 empty) 268 { 269 dVAR; 270 271 PERL_ARGS_ASSERT_SAVE_GP; 272 273 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); 274 275 if (empty) { 276 GP *gp = Perl_newGP(aTHX_ gv); 277 278 if (GvCVu(gv)) 279 mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/ 280 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { 281 gp->gp_io = newIO(); 282 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; 283 } 284 #ifdef PERL_DONT_CREATE_GVSV 285 if (gv == PL_errgv) { 286 /* We could scatter this logic everywhere by changing the 287 definition of ERRSV from GvSV() to GvSVn(), but it seems more 288 efficient to do this check once here. */ 289 gp->gp_sv = newSV(0); 290 } 291 #endif 292 GvGP(gv) = gp; 293 } 294 else { 295 gp_ref(GvGP(gv)); 296 GvINTRO_on(gv); 297 } 298 } 299 300 AV * 301 Perl_save_ary(pTHX_ GV *gv) 302 { 303 dVAR; 304 AV * const oav = GvAVn(gv); 305 AV *av; 306 307 PERL_ARGS_ASSERT_SAVE_ARY; 308 309 if (!AvREAL(oav) && AvREIFY(oav)) 310 av_reify(oav); 311 save_pushptrptr(gv, oav, SAVEt_AV); 312 313 GvAV(gv) = NULL; 314 av = GvAVn(gv); 315 if (SvMAGIC(oav)) 316 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av)); 317 return av; 318 } 319 320 HV * 321 Perl_save_hash(pTHX_ GV *gv) 322 { 323 dVAR; 324 HV *ohv, *hv; 325 326 PERL_ARGS_ASSERT_SAVE_HASH; 327 328 save_pushptrptr(gv, (ohv = GvHVn(gv)), SAVEt_HV); 329 330 GvHV(gv) = NULL; 331 hv = GvHVn(gv); 332 if (SvMAGIC(ohv)) 333 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv)); 334 return hv; 335 } 336 337 void 338 Perl_save_item(pTHX_ register SV *item) 339 { 340 dVAR; 341 register SV * const sv = newSVsv(item); 342 343 PERL_ARGS_ASSERT_SAVE_ITEM; 344 345 save_pushptrptr(item, /* remember the pointer */ 346 sv, /* remember the value */ 347 SAVEt_ITEM); 348 } 349 350 void 351 Perl_save_bool(pTHX_ bool *boolp) 352 { 353 dVAR; 354 355 PERL_ARGS_ASSERT_SAVE_BOOL; 356 357 SSCHECK(3); 358 SSPUSHBOOL(*boolp); 359 SSPUSHPTR(boolp); 360 SSPUSHINT(SAVEt_BOOL); 361 } 362 363 void 364 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) 365 { 366 dVAR; 367 SSCHECK(3); 368 SSPUSHINT(i); 369 SSPUSHPTR(ptr); 370 SSPUSHINT(type); 371 } 372 373 void 374 Perl_save_int(pTHX_ int *intp) 375 { 376 dVAR; 377 378 PERL_ARGS_ASSERT_SAVE_INT; 379 380 save_pushi32ptr(*intp, intp, SAVEt_INT); 381 } 382 383 void 384 Perl_save_I8(pTHX_ I8 *bytep) 385 { 386 dVAR; 387 388 PERL_ARGS_ASSERT_SAVE_I8; 389 390 save_pushi32ptr(*bytep, bytep, SAVEt_I8); 391 } 392 393 void 394 Perl_save_I16(pTHX_ I16 *intp) 395 { 396 dVAR; 397 398 PERL_ARGS_ASSERT_SAVE_I16; 399 400 save_pushi32ptr(*intp, intp, SAVEt_I16); 401 } 402 403 void 404 Perl_save_I32(pTHX_ I32 *intp) 405 { 406 dVAR; 407 408 PERL_ARGS_ASSERT_SAVE_I32; 409 410 save_pushi32ptr(*intp, intp, SAVEt_I32); 411 } 412 413 /* Cannot use save_sptr() to store a char* since the SV** cast will 414 * force word-alignment and we'll miss the pointer. 415 */ 416 void 417 Perl_save_pptr(pTHX_ char **pptr) 418 { 419 dVAR; 420 421 PERL_ARGS_ASSERT_SAVE_PPTR; 422 423 save_pushptrptr(*pptr, pptr, SAVEt_PPTR); 424 } 425 426 void 427 Perl_save_vptr(pTHX_ void *ptr) 428 { 429 dVAR; 430 431 PERL_ARGS_ASSERT_SAVE_VPTR; 432 433 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); 434 } 435 436 void 437 Perl_save_sptr(pTHX_ SV **sptr) 438 { 439 dVAR; 440 441 PERL_ARGS_ASSERT_SAVE_SPTR; 442 443 save_pushptrptr(*sptr, sptr, SAVEt_SPTR); 444 } 445 446 void 447 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) 448 { 449 dVAR; 450 SSCHECK(4); 451 ASSERT_CURPAD_ACTIVE("save_padsv"); 452 SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off])); 453 SSPUSHPTR(PL_comppad); 454 SSPUSHLONG((long)off); 455 SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE); 456 } 457 458 void 459 Perl_save_hptr(pTHX_ HV **hptr) 460 { 461 dVAR; 462 463 PERL_ARGS_ASSERT_SAVE_HPTR; 464 465 save_pushptrptr(*hptr, hptr, SAVEt_HPTR); 466 } 467 468 void 469 Perl_save_aptr(pTHX_ AV **aptr) 470 { 471 dVAR; 472 473 PERL_ARGS_ASSERT_SAVE_APTR; 474 475 save_pushptrptr(*aptr, aptr, SAVEt_APTR); 476 } 477 478 void 479 Perl_save_pushptr(pTHX_ void *const ptr, const int type) 480 { 481 dVAR; 482 SSCHECK(2); 483 SSPUSHPTR(ptr); 484 SSPUSHINT(type); 485 } 486 487 void 488 Perl_save_clearsv(pTHX_ SV **svp) 489 { 490 dVAR; 491 492 PERL_ARGS_ASSERT_SAVE_CLEARSV; 493 494 ASSERT_CURPAD_ACTIVE("save_clearsv"); 495 SSCHECK(2); 496 SSPUSHLONG((long)(svp-PL_curpad)); 497 SSPUSHINT(SAVEt_CLEARSV); 498 SvPADSTALE_off(*svp); /* mark lexical as active */ 499 } 500 501 void 502 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) 503 { 504 dVAR; 505 506 PERL_ARGS_ASSERT_SAVE_DELETE; 507 508 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); 509 } 510 511 void 512 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) 513 { 514 dVAR; 515 516 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; 517 518 SSCHECK(3); 519 SSPUSHDPTR(f); 520 SSPUSHPTR(p); 521 SSPUSHINT(SAVEt_DESTRUCTOR); 522 } 523 524 void 525 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) 526 { 527 dVAR; 528 SSCHECK(3); 529 SSPUSHDXPTR(f); 530 SSPUSHPTR(p); 531 SSPUSHINT(SAVEt_DESTRUCTOR_X); 532 } 533 534 void 535 Perl_save_hints(pTHX) 536 { 537 dVAR; 538 SSCHECK(4); 539 if (PL_hints & HINT_LOCALIZE_HH) { 540 SSPUSHPTR(GvHV(PL_hintgv)); 541 GvHV(PL_hintgv) = Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)); 542 } 543 if (PL_compiling.cop_hints_hash) { 544 HINTS_REFCNT_LOCK; 545 PL_compiling.cop_hints_hash->refcounted_he_refcnt++; 546 HINTS_REFCNT_UNLOCK; 547 } 548 SSPUSHPTR(PL_compiling.cop_hints_hash); 549 SSPUSHINT(PL_hints); 550 SSPUSHINT(SAVEt_HINTS); 551 } 552 553 static void 554 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, 555 const int type) 556 { 557 SSCHECK(4); 558 SSPUSHPTR(ptr1); 559 SSPUSHINT(i); 560 SSPUSHPTR(ptr2); 561 SSPUSHINT(type); 562 } 563 564 void 565 Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr) 566 { 567 dVAR; 568 SV *sv; 569 570 PERL_ARGS_ASSERT_SAVE_AELEM; 571 572 SvGETMAGIC(*sptr); 573 save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr), 574 SAVEt_AELEM); 575 /* if it gets reified later, the restore will have the wrong refcnt */ 576 if (!AvREAL(av) && AvREIFY(av)) 577 SvREFCNT_inc_void(*sptr); 578 save_scalar_at(sptr); 579 sv = *sptr; 580 /* If we're localizing a tied array element, this new sv 581 * won't actually be stored in the array - so it won't get 582 * reaped when the localize ends. Ensure it gets reaped by 583 * mortifying it instead. DAPM */ 584 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) 585 sv_2mortal(sv); 586 } 587 588 void 589 Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr) 590 { 591 dVAR; 592 SV *sv; 593 594 PERL_ARGS_ASSERT_SAVE_HELEM; 595 596 SvGETMAGIC(*sptr); 597 SSCHECK(4); 598 SSPUSHPTR(SvREFCNT_inc_simple(hv)); 599 SSPUSHPTR(newSVsv(key)); 600 SSPUSHPTR(SvREFCNT_inc(*sptr)); 601 SSPUSHINT(SAVEt_HELEM); 602 save_scalar_at(sptr); 603 sv = *sptr; 604 /* If we're localizing a tied hash element, this new sv 605 * won't actually be stored in the hash - so it won't get 606 * reaped when the localize ends. Ensure it gets reaped by 607 * mortifying it instead. DAPM */ 608 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) 609 sv_2mortal(sv); 610 } 611 612 SV* 613 Perl_save_svref(pTHX_ SV **sptr) 614 { 615 dVAR; 616 617 PERL_ARGS_ASSERT_SAVE_SVREF; 618 619 SvGETMAGIC(*sptr); 620 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF); 621 return save_scalar_at(sptr); 622 } 623 624 I32 625 Perl_save_alloc(pTHX_ I32 size, I32 pad) 626 { 627 dVAR; 628 register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] 629 - (char*)PL_savestack); 630 register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); 631 632 SSGROW(elems + 2); 633 634 PL_savestack_ix += elems; 635 SSPUSHINT(elems); 636 SSPUSHINT(SAVEt_ALLOC); 637 return start; 638 } 639 640 void 641 Perl_leave_scope(pTHX_ I32 base) 642 { 643 dVAR; 644 register SV *sv; 645 register SV *value; 646 register GV *gv; 647 register AV *av; 648 register HV *hv; 649 void* ptr; 650 register char* str; 651 I32 i; 652 /* Localise the effects of the TAINT_NOT inside the loop. */ 653 const bool was = PL_tainted; 654 655 if (base < -1) 656 Perl_croak(aTHX_ "panic: corrupt saved stack index"); 657 while (PL_savestack_ix > base) { 658 TAINT_NOT; 659 660 switch (SSPOPINT) { 661 case SAVEt_ITEM: /* normal string */ 662 value = MUTABLE_SV(SSPOPPTR); 663 sv = MUTABLE_SV(SSPOPPTR); 664 sv_replace(sv,value); 665 PL_localizing = 2; 666 SvSETMAGIC(sv); 667 PL_localizing = 0; 668 break; 669 case SAVEt_SV: /* scalar reference */ 670 value = MUTABLE_SV(SSPOPPTR); 671 gv = MUTABLE_GV(SSPOPPTR); 672 ptr = &GvSV(gv); 673 av = MUTABLE_AV(gv); /* what to refcnt_dec */ 674 restore_sv: 675 sv = *(SV**)ptr; 676 DEBUG_S(PerlIO_printf(Perl_debug_log, 677 "restore svref: %p %p:%s -> %p:%s\n", 678 (void*)ptr, (void*)sv, SvPEEK(sv), 679 (void*)value, SvPEEK(value))); 680 *(SV**)ptr = value; 681 SvREFCNT_dec(sv); 682 PL_localizing = 2; 683 SvSETMAGIC(value); 684 PL_localizing = 0; 685 SvREFCNT_dec(value); 686 if (av) /* actually an av, hv or gv */ 687 SvREFCNT_dec(av); 688 break; 689 case SAVEt_GENERIC_PVREF: /* generic pv */ 690 ptr = SSPOPPTR; 691 str = (char*)SSPOPPTR; 692 if (*(char**)ptr != str) { 693 Safefree(*(char**)ptr); 694 *(char**)ptr = str; 695 } 696 break; 697 case SAVEt_SHARED_PVREF: /* shared pv */ 698 str = (char*)SSPOPPTR; 699 ptr = SSPOPPTR; 700 if (*(char**)ptr != str) { 701 #ifdef NETWARE 702 PerlMem_free(*(char**)ptr); 703 #else 704 PerlMemShared_free(*(char**)ptr); 705 #endif 706 *(char**)ptr = str; 707 } 708 break; 709 case SAVEt_GENERIC_SVREF: /* generic sv */ 710 value = MUTABLE_SV(SSPOPPTR); 711 ptr = SSPOPPTR; 712 sv = *(SV**)ptr; 713 *(SV**)ptr = value; 714 SvREFCNT_dec(sv); 715 SvREFCNT_dec(value); 716 break; 717 case SAVEt_AV: /* array reference */ 718 av = MUTABLE_AV(SSPOPPTR); 719 gv = MUTABLE_GV(SSPOPPTR); 720 if (GvAV(gv)) { 721 SvREFCNT_dec(GvAV(gv)); 722 } 723 GvAV(gv) = av; 724 if (SvMAGICAL(av)) { 725 PL_localizing = 2; 726 SvSETMAGIC(MUTABLE_SV(av)); 727 PL_localizing = 0; 728 } 729 break; 730 case SAVEt_HV: /* hash reference */ 731 hv = MUTABLE_HV(SSPOPPTR); 732 gv = MUTABLE_GV(SSPOPPTR); 733 if (GvHV(gv)) { 734 SvREFCNT_dec(GvHV(gv)); 735 } 736 GvHV(gv) = hv; 737 if (SvMAGICAL(hv)) { 738 PL_localizing = 2; 739 SvSETMAGIC(MUTABLE_SV(hv)); 740 PL_localizing = 0; 741 } 742 break; 743 case SAVEt_INT: /* int reference */ 744 ptr = SSPOPPTR; 745 *(int*)ptr = (int)SSPOPINT; 746 break; 747 case SAVEt_BOOL: /* bool reference */ 748 ptr = SSPOPPTR; 749 *(bool*)ptr = (bool)SSPOPBOOL; 750 break; 751 case SAVEt_I32: /* I32 reference */ 752 ptr = SSPOPPTR; 753 #ifdef PERL_DEBUG_READONLY_OPS 754 { 755 const I32 val = SSPOPINT; 756 if (*(I32*)ptr != val) 757 *(I32*)ptr = val; 758 } 759 #else 760 *(I32*)ptr = (I32)SSPOPINT; 761 #endif 762 break; 763 case SAVEt_SPTR: /* SV* reference */ 764 ptr = SSPOPPTR; 765 *(SV**)ptr = MUTABLE_SV(SSPOPPTR); 766 break; 767 case SAVEt_VPTR: /* random* reference */ 768 case SAVEt_PPTR: /* char* reference */ 769 ptr = SSPOPPTR; 770 *(char**)ptr = (char*)SSPOPPTR; 771 break; 772 case SAVEt_HPTR: /* HV* reference */ 773 ptr = SSPOPPTR; 774 *(HV**)ptr = MUTABLE_HV(SSPOPPTR); 775 break; 776 case SAVEt_APTR: /* AV* reference */ 777 ptr = SSPOPPTR; 778 *(AV**)ptr = MUTABLE_AV(SSPOPPTR); 779 break; 780 case SAVEt_GP: /* scalar reference */ 781 ptr = SSPOPPTR; 782 gv = MUTABLE_GV(SSPOPPTR); 783 gp_free(gv); 784 GvGP(gv) = (GP*)ptr; 785 /* putting a method back into circulation ("local")*/ 786 if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv)) 787 mro_method_changed_in(hv); 788 SvREFCNT_dec(gv); 789 break; 790 case SAVEt_FREESV: 791 ptr = SSPOPPTR; 792 SvREFCNT_dec(MUTABLE_SV(ptr)); 793 break; 794 case SAVEt_MORTALIZESV: 795 ptr = SSPOPPTR; 796 sv_2mortal(MUTABLE_SV(ptr)); 797 break; 798 case SAVEt_FREEOP: 799 ptr = SSPOPPTR; 800 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */ 801 op_free((OP*)ptr); 802 break; 803 case SAVEt_FREEPV: 804 ptr = SSPOPPTR; 805 Safefree(ptr); 806 break; 807 case SAVEt_CLEARSV: 808 ptr = (void*)&PL_curpad[SSPOPLONG]; 809 sv = *(SV**)ptr; 810 811 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 812 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n", 813 PTR2UV(PL_comppad), PTR2UV(PL_curpad), 814 (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), 815 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" 816 )); 817 818 /* Can clear pad variable in place? */ 819 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { 820 /* 821 * if a my variable that was made readonly is going out of 822 * scope, we want to remove the readonlyness so that it can 823 * go out of scope quietly 824 */ 825 if (SvPADMY(sv) && !SvFAKE(sv)) 826 SvREADONLY_off(sv); 827 828 if (SvTHINKFIRST(sv)) 829 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); 830 if (SvMAGICAL(sv)) 831 mg_free(sv); 832 833 switch (SvTYPE(sv)) { 834 case SVt_NULL: 835 break; 836 case SVt_PVAV: 837 av_clear(MUTABLE_AV(sv)); 838 break; 839 case SVt_PVHV: 840 hv_clear(MUTABLE_HV(sv)); 841 break; 842 case SVt_PVCV: 843 Perl_croak(aTHX_ "panic: leave_scope pad code"); 844 default: 845 SvOK_off(sv); 846 break; 847 } 848 SvPADSTALE_on(sv); /* mark as no longer live */ 849 } 850 else { /* Someone has a claim on this, so abandon it. */ 851 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP); 852 switch (SvTYPE(sv)) { /* Console ourselves with a new value */ 853 case SVt_PVAV: *(SV**)ptr = MUTABLE_SV(newAV()); break; 854 case SVt_PVHV: *(SV**)ptr = MUTABLE_SV(newHV()); break; 855 default: *(SV**)ptr = newSV(0); break; 856 } 857 SvREFCNT_dec(sv); /* Cast current value to the winds. */ 858 /* preserve pad nature, but also mark as not live 859 * for any closure capturing */ 860 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE; 861 } 862 break; 863 case SAVEt_DELETE: 864 ptr = SSPOPPTR; 865 hv = MUTABLE_HV(ptr); 866 i = SSPOPINT; 867 ptr = SSPOPPTR; 868 (void)hv_delete(hv, (char*)ptr, i, G_DISCARD); 869 SvREFCNT_dec(hv); 870 Safefree(ptr); 871 break; 872 case SAVEt_DESTRUCTOR_X: 873 ptr = SSPOPPTR; 874 (*SSPOPDXPTR)(aTHX_ ptr); 875 break; 876 case SAVEt_REGCONTEXT: 877 case SAVEt_ALLOC: 878 i = SSPOPINT; 879 PL_savestack_ix -= i; /* regexp must have croaked */ 880 break; 881 case SAVEt_STACK_POS: /* Position on Perl stack */ 882 i = SSPOPINT; 883 PL_stack_sp = PL_stack_base + i; 884 break; 885 case SAVEt_STACK_CXPOS: /* blk_oldsp on context stack */ 886 i = SSPOPINT; 887 cxstack[i].blk_oldsp = SSPOPINT; 888 break; 889 case SAVEt_AELEM: /* array element */ 890 value = MUTABLE_SV(SSPOPPTR); 891 i = SSPOPINT; 892 av = MUTABLE_AV(SSPOPPTR); 893 ptr = av_fetch(av,i,1); 894 if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */ 895 SvREFCNT_dec(value); 896 if (ptr) { 897 sv = *(SV**)ptr; 898 if (sv && sv != &PL_sv_undef) { 899 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 900 SvREFCNT_inc_void_NN(sv); 901 goto restore_sv; 902 } 903 } 904 SvREFCNT_dec(av); 905 SvREFCNT_dec(value); 906 break; 907 case SAVEt_HELEM: /* hash element */ 908 value = MUTABLE_SV(SSPOPPTR); 909 sv = MUTABLE_SV(SSPOPPTR); 910 hv = MUTABLE_HV(SSPOPPTR); 911 ptr = hv_fetch_ent(hv, sv, 1, 0); 912 SvREFCNT_dec(sv); 913 if (ptr) { 914 const SV * const oval = HeVAL((HE*)ptr); 915 if (oval && oval != &PL_sv_undef) { 916 ptr = &HeVAL((HE*)ptr); 917 if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) 918 SvREFCNT_inc_void(*(SV**)ptr); 919 av = MUTABLE_AV(hv); /* what to refcnt_dec */ 920 goto restore_sv; 921 } 922 } 923 SvREFCNT_dec(hv); 924 SvREFCNT_dec(value); 925 break; 926 case SAVEt_OP: 927 PL_op = (OP*)SSPOPPTR; 928 break; 929 case SAVEt_HINTS: 930 if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) { 931 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); 932 GvHV(PL_hintgv) = NULL; 933 } 934 *(I32*)&PL_hints = (I32)SSPOPINT; 935 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); 936 PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR; 937 if (PL_hints & HINT_LOCALIZE_HH) { 938 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); 939 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR); 940 assert(GvHV(PL_hintgv)); 941 } else if (!GvHV(PL_hintgv)) { 942 /* Need to add a new one manually, else gv_fetchpv() can 943 add one in this code: 944 945 if (SvTYPE(gv) == SVt_PVGV) { 946 if (add) { 947 GvMULTI_on(gv); 948 gv_init_sv(gv, sv_type); 949 if (*name=='!' && sv_type == SVt_PVHV && len==1) 950 require_errno(gv); 951 } 952 return gv; 953 } 954 955 and it won't have the magic set. */ 956 957 HV *const hv = newHV(); 958 hv_magic(hv, NULL, PERL_MAGIC_hints); 959 GvHV(PL_hintgv) = hv; 960 } 961 assert(GvHV(PL_hintgv)); 962 break; 963 case SAVEt_COMPPAD: 964 PL_comppad = (PAD*)SSPOPPTR; 965 if (PL_comppad) 966 PL_curpad = AvARRAY(PL_comppad); 967 else 968 PL_curpad = NULL; 969 break; 970 case SAVEt_PADSV_AND_MORTALIZE: 971 { 972 const PADOFFSET off = (PADOFFSET)SSPOPLONG; 973 SV **svp; 974 ptr = SSPOPPTR; 975 assert (ptr); 976 svp = AvARRAY((PAD*)ptr) + off; 977 /* This mortalizing used to be done by POPLOOP() via itersave. 978 But as we have all the information here, we can do it here, 979 save even having to have itersave in the struct. */ 980 sv_2mortal(*svp); 981 *svp = MUTABLE_SV(SSPOPPTR); 982 } 983 break; 984 case SAVEt_SAVESWITCHSTACK: 985 { 986 dSP; 987 AV *const t = MUTABLE_AV(SSPOPPTR); 988 AV *const f = MUTABLE_AV(SSPOPPTR); 989 SWITCHSTACK(t,f); 990 PL_curstackinfo->si_stack = f; 991 } 992 break; 993 case SAVEt_SET_SVFLAGS: 994 { 995 const U32 val = (U32)SSPOPINT; 996 const U32 mask = (U32)SSPOPINT; 997 sv = MUTABLE_SV(SSPOPPTR); 998 SvFLAGS(sv) &= ~mask; 999 SvFLAGS(sv) |= val; 1000 } 1001 break; 1002 1003 /* This would be a mathom, but Perl_save_svref() calls a static 1004 function, S_save_scalar_at(), so has to stay in this file. */ 1005 case SAVEt_SVREF: /* scalar reference */ 1006 value = MUTABLE_SV(SSPOPPTR); 1007 ptr = SSPOPPTR; 1008 av = NULL; /* what to refcnt_dec */ 1009 goto restore_sv; 1010 1011 /* These are only saved in mathoms.c */ 1012 case SAVEt_NSTAB: 1013 gv = MUTABLE_GV(SSPOPPTR); 1014 (void)sv_clear(MUTABLE_SV(gv)); 1015 break; 1016 case SAVEt_LONG: /* long reference */ 1017 ptr = SSPOPPTR; 1018 *(long*)ptr = (long)SSPOPLONG; 1019 break; 1020 case SAVEt_IV: /* IV reference */ 1021 ptr = SSPOPPTR; 1022 *(IV*)ptr = (IV)SSPOPIV; 1023 break; 1024 1025 /* This case is rendered redundant by the integration of change 1026 33078. See the comment near Perl_save_padsv(). */ 1027 case SAVEt_PADSV: 1028 { 1029 const PADOFFSET off = (PADOFFSET)SSPOPLONG; 1030 ptr = SSPOPPTR; 1031 if (ptr) 1032 AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR; 1033 else { 1034 /* Can we ever get here? 1035 POPs must balance PUSHes. */ 1036 (void) SSPOPPTR; 1037 } 1038 } 1039 break; 1040 case SAVEt_I16: /* I16 reference */ 1041 ptr = SSPOPPTR; 1042 *(I16*)ptr = (I16)SSPOPINT; 1043 break; 1044 case SAVEt_I8: /* I8 reference */ 1045 ptr = SSPOPPTR; 1046 *(I8*)ptr = (I8)SSPOPINT; 1047 break; 1048 case SAVEt_DESTRUCTOR: 1049 ptr = SSPOPPTR; 1050 (*SSPOPDPTR)(ptr); 1051 break; 1052 case SAVEt_COP_ARYBASE: 1053 ptr = SSPOPPTR; 1054 i = SSPOPINT; 1055 CopARYBASE_set((COP *)ptr, i); 1056 break; 1057 case SAVEt_COMPILE_WARNINGS: 1058 ptr = SSPOPPTR; 1059 1060 if (!specialWARN(PL_compiling.cop_warnings)) 1061 PerlMemShared_free(PL_compiling.cop_warnings); 1062 1063 PL_compiling.cop_warnings = (STRLEN*)ptr; 1064 break; 1065 case SAVEt_RE_STATE: 1066 { 1067 const struct re_save_state *const state 1068 = (struct re_save_state *) 1069 (PL_savestack + PL_savestack_ix 1070 - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); 1071 PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; 1072 1073 if (PL_reg_start_tmp != state->re_state_reg_start_tmp) { 1074 Safefree(PL_reg_start_tmp); 1075 } 1076 if (PL_reg_poscache != state->re_state_reg_poscache) { 1077 Safefree(PL_reg_poscache); 1078 } 1079 Copy(state, &PL_reg_state, 1, struct re_save_state); 1080 } 1081 break; 1082 case SAVEt_PARSER: 1083 ptr = SSPOPPTR; 1084 parser_free((yy_parser *) ptr); 1085 break; 1086 default: 1087 Perl_croak(aTHX_ "panic: leave_scope inconsistency"); 1088 } 1089 } 1090 1091 PL_tainted = was; 1092 } 1093 1094 void 1095 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) 1096 { 1097 dVAR; 1098 1099 PERL_ARGS_ASSERT_CX_DUMP; 1100 1101 #ifdef DEBUGGING 1102 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); 1103 if (CxTYPE(cx) != CXt_SUBST) { 1104 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); 1105 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n", 1106 PTR2UV(cx->blk_oldcop)); 1107 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); 1108 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); 1109 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n", 1110 PTR2UV(cx->blk_oldpm)); 1111 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); 1112 } 1113 switch (CxTYPE(cx)) { 1114 case CXt_NULL: 1115 case CXt_BLOCK: 1116 break; 1117 case CXt_FORMAT: 1118 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", 1119 PTR2UV(cx->blk_sub.cv)); 1120 PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n", 1121 PTR2UV(cx->blk_sub.gv)); 1122 PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n", 1123 PTR2UV(cx->blk_sub.dfoutgv)); 1124 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", 1125 (int)CxHASARGS(cx)); 1126 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", 1127 PTR2UV(cx->blk_sub.retop)); 1128 break; 1129 case CXt_SUB: 1130 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", 1131 PTR2UV(cx->blk_sub.cv)); 1132 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", 1133 (long)cx->blk_sub.olddepth); 1134 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", 1135 (int)CxHASARGS(cx)); 1136 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); 1137 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", 1138 PTR2UV(cx->blk_sub.retop)); 1139 break; 1140 case CXt_EVAL: 1141 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", 1142 (long)CxOLD_IN_EVAL(cx)); 1143 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", 1144 PL_op_name[CxOLD_OP_TYPE(cx)], 1145 PL_op_desc[CxOLD_OP_TYPE(cx)]); 1146 if (cx->blk_eval.old_namesv) 1147 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", 1148 SvPVX_const(cx->blk_eval.old_namesv)); 1149 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n", 1150 PTR2UV(cx->blk_eval.old_eval_root)); 1151 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n", 1152 PTR2UV(cx->blk_eval.retop)); 1153 break; 1154 1155 case CXt_LOOP: 1156 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); 1157 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", 1158 (long)cx->blk_loop.resetsp); 1159 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n", 1160 PTR2UV(cx->blk_loop.my_op)); 1161 PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n", 1162 PTR2UV(CX_LOOP_NEXTOP_GET(cx))); 1163 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", 1164 (long)cx->blk_loop.iterix); 1165 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n", 1166 PTR2UV(cx->blk_loop.iterary)); 1167 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", 1168 PTR2UV(CxITERVAR(cx))); 1169 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n", 1170 PTR2UV(cx->blk_loop.iterlval)); 1171 break; 1172 1173 case CXt_SUBST: 1174 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", 1175 (long)cx->sb_iters); 1176 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", 1177 (long)cx->sb_maxiters); 1178 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", 1179 (long)cx->sb_rflags); 1180 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", 1181 (long)CxONCE(cx)); 1182 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", 1183 cx->sb_orig); 1184 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n", 1185 PTR2UV(cx->sb_dstr)); 1186 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n", 1187 PTR2UV(cx->sb_targ)); 1188 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n", 1189 PTR2UV(cx->sb_s)); 1190 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n", 1191 PTR2UV(cx->sb_m)); 1192 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n", 1193 PTR2UV(cx->sb_strend)); 1194 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n", 1195 PTR2UV(cx->sb_rxres)); 1196 break; 1197 } 1198 #else 1199 PERL_UNUSED_CONTEXT; 1200 PERL_UNUSED_ARG(cx); 1201 #endif /* DEBUGGING */ 1202 } 1203 1204 /* This is rendered a mathom by the integration of change 33078. However, until 1205 we have versioned mathom logic in mathoms.c, we can't move it there for 1206 5.10.1, as other code in production may have linked to it. */ 1207 1208 void 1209 Perl_save_padsv(pTHX_ PADOFFSET off) 1210 { 1211 dVAR; 1212 SSCHECK(4); 1213 ASSERT_CURPAD_ACTIVE("save_padsv"); 1214 SSPUSHPTR(PL_curpad[off]); 1215 SSPUSHPTR(PL_comppad); 1216 SSPUSHLONG((long)off); 1217 SSPUSHINT(SAVEt_PADSV); 1218 } 1219 1220 /* 1221 * Local variables: 1222 * c-indentation-style: bsd 1223 * c-basic-offset: 4 1224 * indent-tabs-mode: t 1225 * End: 1226 * 1227 * ex: set ts=8 sts=4 sw=4 noet: 1228 */ 1229