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