scope.c

   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, int 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 (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_ I32 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 I32 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 (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 (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 (!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 (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 (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 ((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 ((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 /* Cannot use save_sptr() to store a char* since the SV** cast will
 461  * force word-alignment and we'll miss the pointer.
 462  */
 463 void
 464 Perl_save_pptr(pTHX_ char **pptr)
 465 {
 466     dVAR;
 467
 468     PERL_ARGS_ASSERT_SAVE_PPTR;
 469
 470     save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
 471 }
 472
 473 void
 474 Perl_save_vptr(pTHX_ void *ptr)
 475 {
 476     dVAR;
 477
 478     PERL_ARGS_ASSERT_SAVE_VPTR;
 479
 480     save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
 481 }
 482
 483 void
 484 Perl_save_sptr(pTHX_ SV **sptr)
 485 {
 486     dVAR;
 487
 488     PERL_ARGS_ASSERT_SAVE_SPTR;
 489
 490     save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
 491 }
 492
 493 void
 494 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
 495 {
 496     dVAR;
 497     dSS_ADD;
 498
 499     ASSERT_CURPAD_ACTIVE("save_padsv");
 500     SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
 501     SS_ADD_PTR(PL_comppad);
 502     SS_ADD_UV((UV)off);
 503     SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
 504     SS_ADD_END(4);
 505 }
 506
 507 void
 508 Perl_save_hptr(pTHX_ HV **hptr)
 509 {
 510     dVAR;
 511
 512     PERL_ARGS_ASSERT_SAVE_HPTR;
 513
 514     save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
 515 }
 516
 517 void
 518 Perl_save_aptr(pTHX_ AV **aptr)
 519 {
 520     dVAR;
 521
 522     PERL_ARGS_ASSERT_SAVE_APTR;
 523
 524     save_pushptrptr(*aptr, aptr, SAVEt_APTR);
 525 }
 526
 527 void
 528 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
 529 {
 530     dVAR;
 531     dSS_ADD;
 532     SS_ADD_PTR(ptr);
 533     SS_ADD_UV(type);
 534     SS_ADD_END(2);
 535 }
 536
 537 void
 538 Perl_save_clearsv(pTHX_ SV **svp)
 539 {
 540     dVAR;
 541     const UV offset = svp - PL_curpad;
 542     const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
 543
 544     PERL_ARGS_ASSERT_SAVE_CLEARSV;
 545
 546     ASSERT_CURPAD_ACTIVE("save_clearsv");
 547     SvPADSTALE_off(*svp); /* mark lexical as active */
 548     if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset) {
 549         Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
 550                    offset, svp, PL_curpad);
 551     }
 552
 553     {
 554         dSS_ADD;
 555         SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
 556         SS_ADD_END(1);
 557     }
 558 }
 559
 560 void
 561 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 562 {
 563     dVAR;
 564
 565     PERL_ARGS_ASSERT_SAVE_DELETE;
 566
 567     save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
 568 }
 569
 570 void
 571 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
 572 {
 573     STRLEN len;
 574     I32 klen;
 575     const char *key;
 576
 577     PERL_ARGS_ASSERT_SAVE_HDELETE;
 578
 579     key  = SvPV_const(keysv, len);
 580     klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
 581     SvREFCNT_inc_simple_void_NN(hv);
 582     save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
 583 }
 584
 585 void
 586 Perl_save_adelete(pTHX_ AV *av, I32 key)
 587 {
 588     dVAR;
 589
 590     PERL_ARGS_ASSERT_SAVE_ADELETE;
 591
 592     SvREFCNT_inc_void(av);
 593     save_pushi32ptr(key, av, SAVEt_ADELETE);
 594 }
 595
 596 void
 597 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 598 {
 599     dVAR;
 600     dSS_ADD;
 601
 602     PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
 603
 604     SS_ADD_DPTR(f);
 605     SS_ADD_PTR(p);
 606     SS_ADD_UV(SAVEt_DESTRUCTOR);
 607     SS_ADD_END(3);
 608 }
 609
 610 void
 611 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 612 {
 613     dVAR;
 614     dSS_ADD;
 615
 616     SS_ADD_DXPTR(f);
 617     SS_ADD_PTR(p);
 618     SS_ADD_UV(SAVEt_DESTRUCTOR_X);
 619     SS_ADD_END(3);
 620 }
 621
 622 void
 623 Perl_save_hints(pTHX)
 624 {
 625     dVAR;
 626     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
 627     if (PL_hints & HINT_LOCALIZE_HH) {
 628         HV *oldhh = GvHV(PL_hintgv);
 629         save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
 630         GvHV(PL_hintgv) = NULL; /* in case copying dies */
 631         GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
 632     } else {
 633         save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
 634     }
 635 }
 636
 637 static void
 638 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
 639                         const int type)
 640 {
 641     dSS_ADD;
 642     SS_ADD_PTR(ptr1);
 643     SS_ADD_INT(i);
 644     SS_ADD_PTR(ptr2);
 645     SS_ADD_UV(type);
 646     SS_ADD_END(4);
 647 }
 648
 649 void
 650 Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
 651 {
 652     dVAR;
 653     SV *sv;
 654
 655     PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
 656
 657     SvGETMAGIC(*sptr);
 658     save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr),
 659                        SAVEt_AELEM);
 660     /* The array needs to hold a reference count on its new element, so it
 661        must be AvREAL. */
 662     if (!AvREAL(av) && AvREIFY(av))
 663         av_reify(av);
 664     save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
 665     if (flags & SAVEf_KEEPOLDELEM)
 666         return;
 667     sv = *sptr;
 668     /* If we're localizing a tied array element, this new sv
 669      * won't actually be stored in the array - so it won't get
 670      * reaped when the localize ends. Ensure it gets reaped by
 671      * mortifying it instead. DAPM */
 672     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 673         sv_2mortal(sv);
 674 }
 675
 676 void
 677 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
 678 {
 679     dVAR;
 680     SV *sv;
 681
 682     PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
 683
 684     SvGETMAGIC(*sptr);
 685     {
 686         dSS_ADD;
 687         SS_ADD_PTR(SvREFCNT_inc_simple(hv));
 688         SS_ADD_PTR(newSVsv(key));
 689         SS_ADD_PTR(SvREFCNT_inc(*sptr));
 690         SS_ADD_UV(SAVEt_HELEM);
 691         SS_ADD_END(4);
 692     }
 693     save_scalar_at(sptr, flags);
 694     if (flags & SAVEf_KEEPOLDELEM)
 695         return;
 696     sv = *sptr;
 697     /* If we're localizing a tied hash element, this new sv
 698      * won't actually be stored in the hash - so it won't get
 699      * reaped when the localize ends. Ensure it gets reaped by
 700      * mortifying it instead. DAPM */
 701     if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
 702         sv_2mortal(sv);
 703 }
 704
 705 SV*
 706 Perl_save_svref(pTHX_ SV **sptr)
 707 {
 708     dVAR;
 709
 710     PERL_ARGS_ASSERT_SAVE_SVREF;
 711
 712     SvGETMAGIC(*sptr);
 713     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
 714     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
 715 }
 716
 717 I32
 718 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 719 {
 720     dVAR;
 721     const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
 722                           - (char*)PL_savestack);
 723     const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
 724     const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
 725
 726     if ((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)
 727         Perl_croak(aTHX_
 728             "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")",
 729                    elems, (IV)size, (IV)pad);
 730
 731     SSGROW(elems + 1);
 732
 733     PL_savestack_ix += elems;
 734     SSPUSHUV(SAVEt_ALLOC | elems_shifted);
 735     return start;
 736 }
 737
 738
 739
 740 #define ARG0_SV  MUTABLE_SV(arg0.any_ptr)
 741 #define ARG0_AV  MUTABLE_AV(arg0.any_ptr)
 742 #define ARG0_HV  MUTABLE_HV(arg0.any_ptr)
 743 #define ARG0_PTR arg0.any_ptr
 744 #define ARG0_PV  (char*)(arg0.any_ptr)
 745 #define ARG0_PVP (char**)(arg0.any_ptr)
 746 #define ARG0_I32 (arg0.any_i32)
 747
 748 #define ARG1_SV  MUTABLE_SV(arg1.any_ptr)
 749 #define ARG1_AV  MUTABLE_AV(arg1.any_ptr)
 750 #define ARG1_GV  MUTABLE_GV(arg1.any_ptr)
 751 #define ARG1_SVP (SV**)(arg1.any_ptr)
 752 #define ARG1_PVP (char**)(arg1.any_ptr)
 753 #define ARG1_PTR arg1.any_ptr
 754 #define ARG1_PV  (char*)(arg1.any_ptr)
 755 #define ARG1_I32 (arg1.any_i32)
 756
 757 #define ARG2_SV  MUTABLE_SV(arg2.any_ptr)
 758 #define ARG2_AV  MUTABLE_AV(arg2.any_ptr)
 759 #define ARG2_HV  MUTABLE_HV(arg2.any_ptr)
 760 #define ARG2_GV  MUTABLE_GV(arg2.any_ptr)
 761 #define ARG2_PV  (char*)(arg2.any_ptr)
 762
 763 void
 764 Perl_leave_scope(pTHX_ I32 base)
 765 {
 766     dVAR;
 767
 768     /* Localise the effects of the TAINT_NOT inside the loop.  */
 769     bool was = TAINT_get;
 770
 771     ANY arg0, arg1, arg2;
 772
 773     /* these initialisations are logically unnecessary, but they shut up
 774      * spurious 'may be used uninitialized' compiler warnings */
 775     arg0.any_ptr = NULL;
 776     arg1.any_ptr = NULL;
 777     arg2.any_ptr = NULL;
 778
 779     if (base < -1)
 780         Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
 781     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
 782                         (long)PL_savestack_ix, (long)base));
 783     while (PL_savestack_ix > base) {
 784         UV uv;
 785         U8 type;
 786
 787         SV *refsv;
 788         SV **svp;
 789
 790         TAINT_NOT;
 791
 792         {
 793             I32 ix = PL_savestack_ix - 1;
 794             ANY *p = &PL_savestack[ix];
 795             uv = p->any_uv;
 796             type = (U8)uv & SAVE_MASK;
 797             if (type > SAVEt_ARG0_MAX) {
 798                 ANY *p0 = p;
 799                 arg0 = *--p;
 800                 if (type > SAVEt_ARG1_MAX) {
 801                     arg1 = *--p;
 802                     if (type > SAVEt_ARG2_MAX) {
 803                         arg2 = *--p;
 804                     }
 805                 }
 806                 ix -= (p0 - p);
 807             }
 808             PL_savestack_ix = ix;
 809         }
 810
 811         switch (type) {
 812         case SAVEt_ITEM:                        /* normal string */
 813             sv_replace(ARG1_SV, ARG0_SV);
 814             if (SvSMAGICAL(ARG1_SV)) {
 815                 PL_localizing = 2;
 816                 mg_set(ARG1_SV);
 817                 PL_localizing = 0;
 818             }
 819             break;
 820
 821             /* This would be a mathom, but Perl_save_svref() calls a static
 822                function, S_save_scalar_at(), so has to stay in this file.  */
 823         case SAVEt_SVREF:                       /* scalar reference */
 824             svp = ARG1_SVP;
 825             refsv = NULL; /* what to refcnt_dec */
 826             goto restore_sv;
 827
 828         case SAVEt_SV:                          /* scalar reference */
 829             svp = &GvSV(ARG1_GV);
 830             refsv = ARG1_SV; /* what to refcnt_dec */
 831         restore_sv:
 832         {
 833             SV * const sv = *svp;
 834             *svp = ARG0_SV;
 835             SvREFCNT_dec(sv);
 836             if (SvSMAGICAL(ARG0_SV)) {
 837                 PL_localizing = 2;
 838                 mg_set(ARG0_SV);
 839                 PL_localizing = 0;
 840             }
 841             SvREFCNT_dec_NN(ARG0_SV);
 842             SvREFCNT_dec(refsv);
 843             break;
 844         }
 845         case SAVEt_GENERIC_PVREF:               /* generic pv */
 846             if (*ARG0_PVP != ARG1_PV) {
 847                 Safefree(*ARG0_PVP);
 848                 *ARG0_PVP = ARG1_PV;
 849             }
 850             break;
 851         case SAVEt_SHARED_PVREF:                /* shared pv */
 852             if (*ARG1_PVP != ARG0_PV) {
 853 #ifdef NETWARE
 854                 PerlMem_free(*ARG1_PVP);
 855 #else
 856                 PerlMemShared_free(*ARG1_PVP);
 857 #endif
 858                 *ARG1_PVP = ARG0_PV;
 859             }
 860             break;
 861         case SAVEt_GVSV:                        /* scalar slot in GV */
 862             svp = &GvSV(ARG1_GV);
 863             goto restore_svp;
 864         case SAVEt_GENERIC_SVREF:               /* generic sv */
 865             svp = ARG1_SVP;
 866         restore_svp:
 867         {
 868             SV * const sv = *svp;
 869             *svp = ARG0_SV;
 870             SvREFCNT_dec(sv);
 871             SvREFCNT_dec(ARG0_SV);
 872             break;
 873         }
 874         case SAVEt_GVSLOT:                      /* any slot in GV */
 875         {
 876             HV *const hv = GvSTASH(ARG2_GV);
 877             svp = ARG1_SVP;
 878             if (hv && HvENAME(hv) && (
 879                     (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
 880                  || (*svp && SvTYPE(*svp) == SVt_PVCV)
 881                ))
 882             {
 883                 if ((char *)svp < (char *)GvGP(ARG2_GV)
 884                  || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
 885                  || GvREFCNT(ARG2_GV) > 1)
 886                     PL_sub_generation++;
 887                 else mro_method_changed_in(hv);
 888             }
 889             goto restore_svp;
 890         }
 891         case SAVEt_AV:                          /* array reference */
 892             SvREFCNT_dec(GvAV(ARG1_GV));
 893             GvAV(ARG1_GV) = ARG0_AV;
 894             if (SvSMAGICAL(ARG0_SV)) {
 895                 PL_localizing = 2;
 896                 mg_set(ARG0_SV);
 897                 PL_localizing = 0;
 898             }
 899             SvREFCNT_dec_NN(ARG1_GV);
 900             break;
 901         case SAVEt_HV:                          /* hash reference */
 902             SvREFCNT_dec(GvHV(ARG1_GV));
 903             GvHV(ARG1_GV) = ARG0_HV;
 904             if (SvSMAGICAL(ARG0_SV)) {
 905                 PL_localizing = 2;
 906                 mg_set(ARG0_SV);
 907                 PL_localizing = 0;
 908             }
 909             SvREFCNT_dec_NN(ARG1_GV);
 910             break;
 911         case SAVEt_INT_SMALL:
 912             *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
 913             break;
 914         case SAVEt_INT:                         /* int reference */
 915             *(int*)ARG0_PTR = (int)ARG1_I32;
 916             break;
 917         case SAVEt_BOOL:                        /* bool reference */
 918             *(bool*)ARG0_PTR = cBOOL(uv >> 8);
 919 #ifdef NO_TAINT_SUPPORT
 920             PERL_UNUSED_VAR(was);
 921 #else
 922             if (ARG0_PTR == &(TAINT_get)) {
 923                 /* If we don't update <was>, to reflect what was saved on the
 924                  * stack for PL_tainted, then we will overwrite this attempt to
 925                  * restore it when we exit this routine.  Note that this won't
 926                  * work if this value was saved in a wider-than necessary type,
 927                  * such as I32 */
 928                 was = *(bool*)ARG0_PTR;
 929             }
 930 #endif
 931             break;
 932         case SAVEt_I32_SMALL:
 933             *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
 934             break;
 935         case SAVEt_I32:                         /* I32 reference */
 936 #ifdef PERL_DEBUG_READONLY_OPS
 937             if (*(I32*)ARG0_PTR != ARG1_I32)
 938 #endif
 939                 *(I32*)ARG0_PTR = ARG1_I32;
 940             break;
 941         case SAVEt_SPTR:                        /* SV* reference */
 942             *(SV**)(ARG0_PTR)= ARG1_SV;
 943             break;
 944         case SAVEt_VPTR:                        /* random* reference */
 945         case SAVEt_PPTR:                        /* char* reference */
 946             *ARG0_PVP = ARG1_PV;
 947             break;
 948         case SAVEt_HPTR:                        /* HV* reference */
 949             *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
 950             break;
 951         case SAVEt_APTR:                        /* AV* reference */
 952             *(AV**)ARG0_PTR = ARG1_AV;
 953             break;
 954         case SAVEt_GP:                          /* scalar reference */
 955         {
 956             HV *hv;
 957             /* possibly taking a method out of circulation */
 958             const bool had_method = !!GvCVu(ARG1_GV);
 959             gp_free(ARG1_GV);
 960             GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
 961             if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
 962                 if (   GvNAMELEN(ARG1_GV) == 3
 963                     && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
 964                 )
 965                     mro_isa_changed_in(hv);
 966                 else if (had_method || GvCVu(ARG1_GV))
 967                     /* putting a method back into circulation ("local")*/
 968                     gv_method_changed(ARG1_GV);
 969             }
 970             SvREFCNT_dec_NN(ARG1_GV);
 971             break;
 972         }
 973         case SAVEt_FREESV:
 974             SvREFCNT_dec(ARG0_SV);
 975             break;
 976         case SAVEt_FREECOPHH:
 977             cophh_free((COPHH *)ARG0_PTR);
 978             break;
 979         case SAVEt_MORTALIZESV:
 980             sv_2mortal(ARG0_SV);
 981             break;
 982         case SAVEt_FREEOP:
 983             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
 984             op_free((OP*)ARG0_PTR);
 985             break;
 986         case SAVEt_FREEPV:
 987             Safefree(ARG0_PTR);
 988             break;
 989
 990         {
 991           SV **svp;
 992           I32 i;
 993           SV *sv;
 994
 995         case SAVEt_CLEARPADRANGE:
 996             i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
 997             svp = &PL_curpad[uv >>
 998                     (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
 999             goto clearsv;
1000         case SAVEt_CLEARSV:
1001             svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1002             i = 1;
1003           clearsv:
1004             for (; i; i--, svp--) {
1005                 sv = *svp;
1006
1007                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1008              "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
1009                     PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1010                     (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1011                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1012                 ));
1013
1014                 /* Can clear pad variable in place? */
1015                 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
1016                     /*
1017                      * if a my variable that was made readonly is going out of
1018                      * scope, we want to remove the readonlyness so that it can
1019                      * go out of scope quietly
1020                      */
1021                     if (SvPADMY(sv) && !SvFAKE(sv))
1022                         SvREADONLY_off(sv);
1023
1024                     if (SvTHINKFIRST(sv))
1025                         sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1026                                                  |SV_COW_DROP_PV);
1027                     if (SvTYPE(sv) == SVt_PVHV)
1028                         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1029                     if (SvMAGICAL(sv))
1030                     {
1031                       sv_unmagic(sv, PERL_MAGIC_backref);
1032                       if (SvTYPE(sv) != SVt_PVCV)
1033                         mg_free(sv);
1034                     }
1035
1036                     switch (SvTYPE(sv)) {
1037                     case SVt_NULL:
1038                         break;
1039                     case SVt_PVAV:
1040                         av_clear(MUTABLE_AV(sv));
1041                         break;
1042                     case SVt_PVHV:
1043                         hv_clear(MUTABLE_HV(sv));
1044                         break;
1045                     case SVt_PVCV:
1046                     {
1047                         HEK * const hek = CvNAME_HEK((CV *)sv);
1048                         assert(hek);
1049                         share_hek_hek(hek);
1050                         cv_undef((CV *)sv);
1051                         CvNAME_HEK_set(sv, hek);
1052                         break;
1053                     }
1054                     default:
1055                         SvOK_off(sv);
1056                         break;
1057                     }
1058                     SvPADSTALE_on(sv); /* mark as no longer live */
1059                 }
1060                 else {  /* Someone has a claim on this, so abandon it. */
1061                     assert(  SvFLAGS(sv) & SVs_PADMY);
1062                     assert(!(SvFLAGS(sv) & SVs_PADTMP));
1063                     switch (SvTYPE(sv)) {       /* Console ourselves with a new value */
1064                     case SVt_PVAV:      *svp = MUTABLE_SV(newAV());     break;
1065                     case SVt_PVHV:      *svp = MUTABLE_SV(newHV());     break;
1066                     case SVt_PVCV:
1067                     {
1068                         /* Create a stub */
1069                         *svp = newSV_type(SVt_PVCV);
1070
1071                         /* Share name */
1072                         assert(CvNAMED(sv));
1073                         CvNAME_HEK_set(*svp,
1074                             share_hek_hek(CvNAME_HEK((CV *)sv)));
1075                         break;
1076                     }
1077                     default:    *svp = newSV(0);                break;
1078                     }
1079                     SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1080                     /* preserve pad nature, but also mark as not live
1081                      * for any closure capturing */
1082                     SvFLAGS(*svp) |= (SVs_PADMY|SVs_PADSTALE);
1083                 }
1084             }
1085             break;
1086         }
1087         case SAVEt_DELETE:
1088             (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
1089             SvREFCNT_dec(ARG0_HV);
1090             Safefree(arg2.any_ptr);
1091             break;
1092         case SAVEt_ADELETE:
1093             (void)av_delete(ARG0_AV, ARG1_I32, G_DISCARD);
1094             SvREFCNT_dec(ARG0_AV);
1095             break;
1096         case SAVEt_DESTRUCTOR_X:
1097             (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
1098             break;
1099         case SAVEt_REGCONTEXT:
1100             /* regexp must have croaked */
1101         case SAVEt_ALLOC:
1102             PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1103             break;
1104         case SAVEt_STACK_POS:           /* Position on Perl stack */
1105             PL_stack_sp = PL_stack_base + arg0.any_i32;
1106             break;
1107         case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
1108             cxstack[ARG0_I32].blk_oldsp = ARG1_I32;
1109             break;
1110         case SAVEt_AELEM:               /* array element */
1111             svp = av_fetch(ARG2_AV, ARG1_I32, 1);
1112             if (!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV)) /* undo reify guard */
1113                 SvREFCNT_dec(ARG0_SV);
1114             if (svp) {
1115                 SV * const sv = *svp;
1116                 if (sv && sv != &PL_sv_undef) {
1117                     if (SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied))
1118                         SvREFCNT_inc_void_NN(sv);
1119                     refsv = ARG2_SV;
1120                     goto restore_sv;
1121                 }
1122             }
1123             SvREFCNT_dec(ARG2_AV);
1124             SvREFCNT_dec(ARG0_SV);
1125             break;
1126         case SAVEt_HELEM:               /* hash element */
1127         {
1128             HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
1129             SvREFCNT_dec(ARG1_SV);
1130             if (he) {
1131                 const SV * const oval = HeVAL(he);
1132                 if (oval && oval != &PL_sv_undef) {
1133                     svp = &HeVAL(he);
1134                     if (SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied))
1135                         SvREFCNT_inc_void(*svp);
1136                     refsv = ARG2_SV; /* what to refcnt_dec */
1137                     goto restore_sv;
1138                 }
1139             }
1140             SvREFCNT_dec(ARG2_HV);
1141             SvREFCNT_dec(ARG0_SV);
1142             break;
1143         }
1144         case SAVEt_OP:
1145             PL_op = (OP*)ARG0_PTR;
1146             break;
1147         case SAVEt_HINTS:
1148             if ((PL_hints & HINT_LOCALIZE_HH)) {
1149               while (GvHV(PL_hintgv)) {
1150                 HV *hv = GvHV(PL_hintgv);
1151                 GvHV(PL_hintgv) = NULL;
1152                 SvREFCNT_dec(MUTABLE_SV(hv));
1153               }
1154             }
1155             cophh_free(CopHINTHASH_get(&PL_compiling));
1156             CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
1157             *(I32*)&PL_hints = ARG1_I32;
1158             if (PL_hints & HINT_LOCALIZE_HH) {
1159                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1160                 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
1161             }
1162             if (!GvHV(PL_hintgv)) {
1163                 /* Need to add a new one manually, else rv2hv can
1164                    add one via GvHVn and it won't have the magic set.  */
1165                 HV *const hv = newHV();
1166                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1167                 GvHV(PL_hintgv) = hv;
1168             }
1169             assert(GvHV(PL_hintgv));
1170             break;
1171         case SAVEt_COMPPAD:
1172             PL_comppad = (PAD*)ARG0_PTR;
1173             if (PL_comppad)
1174                 PL_curpad = AvARRAY(PL_comppad);
1175             else
1176                 PL_curpad = NULL;
1177             break;
1178         case SAVEt_PADSV_AND_MORTALIZE:
1179             {
1180                 SV **svp;
1181                 assert (ARG1_PTR);
1182                 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
1183                 /* This mortalizing used to be done by POPLOOP() via itersave.
1184                    But as we have all the information here, we can do it here,
1185                    save even having to have itersave in the struct.  */
1186                 sv_2mortal(*svp);
1187                 *svp = ARG2_SV;
1188             }
1189             break;
1190         case SAVEt_SAVESWITCHSTACK:
1191             {
1192                 dSP;
1193                 SWITCHSTACK(ARG0_AV, ARG1_AV);
1194                 PL_curstackinfo->si_stack = ARG1_AV;
1195             }
1196             break;
1197         case SAVEt_SET_SVFLAGS:
1198             SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
1199             SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
1200             break;
1201
1202             /* These are only saved in mathoms.c */
1203         case SAVEt_NSTAB:
1204             (void)sv_clear(ARG0_SV);
1205             break;
1206         case SAVEt_LONG:                        /* long reference */
1207             *(long*)ARG0_PTR = arg1.any_long;
1208             break;
1209         case SAVEt_IV:                          /* IV reference */
1210             *(IV*)ARG0_PTR = arg1.any_iv;
1211             break;
1212
1213         case SAVEt_I16:                         /* I16 reference */
1214             *(I16*)ARG0_PTR = (I16)(uv >> 8);
1215             break;
1216         case SAVEt_I8:                          /* I8 reference */
1217             *(I8*)ARG0_PTR = (I8)(uv >> 8);
1218             break;
1219         case SAVEt_DESTRUCTOR:
1220             (*arg1.any_dptr)(ARG0_PTR);
1221             break;
1222         case SAVEt_COMPILE_WARNINGS:
1223             if (!specialWARN(PL_compiling.cop_warnings))
1224                 PerlMemShared_free(PL_compiling.cop_warnings);
1225
1226             PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
1227             break;
1228         case SAVEt_PARSER:
1229             parser_free((yy_parser *) ARG0_PTR);
1230             break;
1231         case SAVEt_READONLY_OFF:
1232             SvREADONLY_off(ARG0_SV);
1233             break;
1234         default:
1235             Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
1236         }
1237     }
1238
1239     TAINT_set(was);
1240 }
1241
1242 void
1243 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1244 {
1245     dVAR;
1246
1247     PERL_ARGS_ASSERT_CX_DUMP;
1248
1249 #ifdef DEBUGGING
1250     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1251     if (CxTYPE(cx) != CXt_SUBST) {
1252         const char *gimme_text;
1253         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1254         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1255                       PTR2UV(cx->blk_oldcop));
1256         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1257         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1258         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1259                       PTR2UV(cx->blk_oldpm));
1260         switch (cx->blk_gimme) {
1261             case G_VOID:
1262                 gimme_text = "VOID";
1263                 break;
1264             case G_SCALAR:
1265                 gimme_text = "SCALAR";
1266                 break;
1267             case G_ARRAY:
1268                 gimme_text = "LIST";
1269                 break;
1270             default:
1271                 gimme_text = "UNKNOWN";
1272                 break;
1273         }
1274         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1275     }
1276     switch (CxTYPE(cx)) {
1277     case CXt_NULL:
1278     case CXt_BLOCK:
1279         break;
1280     case CXt_FORMAT:
1281         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1282                 PTR2UV(cx->blk_format.cv));
1283         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1284                 PTR2UV(cx->blk_format.gv));
1285         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1286                 PTR2UV(cx->blk_format.dfoutgv));
1287         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1288                       (int)CxHASARGS(cx));
1289         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1290                 PTR2UV(cx->blk_format.retop));
1291         break;
1292     case CXt_SUB:
1293         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1294                 PTR2UV(cx->blk_sub.cv));
1295         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1296                 (long)cx->blk_sub.olddepth);
1297         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1298                 (int)CxHASARGS(cx));
1299         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1300         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1301                 PTR2UV(cx->blk_sub.retop));
1302         break;
1303     case CXt_EVAL:
1304         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1305                 (long)CxOLD_IN_EVAL(cx));
1306         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1307                 PL_op_name[CxOLD_OP_TYPE(cx)],
1308                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1309         if (cx->blk_eval.old_namesv)
1310             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1311                           SvPVX_const(cx->blk_eval.old_namesv));
1312         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1313                 PTR2UV(cx->blk_eval.old_eval_root));
1314         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1315                 PTR2UV(cx->blk_eval.retop));
1316         break;
1317
1318     case CXt_LOOP_LAZYIV:
1319     case CXt_LOOP_LAZYSV:
1320     case CXt_LOOP_FOR:
1321     case CXt_LOOP_PLAIN:
1322         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1323         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1324                 (long)cx->blk_loop.resetsp);
1325         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1326                 PTR2UV(cx->blk_loop.my_op));
1327         /* XXX: not accurate for LAZYSV/IV */
1328         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1329                 PTR2UV(cx->blk_loop.state_u.ary.ary));
1330         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1331                 (long)cx->blk_loop.state_u.ary.ix);
1332         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1333                 PTR2UV(CxITERVAR(cx)));
1334         break;
1335
1336     case CXt_SUBST:
1337         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1338                 (long)cx->sb_iters);
1339         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1340                 (long)cx->sb_maxiters);
1341         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1342                 (long)cx->sb_rflags);
1343         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1344                 (long)CxONCE(cx));
1345         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1346                 cx->sb_orig);
1347         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1348                 PTR2UV(cx->sb_dstr));
1349         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1350                 PTR2UV(cx->sb_targ));
1351         PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1352                 PTR2UV(cx->sb_s));
1353         PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1354                 PTR2UV(cx->sb_m));
1355         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1356                 PTR2UV(cx->sb_strend));
1357         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1358                 PTR2UV(cx->sb_rxres));
1359         break;
1360     }
1361 #else
1362     PERL_UNUSED_CONTEXT;
1363     PERL_UNUSED_ARG(cx);
1364 #endif  /* DEBUGGING */
1365 }
1366
1367 /*
1368  * Local variables:
1369  * c-indentation-style: bsd
1370  * c-basic-offset: 4
1371  * indent-tabs-mode: nil
1372  * End:
1373  *
1374  * ex: set ts=8 sts=4 sw=4 et:
1375  */