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