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