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