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