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