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