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