1 /* scope.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"] 16 */ 17 18 /* This file contains functions to manipulate several of Perl's stacks; 19 * in particular it contains code to push various types of things onto 20 * the savestack, then to pop them off and perform the correct restorative 21 * action for each one. This corresponds to the cleanup Perl does at 22 * each scope exit. 23 */ 24 25 #include "EXTERN.h" 26 #define PERL_IN_SCOPE_C 27 #include "perl.h" 28 29 SV** 30 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) 31 { 32 dVAR; 33 34 PERL_ARGS_ASSERT_STACK_GROW; 35 36 PL_stack_sp = sp; 37 #ifndef STRESS_REALLOC 38 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); 39 #else 40 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1); 41 #endif 42 return PL_stack_sp; 43 } 44 45 #ifndef STRESS_REALLOC 46 #define GROW(old) ((old) * 3 / 2) 47 #else 48 #define GROW(old) ((old) + 1) 49 #endif 50 51 PERL_SI * 52 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) 53 { 54 dVAR; 55 PERL_SI *si; 56 Newx(si, 1, PERL_SI); 57 si->si_stack = newAV(); 58 AvREAL_off(si->si_stack); 59 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); 60 AvALLOC(si->si_stack)[0] = &PL_sv_undef; 61 AvFILLp(si->si_stack) = 0; 62 si->si_prev = 0; 63 si->si_next = 0; 64 si->si_cxmax = cxitems - 1; 65 si->si_cxix = -1; 66 si->si_type = PERLSI_UNDEF; 67 Newx(si->si_cxstack, cxitems, PERL_CONTEXT); 68 /* Without any kind of initialising PUSHSUBST() 69 * in pp_subst() will read uninitialised heap. */ 70 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT); 71 return si; 72 } 73 74 I32 75 Perl_cxinc(pTHX) 76 { 77 dVAR; 78 const IV old_max = cxstack_max; 79 cxstack_max = GROW(cxstack_max); 80 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); 81 /* Without any kind of initialising deep enough recursion 82 * will end up reading uninitialised PERL_CONTEXTs. */ 83 PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT); 84 return cxstack_ix + 1; 85 } 86 87 void 88 Perl_push_scope(pTHX) 89 { 90 dVAR; 91 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) { 92 PL_scopestack_max = GROW(PL_scopestack_max); 93 Renew(PL_scopestack, PL_scopestack_max, I32); 94 #ifdef DEBUGGING 95 Renew(PL_scopestack_name, PL_scopestack_max, const char*); 96 #endif 97 } 98 #ifdef DEBUGGING 99 PL_scopestack_name[PL_scopestack_ix] = "unknown"; 100 #endif 101 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; 102 103 } 104 105 void 106 Perl_pop_scope(pTHX) 107 { 108 dVAR; 109 const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; 110 LEAVE_SCOPE(oldsave); 111 } 112 113 void 114 Perl_markstack_grow(pTHX) 115 { 116 dVAR; 117 const I32 oldmax = PL_markstack_max - PL_markstack; 118 const I32 newmax = GROW(oldmax); 119 120 Renew(PL_markstack, newmax, I32); 121 PL_markstack_ptr = PL_markstack + oldmax; 122 PL_markstack_max = PL_markstack + newmax; 123 } 124 125 void 126 Perl_savestack_grow(pTHX) 127 { 128 dVAR; 129 PL_savestack_max = GROW(PL_savestack_max) + 4; 130 Renew(PL_savestack, PL_savestack_max, ANY); 131 } 132 133 void 134 Perl_savestack_grow_cnt(pTHX_ I32 need) 135 { 136 dVAR; 137 PL_savestack_max = PL_savestack_ix + need; 138 Renew(PL_savestack, PL_savestack_max, ANY); 139 } 140 141 #undef GROW 142 143 void 144 Perl_tmps_grow(pTHX_ SSize_t n) 145 { 146 dVAR; 147 #ifndef STRESS_REALLOC 148 if (n < 128) 149 n = (PL_tmps_max < 512) ? 128 : 512; 150 #endif 151 PL_tmps_max = PL_tmps_ix + n + 1; 152 Renew(PL_tmps_stack, PL_tmps_max, SV*); 153 } 154 155 156 void 157 Perl_free_tmps(pTHX) 158 { 159 dVAR; 160 /* XXX should tmps_floor live in cxstack? */ 161 const SSize_t myfloor = PL_tmps_floor; 162 while (PL_tmps_ix > myfloor) { /* clean up after last statement */ 163 SV* const sv = PL_tmps_stack[PL_tmps_ix--]; 164 #ifdef PERL_POISON 165 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); 166 #endif 167 if (LIKELY(sv && sv != &PL_sv_undef)) { 168 SvTEMP_off(sv); 169 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ 170 } 171 } 172 } 173 174 STATIC SV * 175 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) 176 { 177 dVAR; 178 SV * osv; 179 SV *sv; 180 181 PERL_ARGS_ASSERT_SAVE_SCALAR_AT; 182 183 osv = *sptr; 184 sv = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0)); 185 186 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) { 187 if (SvGMAGICAL(osv)) { 188 SvFLAGS(osv) |= (SvFLAGS(osv) & 189 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 190 } 191 if (!(flags & SAVEf_KEEPOLDELEM)) 192 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC)); 193 } 194 195 return sv; 196 } 197 198 void 199 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) 200 { 201 dVAR; 202 dSS_ADD; 203 SS_ADD_PTR(ptr1); 204 SS_ADD_PTR(ptr2); 205 SS_ADD_UV(type); 206 SS_ADD_END(3); 207 } 208 209 SV * 210 Perl_save_scalar(pTHX_ GV *gv) 211 { 212 dVAR; 213 SV ** const sptr = &GvSVn(gv); 214 215 PERL_ARGS_ASSERT_SAVE_SCALAR; 216 217 if (UNLIKELY(SvGMAGICAL(*sptr))) { 218 PL_localizing = 1; 219 (void)mg_get(*sptr); 220 PL_localizing = 0; 221 } 222 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV); 223 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 224 } 225 226 /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to 227 * restore a global SV to its prior contents, freeing new value. */ 228 void 229 Perl_save_generic_svref(pTHX_ SV **sptr) 230 { 231 dVAR; 232 233 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; 234 235 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); 236 } 237 238 /* Like save_pptr(), but also Safefree()s the new value if it is different 239 * from the old one. Can be used to restore a global char* to its prior 240 * contents, freeing new value. */ 241 void 242 Perl_save_generic_pvref(pTHX_ char **str) 243 { 244 dVAR; 245 246 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; 247 248 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); 249 } 250 251 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). 252 * Can be used to restore a shared global char* to its prior 253 * contents, freeing new value. */ 254 void 255 Perl_save_shared_pvref(pTHX_ char **str) 256 { 257 dVAR; 258 259 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; 260 261 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); 262 } 263 264 /* set the SvFLAGS specified by mask to the values in val */ 265 266 void 267 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) 268 { 269 dVAR; 270 dSS_ADD; 271 272 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; 273 274 SS_ADD_PTR(sv); 275 SS_ADD_INT(mask); 276 SS_ADD_INT(val); 277 SS_ADD_UV(SAVEt_SET_SVFLAGS); 278 SS_ADD_END(4); 279 } 280 281 void 282 Perl_save_gp(pTHX_ GV *gv, I32 empty) 283 { 284 dVAR; 285 286 PERL_ARGS_ASSERT_SAVE_GP; 287 288 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); 289 290 if (empty) { 291 GP *gp = Perl_newGP(aTHX_ gv); 292 HV * const stash = GvSTASH(gv); 293 bool isa_changed = 0; 294 295 if (stash && HvENAME(stash)) { 296 if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3)) 297 isa_changed = TRUE; 298 else if (GvCVu(gv)) 299 /* taking a method out of circulation ("local")*/ 300 mro_method_changed_in(stash); 301 } 302 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { 303 gp->gp_io = newIO(); 304 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; 305 } 306 GvGP_set(gv,gp); 307 if (isa_changed) mro_isa_changed_in(stash); 308 } 309 else { 310 gp_ref(GvGP(gv)); 311 GvINTRO_on(gv); 312 } 313 } 314 315 AV * 316 Perl_save_ary(pTHX_ GV *gv) 317 { 318 dVAR; 319 AV * const oav = GvAVn(gv); 320 AV *av; 321 322 PERL_ARGS_ASSERT_SAVE_ARY; 323 324 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav))) 325 av_reify(oav); 326 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV); 327 328 GvAV(gv) = NULL; 329 av = GvAVn(gv); 330 if (UNLIKELY(SvMAGIC(oav))) 331 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); 332 return av; 333 } 334 335 HV * 336 Perl_save_hash(pTHX_ GV *gv) 337 { 338 dVAR; 339 HV *ohv, *hv; 340 341 PERL_ARGS_ASSERT_SAVE_HASH; 342 343 save_pushptrptr( 344 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV 345 ); 346 347 GvHV(gv) = NULL; 348 hv = GvHVn(gv); 349 if (UNLIKELY(SvMAGIC(ohv))) 350 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); 351 return hv; 352 } 353 354 void 355 Perl_save_item(pTHX_ SV *item) 356 { 357 dVAR; 358 SV * const sv = newSVsv(item); 359 360 PERL_ARGS_ASSERT_SAVE_ITEM; 361 362 save_pushptrptr(item, /* remember the pointer */ 363 sv, /* remember the value */ 364 SAVEt_ITEM); 365 } 366 367 void 368 Perl_save_bool(pTHX_ bool *boolp) 369 { 370 dVAR; 371 dSS_ADD; 372 373 PERL_ARGS_ASSERT_SAVE_BOOL; 374 375 SS_ADD_PTR(boolp); 376 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8)); 377 SS_ADD_END(2); 378 } 379 380 void 381 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) 382 { 383 dVAR; 384 dSS_ADD; 385 386 SS_ADD_INT(i); 387 SS_ADD_PTR(ptr); 388 SS_ADD_UV(type); 389 SS_ADD_END(3); 390 } 391 392 void 393 Perl_save_int(pTHX_ int *intp) 394 { 395 dVAR; 396 const int i = *intp; 397 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL); 398 int size = 2; 399 dSS_ADD; 400 401 PERL_ARGS_ASSERT_SAVE_INT; 402 403 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) { 404 SS_ADD_INT(i); 405 type = SAVEt_INT; 406 size++; 407 } 408 SS_ADD_PTR(intp); 409 SS_ADD_UV(type); 410 SS_ADD_END(size); 411 } 412 413 void 414 Perl_save_I8(pTHX_ I8 *bytep) 415 { 416 dVAR; 417 dSS_ADD; 418 419 PERL_ARGS_ASSERT_SAVE_I8; 420 421 SS_ADD_PTR(bytep); 422 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8)); 423 SS_ADD_END(2); 424 } 425 426 void 427 Perl_save_I16(pTHX_ I16 *intp) 428 { 429 dVAR; 430 dSS_ADD; 431 432 PERL_ARGS_ASSERT_SAVE_I16; 433 434 SS_ADD_PTR(intp); 435 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8)); 436 SS_ADD_END(2); 437 } 438 439 void 440 Perl_save_I32(pTHX_ I32 *intp) 441 { 442 dVAR; 443 const I32 i = *intp; 444 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL); 445 int size = 2; 446 dSS_ADD; 447 448 PERL_ARGS_ASSERT_SAVE_I32; 449 450 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) { 451 SS_ADD_INT(i); 452 type = SAVEt_I32; 453 size++; 454 } 455 SS_ADD_PTR(intp); 456 SS_ADD_UV(type); 457 SS_ADD_END(size); 458 } 459 460 void 461 Perl_save_strlen(pTHX_ STRLEN *ptr) 462 { 463 dVAR; 464 dSS_ADD; 465 466 PERL_ARGS_ASSERT_SAVE_STRLEN; 467 468 SS_ADD_IV(*ptr); 469 SS_ADD_PTR(ptr); 470 SS_ADD_UV(SAVEt_STRLEN); 471 SS_ADD_END(3); 472 } 473 474 /* Cannot use save_sptr() to store a char* since the SV** cast will 475 * force word-alignment and we'll miss the pointer. 476 */ 477 void 478 Perl_save_pptr(pTHX_ char **pptr) 479 { 480 dVAR; 481 482 PERL_ARGS_ASSERT_SAVE_PPTR; 483 484 save_pushptrptr(*pptr, pptr, SAVEt_PPTR); 485 } 486 487 void 488 Perl_save_vptr(pTHX_ void *ptr) 489 { 490 dVAR; 491 492 PERL_ARGS_ASSERT_SAVE_VPTR; 493 494 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); 495 } 496 497 void 498 Perl_save_sptr(pTHX_ SV **sptr) 499 { 500 dVAR; 501 502 PERL_ARGS_ASSERT_SAVE_SPTR; 503 504 save_pushptrptr(*sptr, sptr, SAVEt_SPTR); 505 } 506 507 void 508 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) 509 { 510 dVAR; 511 dSS_ADD; 512 513 ASSERT_CURPAD_ACTIVE("save_padsv"); 514 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off])); 515 SS_ADD_PTR(PL_comppad); 516 SS_ADD_UV((UV)off); 517 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE); 518 SS_ADD_END(4); 519 } 520 521 void 522 Perl_save_hptr(pTHX_ HV **hptr) 523 { 524 dVAR; 525 526 PERL_ARGS_ASSERT_SAVE_HPTR; 527 528 save_pushptrptr(*hptr, hptr, SAVEt_HPTR); 529 } 530 531 void 532 Perl_save_aptr(pTHX_ AV **aptr) 533 { 534 dVAR; 535 536 PERL_ARGS_ASSERT_SAVE_APTR; 537 538 save_pushptrptr(*aptr, aptr, SAVEt_APTR); 539 } 540 541 void 542 Perl_save_pushptr(pTHX_ void *const ptr, const int type) 543 { 544 dVAR; 545 dSS_ADD; 546 SS_ADD_PTR(ptr); 547 SS_ADD_UV(type); 548 SS_ADD_END(2); 549 } 550 551 void 552 Perl_save_clearsv(pTHX_ SV **svp) 553 { 554 dVAR; 555 const UV offset = svp - PL_curpad; 556 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT; 557 558 PERL_ARGS_ASSERT_SAVE_CLEARSV; 559 560 ASSERT_CURPAD_ACTIVE("save_clearsv"); 561 SvPADSTALE_off(*svp); /* mark lexical as active */ 562 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) { 563 Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)", 564 offset, svp, PL_curpad); 565 } 566 567 { 568 dSS_ADD; 569 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV); 570 SS_ADD_END(1); 571 } 572 } 573 574 void 575 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) 576 { 577 dVAR; 578 579 PERL_ARGS_ASSERT_SAVE_DELETE; 580 581 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); 582 } 583 584 void 585 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) 586 { 587 STRLEN len; 588 I32 klen; 589 const char *key; 590 591 PERL_ARGS_ASSERT_SAVE_HDELETE; 592 593 key = SvPV_const(keysv, len); 594 klen = SvUTF8(keysv) ? -(I32)len : (I32)len; 595 SvREFCNT_inc_simple_void_NN(hv); 596 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE); 597 } 598 599 void 600 Perl_save_adelete(pTHX_ AV *av, SSize_t key) 601 { 602 dVAR; 603 dSS_ADD; 604 605 PERL_ARGS_ASSERT_SAVE_ADELETE; 606 607 SvREFCNT_inc_void(av); 608 SS_ADD_UV(key); 609 SS_ADD_PTR(av); 610 SS_ADD_IV(SAVEt_ADELETE); 611 SS_ADD_END(3); 612 } 613 614 void 615 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) 616 { 617 dVAR; 618 dSS_ADD; 619 620 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; 621 622 SS_ADD_DPTR(f); 623 SS_ADD_PTR(p); 624 SS_ADD_UV(SAVEt_DESTRUCTOR); 625 SS_ADD_END(3); 626 } 627 628 void 629 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) 630 { 631 dVAR; 632 dSS_ADD; 633 634 SS_ADD_DXPTR(f); 635 SS_ADD_PTR(p); 636 SS_ADD_UV(SAVEt_DESTRUCTOR_X); 637 SS_ADD_END(3); 638 } 639 640 void 641 Perl_save_hints(pTHX) 642 { 643 dVAR; 644 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); 645 if (PL_hints & HINT_LOCALIZE_HH) { 646 HV *oldhh = GvHV(PL_hintgv); 647 save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS); 648 GvHV(PL_hintgv) = NULL; /* in case copying dies */ 649 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh); 650 } else { 651 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS); 652 } 653 } 654 655 static void 656 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, 657 const int type) 658 { 659 dSS_ADD; 660 SS_ADD_PTR(ptr1); 661 SS_ADD_INT(i); 662 SS_ADD_PTR(ptr2); 663 SS_ADD_UV(type); 664 SS_ADD_END(4); 665 } 666 667 void 668 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, 669 const U32 flags) 670 { 671 dVAR; dSS_ADD; 672 SV *sv; 673 674 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; 675 676 SvGETMAGIC(*sptr); 677 SS_ADD_PTR(SvREFCNT_inc_simple(av)); 678 SS_ADD_IV(idx); 679 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 680 SS_ADD_UV(SAVEt_AELEM); 681 SS_ADD_END(4); 682 /* The array needs to hold a reference count on its new element, so it 683 must be AvREAL. */ 684 if (UNLIKELY(!AvREAL(av) && AvREIFY(av))) 685 av_reify(av); 686 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ 687 if (flags & SAVEf_KEEPOLDELEM) 688 return; 689 sv = *sptr; 690 /* If we're localizing a tied array element, this new sv 691 * won't actually be stored in the array - so it won't get 692 * reaped when the localize ends. Ensure it gets reaped by 693 * mortifying it instead. DAPM */ 694 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) 695 sv_2mortal(sv); 696 } 697 698 void 699 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) 700 { 701 dVAR; 702 SV *sv; 703 704 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS; 705 706 SvGETMAGIC(*sptr); 707 { 708 dSS_ADD; 709 SS_ADD_PTR(SvREFCNT_inc_simple(hv)); 710 SS_ADD_PTR(newSVsv(key)); 711 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 712 SS_ADD_UV(SAVEt_HELEM); 713 SS_ADD_END(4); 714 } 715 save_scalar_at(sptr, flags); 716 if (flags & SAVEf_KEEPOLDELEM) 717 return; 718 sv = *sptr; 719 /* If we're localizing a tied hash element, this new sv 720 * won't actually be stored in the hash - so it won't get 721 * reaped when the localize ends. Ensure it gets reaped by 722 * mortifying it instead. DAPM */ 723 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))) 724 sv_2mortal(sv); 725 } 726 727 SV* 728 Perl_save_svref(pTHX_ SV **sptr) 729 { 730 dVAR; 731 732 PERL_ARGS_ASSERT_SAVE_SVREF; 733 734 SvGETMAGIC(*sptr); 735 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF); 736 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 737 } 738 739 I32 740 Perl_save_alloc(pTHX_ I32 size, I32 pad) 741 { 742 dVAR; 743 const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] 744 - (char*)PL_savestack); 745 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); 746 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT; 747 748 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)) 749 Perl_croak(aTHX_ 750 "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")", 751 elems, (IV)size, (IV)pad); 752 753 SSGROW(elems + 1); 754 755 PL_savestack_ix += elems; 756 SSPUSHUV(SAVEt_ALLOC | elems_shifted); 757 return start; 758 } 759 760 761 762 #define ARG0_SV MUTABLE_SV(arg0.any_ptr) 763 #define ARG0_AV MUTABLE_AV(arg0.any_ptr) 764 #define ARG0_HV MUTABLE_HV(arg0.any_ptr) 765 #define ARG0_PTR arg0.any_ptr 766 #define ARG0_PV (char*)(arg0.any_ptr) 767 #define ARG0_PVP (char**)(arg0.any_ptr) 768 #define ARG0_I32 (arg0.any_i32) 769 770 #define ARG1_SV MUTABLE_SV(arg1.any_ptr) 771 #define ARG1_AV MUTABLE_AV(arg1.any_ptr) 772 #define ARG1_GV MUTABLE_GV(arg1.any_ptr) 773 #define ARG1_SVP (SV**)(arg1.any_ptr) 774 #define ARG1_PVP (char**)(arg1.any_ptr) 775 #define ARG1_PTR arg1.any_ptr 776 #define ARG1_PV (char*)(arg1.any_ptr) 777 #define ARG1_I32 (arg1.any_i32) 778 779 #define ARG2_SV MUTABLE_SV(arg2.any_ptr) 780 #define ARG2_AV MUTABLE_AV(arg2.any_ptr) 781 #define ARG2_HV MUTABLE_HV(arg2.any_ptr) 782 #define ARG2_GV MUTABLE_GV(arg2.any_ptr) 783 #define ARG2_PV (char*)(arg2.any_ptr) 784 785 void 786 Perl_leave_scope(pTHX_ I32 base) 787 { 788 dVAR; 789 790 /* Localise the effects of the TAINT_NOT inside the loop. */ 791 bool was = TAINT_get; 792 793 ANY arg0, arg1, arg2; 794 795 /* these initialisations are logically unnecessary, but they shut up 796 * spurious 'may be used uninitialized' compiler warnings */ 797 arg0.any_ptr = NULL; 798 arg1.any_ptr = NULL; 799 arg2.any_ptr = NULL; 800 801 if (UNLIKELY(base < -1)) 802 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); 803 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n", 804 (long)PL_savestack_ix, (long)base)); 805 while (PL_savestack_ix > base) { 806 UV uv; 807 U8 type; 808 809 SV *refsv; 810 SV **svp; 811 812 TAINT_NOT; 813 814 { 815 I32 ix = PL_savestack_ix - 1; 816 ANY *p = &PL_savestack[ix]; 817 uv = p->any_uv; 818 type = (U8)uv & SAVE_MASK; 819 if (type > SAVEt_ARG0_MAX) { 820 ANY *p0 = p; 821 arg0 = *--p; 822 if (type > SAVEt_ARG1_MAX) { 823 arg1 = *--p; 824 if (type > SAVEt_ARG2_MAX) { 825 arg2 = *--p; 826 } 827 } 828 ix -= (p0 - p); 829 } 830 PL_savestack_ix = ix; 831 } 832 833 switch (type) { 834 case SAVEt_ITEM: /* normal string */ 835 sv_replace(ARG1_SV, ARG0_SV); 836 if (UNLIKELY(SvSMAGICAL(ARG1_SV))) { 837 PL_localizing = 2; 838 mg_set(ARG1_SV); 839 PL_localizing = 0; 840 } 841 break; 842 843 /* This would be a mathom, but Perl_save_svref() calls a static 844 function, S_save_scalar_at(), so has to stay in this file. */ 845 case SAVEt_SVREF: /* scalar reference */ 846 svp = ARG1_SVP; 847 refsv = NULL; /* what to refcnt_dec */ 848 goto restore_sv; 849 850 case SAVEt_SV: /* scalar reference */ 851 svp = &GvSV(ARG1_GV); 852 refsv = ARG1_SV; /* what to refcnt_dec */ 853 restore_sv: 854 { 855 SV * const sv = *svp; 856 *svp = ARG0_SV; 857 SvREFCNT_dec(sv); 858 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) { 859 PL_localizing = 2; 860 mg_set(ARG0_SV); 861 PL_localizing = 0; 862 } 863 SvREFCNT_dec_NN(ARG0_SV); 864 SvREFCNT_dec(refsv); 865 break; 866 } 867 case SAVEt_GENERIC_PVREF: /* generic pv */ 868 if (*ARG0_PVP != ARG1_PV) { 869 Safefree(*ARG0_PVP); 870 *ARG0_PVP = ARG1_PV; 871 } 872 break; 873 case SAVEt_SHARED_PVREF: /* shared pv */ 874 if (*ARG1_PVP != ARG0_PV) { 875 #ifdef NETWARE 876 PerlMem_free(*ARG1_PVP); 877 #else 878 PerlMemShared_free(*ARG1_PVP); 879 #endif 880 *ARG1_PVP = ARG0_PV; 881 } 882 break; 883 case SAVEt_GVSV: /* scalar slot in GV */ 884 svp = &GvSV(ARG1_GV); 885 goto restore_svp; 886 case SAVEt_GENERIC_SVREF: /* generic sv */ 887 svp = ARG1_SVP; 888 restore_svp: 889 { 890 SV * const sv = *svp; 891 *svp = ARG0_SV; 892 SvREFCNT_dec(sv); 893 SvREFCNT_dec(ARG0_SV); 894 break; 895 } 896 case SAVEt_GVSLOT: /* any slot in GV */ 897 { 898 HV *const hv = GvSTASH(ARG2_GV); 899 svp = ARG1_SVP; 900 if (hv && HvENAME(hv) && ( 901 (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV) 902 || (*svp && SvTYPE(*svp) == SVt_PVCV) 903 )) 904 { 905 if ((char *)svp < (char *)GvGP(ARG2_GV) 906 || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp) 907 || GvREFCNT(ARG2_GV) > 1) 908 PL_sub_generation++; 909 else mro_method_changed_in(hv); 910 } 911 goto restore_svp; 912 } 913 case SAVEt_AV: /* array reference */ 914 SvREFCNT_dec(GvAV(ARG1_GV)); 915 GvAV(ARG1_GV) = ARG0_AV; 916 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) { 917 PL_localizing = 2; 918 mg_set(ARG0_SV); 919 PL_localizing = 0; 920 } 921 SvREFCNT_dec_NN(ARG1_GV); 922 break; 923 case SAVEt_HV: /* hash reference */ 924 SvREFCNT_dec(GvHV(ARG1_GV)); 925 GvHV(ARG1_GV) = ARG0_HV; 926 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) { 927 PL_localizing = 2; 928 mg_set(ARG0_SV); 929 PL_localizing = 0; 930 } 931 SvREFCNT_dec_NN(ARG1_GV); 932 break; 933 case SAVEt_INT_SMALL: 934 *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT); 935 break; 936 case SAVEt_INT: /* int reference */ 937 *(int*)ARG0_PTR = (int)ARG1_I32; 938 break; 939 case SAVEt_STRLEN: /* STRLEN/size_t ref */ 940 *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv; 941 break; 942 case SAVEt_BOOL: /* bool reference */ 943 *(bool*)ARG0_PTR = cBOOL(uv >> 8); 944 #ifdef NO_TAINT_SUPPORT 945 PERL_UNUSED_VAR(was); 946 #else 947 if (UNLIKELY(ARG0_PTR == &(TAINT_get))) { 948 /* If we don't update <was>, to reflect what was saved on the 949 * stack for PL_tainted, then we will overwrite this attempt to 950 * restore it when we exit this routine. Note that this won't 951 * work if this value was saved in a wider-than necessary type, 952 * such as I32 */ 953 was = *(bool*)ARG0_PTR; 954 } 955 #endif 956 break; 957 case SAVEt_I32_SMALL: 958 *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT); 959 break; 960 case SAVEt_I32: /* I32 reference */ 961 #ifdef PERL_DEBUG_READONLY_OPS 962 if (*(I32*)ARG0_PTR != ARG1_I32) 963 #endif 964 *(I32*)ARG0_PTR = ARG1_I32; 965 break; 966 case SAVEt_SPTR: /* SV* reference */ 967 *(SV**)(ARG0_PTR)= ARG1_SV; 968 break; 969 case SAVEt_VPTR: /* random* reference */ 970 case SAVEt_PPTR: /* char* reference */ 971 *ARG0_PVP = ARG1_PV; 972 break; 973 case SAVEt_HPTR: /* HV* reference */ 974 *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR); 975 break; 976 case SAVEt_APTR: /* AV* reference */ 977 *(AV**)ARG0_PTR = ARG1_AV; 978 break; 979 case SAVEt_GP: /* scalar reference */ 980 { 981 HV *hv; 982 /* possibly taking a method out of circulation */ 983 const bool had_method = !!GvCVu(ARG1_GV); 984 gp_free(ARG1_GV); 985 GvGP_set(ARG1_GV, (GP*)ARG0_PTR); 986 if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) { 987 if ( GvNAMELEN(ARG1_GV) == 3 988 && strnEQ(GvNAME(ARG1_GV), "ISA", 3) 989 ) 990 mro_isa_changed_in(hv); 991 else if (had_method || GvCVu(ARG1_GV)) 992 /* putting a method back into circulation ("local")*/ 993 gv_method_changed(ARG1_GV); 994 } 995 SvREFCNT_dec_NN(ARG1_GV); 996 break; 997 } 998 case SAVEt_FREESV: 999 SvREFCNT_dec(ARG0_SV); 1000 break; 1001 case SAVEt_FREECOPHH: 1002 cophh_free((COPHH *)ARG0_PTR); 1003 break; 1004 case SAVEt_MORTALIZESV: 1005 sv_2mortal(ARG0_SV); 1006 break; 1007 case SAVEt_FREEOP: 1008 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); 1009 op_free((OP*)ARG0_PTR); 1010 break; 1011 case SAVEt_FREEPV: 1012 Safefree(ARG0_PTR); 1013 break; 1014 1015 { 1016 SV **svp; 1017 I32 i; 1018 SV *sv; 1019 1020 case SAVEt_CLEARPADRANGE: 1021 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK); 1022 svp = &PL_curpad[uv >> 1023 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1; 1024 goto clearsv; 1025 case SAVEt_CLEARSV: 1026 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT]; 1027 i = 1; 1028 clearsv: 1029 for (; i; i--, svp--) { 1030 sv = *svp; 1031 1032 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1033 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n", 1034 PTR2UV(PL_comppad), PTR2UV(PL_curpad), 1035 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), 1036 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" 1037 )); 1038 1039 assert(SvPADMY(sv)); 1040 1041 /* Can clear pad variable in place? */ 1042 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) { 1043 1044 /* these flags are the union of all the relevant flags 1045 * in the individual conditions within */ 1046 if (UNLIKELY(SvFLAGS(sv) & ( 1047 SVf_READONLY /* for SvREADONLY_off() */ 1048 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */ 1049 | SVf_OOK 1050 | SVf_THINKFIRST))) 1051 { 1052 /* if a my variable that was made readonly is 1053 * going out of scope, we want to remove the 1054 * readonlyness so that it can go out of scope 1055 * quietly 1056 */ 1057 if (SvREADONLY(sv) && !SvFAKE(sv)) 1058 SvREADONLY_off(sv); 1059 1060 if (SvOOK(sv)) { /* OOK or HvAUX */ 1061 if (SvTYPE(sv) == SVt_PVHV) 1062 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); 1063 else 1064 sv_backoff(sv); 1065 } 1066 1067 if (SvMAGICAL(sv)) { 1068 /* note that backrefs (either in HvAUX or magic) 1069 * must be removed before other magic */ 1070 sv_unmagic(sv, PERL_MAGIC_backref); 1071 if (SvTYPE(sv) != SVt_PVCV) 1072 mg_free(sv); 1073 } 1074 if (SvTHINKFIRST(sv)) 1075 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF 1076 |SV_COW_DROP_PV); 1077 1078 } 1079 switch (SvTYPE(sv)) { 1080 case SVt_NULL: 1081 break; 1082 case SVt_PVAV: 1083 av_clear(MUTABLE_AV(sv)); 1084 break; 1085 case SVt_PVHV: 1086 hv_clear(MUTABLE_HV(sv)); 1087 break; 1088 case SVt_PVCV: 1089 { 1090 HEK * const hek = CvNAME_HEK((CV *)sv); 1091 assert(hek); 1092 share_hek_hek(hek); 1093 cv_undef((CV *)sv); 1094 CvNAME_HEK_set(sv, hek); 1095 break; 1096 } 1097 default: 1098 /* This looks odd, but these two macros are for use in 1099 expressions and finish with a trailing comma, so 1100 adding a ; after them would be wrong. */ 1101 assert_not_ROK(sv) 1102 assert_not_glob(sv) 1103 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8); 1104 break; 1105 } 1106 SvPADSTALE_on(sv); /* mark as no longer live */ 1107 } 1108 else { /* Someone has a claim on this, so abandon it. */ 1109 assert( SvFLAGS(sv) & SVs_PADMY); 1110 assert(!(SvFLAGS(sv) & SVs_PADTMP)); 1111 switch (SvTYPE(sv)) { /* Console ourselves with a new value */ 1112 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break; 1113 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break; 1114 case SVt_PVCV: 1115 { 1116 /* Create a stub */ 1117 *svp = newSV_type(SVt_PVCV); 1118 1119 /* Share name */ 1120 assert(CvNAMED(sv)); 1121 CvNAME_HEK_set(*svp, 1122 share_hek_hek(CvNAME_HEK((CV *)sv))); 1123 break; 1124 } 1125 default: *svp = newSV(0); break; 1126 } 1127 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */ 1128 /* preserve pad nature, but also mark as not live 1129 * for any closure capturing */ 1130 SvFLAGS(*svp) |= (SVs_PADMY|SVs_PADSTALE); 1131 } 1132 } 1133 break; 1134 } 1135 case SAVEt_DELETE: 1136 (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD); 1137 SvREFCNT_dec(ARG0_HV); 1138 Safefree(arg2.any_ptr); 1139 break; 1140 case SAVEt_ADELETE: 1141 (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD); 1142 SvREFCNT_dec(ARG0_AV); 1143 break; 1144 case SAVEt_DESTRUCTOR_X: 1145 (*arg1.any_dxptr)(aTHX_ ARG0_PTR); 1146 break; 1147 case SAVEt_REGCONTEXT: 1148 /* regexp must have croaked */ 1149 case SAVEt_ALLOC: 1150 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT; 1151 break; 1152 case SAVEt_STACK_POS: /* Position on Perl stack */ 1153 PL_stack_sp = PL_stack_base + arg0.any_i32; 1154 break; 1155 case SAVEt_AELEM: /* array element */ 1156 svp = av_fetch(ARG2_AV, arg1.any_iv, 1); 1157 if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */ 1158 SvREFCNT_dec(ARG0_SV); 1159 if (LIKELY(svp)) { 1160 SV * const sv = *svp; 1161 if (LIKELY(sv && sv != &PL_sv_undef)) { 1162 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied))) 1163 SvREFCNT_inc_void_NN(sv); 1164 refsv = ARG2_SV; 1165 goto restore_sv; 1166 } 1167 } 1168 SvREFCNT_dec(ARG2_AV); 1169 SvREFCNT_dec(ARG0_SV); 1170 break; 1171 case SAVEt_HELEM: /* hash element */ 1172 { 1173 HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0); 1174 SvREFCNT_dec(ARG1_SV); 1175 if (LIKELY(he)) { 1176 const SV * const oval = HeVAL(he); 1177 if (LIKELY(oval && oval != &PL_sv_undef)) { 1178 svp = &HeVAL(he); 1179 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied))) 1180 SvREFCNT_inc_void(*svp); 1181 refsv = ARG2_SV; /* what to refcnt_dec */ 1182 goto restore_sv; 1183 } 1184 } 1185 SvREFCNT_dec(ARG2_HV); 1186 SvREFCNT_dec(ARG0_SV); 1187 break; 1188 } 1189 case SAVEt_OP: 1190 PL_op = (OP*)ARG0_PTR; 1191 break; 1192 case SAVEt_HINTS: 1193 if ((PL_hints & HINT_LOCALIZE_HH)) { 1194 while (GvHV(PL_hintgv)) { 1195 HV *hv = GvHV(PL_hintgv); 1196 GvHV(PL_hintgv) = NULL; 1197 SvREFCNT_dec(MUTABLE_SV(hv)); 1198 } 1199 } 1200 cophh_free(CopHINTHASH_get(&PL_compiling)); 1201 CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR); 1202 *(I32*)&PL_hints = ARG1_I32; 1203 if (PL_hints & HINT_LOCALIZE_HH) { 1204 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); 1205 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR); 1206 } 1207 if (!GvHV(PL_hintgv)) { 1208 /* Need to add a new one manually, else rv2hv can 1209 add one via GvHVn and it won't have the magic set. */ 1210 HV *const hv = newHV(); 1211 hv_magic(hv, NULL, PERL_MAGIC_hints); 1212 GvHV(PL_hintgv) = hv; 1213 } 1214 assert(GvHV(PL_hintgv)); 1215 break; 1216 case SAVEt_COMPPAD: 1217 PL_comppad = (PAD*)ARG0_PTR; 1218 if (LIKELY(PL_comppad)) 1219 PL_curpad = AvARRAY(PL_comppad); 1220 else 1221 PL_curpad = NULL; 1222 break; 1223 case SAVEt_PADSV_AND_MORTALIZE: 1224 { 1225 SV **svp; 1226 assert (ARG1_PTR); 1227 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv; 1228 /* This mortalizing used to be done by POPLOOP() via itersave. 1229 But as we have all the information here, we can do it here, 1230 save even having to have itersave in the struct. */ 1231 sv_2mortal(*svp); 1232 *svp = ARG2_SV; 1233 } 1234 break; 1235 case SAVEt_SAVESWITCHSTACK: 1236 { 1237 dSP; 1238 SWITCHSTACK(ARG0_AV, ARG1_AV); 1239 PL_curstackinfo->si_stack = ARG1_AV; 1240 } 1241 break; 1242 case SAVEt_SET_SVFLAGS: 1243 SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32); 1244 SvFLAGS(ARG2_SV) |= (U32)ARG0_I32; 1245 break; 1246 1247 /* These are only saved in mathoms.c */ 1248 case SAVEt_NSTAB: 1249 (void)sv_clear(ARG0_SV); 1250 break; 1251 case SAVEt_LONG: /* long reference */ 1252 *(long*)ARG0_PTR = arg1.any_long; 1253 break; 1254 case SAVEt_IV: /* IV reference */ 1255 *(IV*)ARG0_PTR = arg1.any_iv; 1256 break; 1257 1258 case SAVEt_I16: /* I16 reference */ 1259 *(I16*)ARG0_PTR = (I16)(uv >> 8); 1260 break; 1261 case SAVEt_I8: /* I8 reference */ 1262 *(I8*)ARG0_PTR = (I8)(uv >> 8); 1263 break; 1264 case SAVEt_DESTRUCTOR: 1265 (*arg1.any_dptr)(ARG0_PTR); 1266 break; 1267 case SAVEt_COMPILE_WARNINGS: 1268 if (!specialWARN(PL_compiling.cop_warnings)) 1269 PerlMemShared_free(PL_compiling.cop_warnings); 1270 1271 PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR; 1272 break; 1273 case SAVEt_PARSER: 1274 parser_free((yy_parser *) ARG0_PTR); 1275 break; 1276 case SAVEt_READONLY_OFF: 1277 SvREADONLY_off(ARG0_SV); 1278 break; 1279 default: 1280 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type); 1281 } 1282 } 1283 1284 TAINT_set(was); 1285 } 1286 1287 void 1288 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) 1289 { 1290 dVAR; 1291 1292 PERL_ARGS_ASSERT_CX_DUMP; 1293 1294 #ifdef DEBUGGING 1295 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); 1296 if (CxTYPE(cx) != CXt_SUBST) { 1297 const char *gimme_text; 1298 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); 1299 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n", 1300 PTR2UV(cx->blk_oldcop)); 1301 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); 1302 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); 1303 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n", 1304 PTR2UV(cx->blk_oldpm)); 1305 switch (cx->blk_gimme) { 1306 case G_VOID: 1307 gimme_text = "VOID"; 1308 break; 1309 case G_SCALAR: 1310 gimme_text = "SCALAR"; 1311 break; 1312 case G_ARRAY: 1313 gimme_text = "LIST"; 1314 break; 1315 default: 1316 gimme_text = "UNKNOWN"; 1317 break; 1318 } 1319 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text); 1320 } 1321 switch (CxTYPE(cx)) { 1322 case CXt_NULL: 1323 case CXt_BLOCK: 1324 break; 1325 case CXt_FORMAT: 1326 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n", 1327 PTR2UV(cx->blk_format.cv)); 1328 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n", 1329 PTR2UV(cx->blk_format.gv)); 1330 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n", 1331 PTR2UV(cx->blk_format.dfoutgv)); 1332 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n", 1333 (int)CxHASARGS(cx)); 1334 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n", 1335 PTR2UV(cx->blk_format.retop)); 1336 break; 1337 case CXt_SUB: 1338 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", 1339 PTR2UV(cx->blk_sub.cv)); 1340 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", 1341 (long)cx->blk_sub.olddepth); 1342 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", 1343 (int)CxHASARGS(cx)); 1344 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); 1345 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", 1346 PTR2UV(cx->blk_sub.retop)); 1347 break; 1348 case CXt_EVAL: 1349 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", 1350 (long)CxOLD_IN_EVAL(cx)); 1351 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", 1352 PL_op_name[CxOLD_OP_TYPE(cx)], 1353 PL_op_desc[CxOLD_OP_TYPE(cx)]); 1354 if (cx->blk_eval.old_namesv) 1355 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", 1356 SvPVX_const(cx->blk_eval.old_namesv)); 1357 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n", 1358 PTR2UV(cx->blk_eval.old_eval_root)); 1359 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n", 1360 PTR2UV(cx->blk_eval.retop)); 1361 break; 1362 1363 case CXt_LOOP_LAZYIV: 1364 case CXt_LOOP_LAZYSV: 1365 case CXt_LOOP_FOR: 1366 case CXt_LOOP_PLAIN: 1367 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); 1368 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", 1369 (long)cx->blk_loop.resetsp); 1370 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n", 1371 PTR2UV(cx->blk_loop.my_op)); 1372 /* XXX: not accurate for LAZYSV/IV */ 1373 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n", 1374 PTR2UV(cx->blk_loop.state_u.ary.ary)); 1375 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", 1376 (long)cx->blk_loop.state_u.ary.ix); 1377 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", 1378 PTR2UV(CxITERVAR(cx))); 1379 break; 1380 1381 case CXt_SUBST: 1382 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", 1383 (long)cx->sb_iters); 1384 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", 1385 (long)cx->sb_maxiters); 1386 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", 1387 (long)cx->sb_rflags); 1388 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", 1389 (long)CxONCE(cx)); 1390 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", 1391 cx->sb_orig); 1392 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n", 1393 PTR2UV(cx->sb_dstr)); 1394 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n", 1395 PTR2UV(cx->sb_targ)); 1396 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n", 1397 PTR2UV(cx->sb_s)); 1398 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n", 1399 PTR2UV(cx->sb_m)); 1400 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n", 1401 PTR2UV(cx->sb_strend)); 1402 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n", 1403 PTR2UV(cx->sb_rxres)); 1404 break; 1405 } 1406 #else 1407 PERL_UNUSED_CONTEXT; 1408 PERL_UNUSED_ARG(cx); 1409 #endif /* DEBUGGING */ 1410 } 1411 1412 /* 1413 * Local variables: 1414 * c-indentation-style: bsd 1415 * c-basic-offset: 4 1416 * indent-tabs-mode: nil 1417 * End: 1418 * 1419 * ex: set ts=8 sts=4 sw=4 et: 1420 */ 1421