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