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 #include "feature.h"
  29
  30 SV**
  31 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
  32 {
  33     SSize_t extra;
  34     SSize_t current = (p - PL_stack_base);
  35
  36     PERL_ARGS_ASSERT_STACK_GROW;
  37
  38     if (UNLIKELY(n < 0))
  39         Perl_croak(aTHX_
  40             "panic: stack_grow() negative count (%" IVdf ")", (IV)n);
  41
  42     PL_stack_sp = sp;
  43     extra =
  44 #ifdef STRESS_REALLOC
  45         1;
  46 #else
  47         128;
  48 #endif
  49     /* If the total might wrap, panic instead. This is really testing
  50      * that (current + n + extra < SSize_t_MAX), but done in a way that
  51      * can't wrap */
  52     if (UNLIKELY(   current         > SSize_t_MAX - extra
  53                  || current + extra > SSize_t_MAX - n
  54     ))
  55         /* diag_listed_as: Out of memory during %s extend */
  56         Perl_croak(aTHX_ "Out of memory during stack extend");
  57
  58     av_extend(PL_curstack, current + n + extra);
  59 #ifdef DEBUGGING
  60         PL_curstackinfo->si_stack_hwm = current + n + extra;
  61 #endif
  62
  63     return PL_stack_sp;
  64 }
  65
  66 #ifdef STRESS_REALLOC
  67 #define GROW(old) ((old) + 1)
  68 #else
  69 #define GROW(old) ((old) * 3 / 2)
  70 #endif
  71
  72 PERL_SI *
  73 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
  74 {
  75     PERL_SI *si;
  76     Newx(si, 1, PERL_SI);
  77     si->si_stack = newAV();
  78     AvREAL_off(si->si_stack);
  79     av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
  80     AvALLOC(si->si_stack)[0] = &PL_sv_undef;
  81     AvFILLp(si->si_stack) = 0;
  82     si->si_prev = 0;
  83     si->si_next = 0;
  84     si->si_cxmax = cxitems - 1;
  85     si->si_cxix = -1;
  86     si->si_cxsubix = -1;
  87     si->si_type = PERLSI_UNDEF;
  88     Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
  89     /* Without any kind of initialising CX_PUSHSUBST()
  90      * in pp_subst() will read uninitialised heap. */
  91     PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
  92     return si;
  93 }
  94
  95 I32
  96 Perl_cxinc(pTHX)
  97 {
  98     const IV old_max = cxstack_max;
  99     const IV new_max = GROW(cxstack_max);
 100     Renew(cxstack, new_max + 1, PERL_CONTEXT);
 101     cxstack_max = new_max;
 102     /* Without any kind of initialising deep enough recursion
 103      * will end up reading uninitialised PERL_CONTEXTs. */
 104     PoisonNew(cxstack + old_max + 1, new_max - old_max, PERL_CONTEXT);
 105     return cxstack_ix + 1;
 106 }
 107
 108 /*
 109 =for apidoc_section $callback
 110 =for apidoc push_scope
 111
 112 Implements L<perlapi/C<ENTER>>
 113
 114 =cut
 115 */
 116
 117 void
 118 Perl_push_scope(pTHX)
 119 {
 120     if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) {
 121         const IV new_max = GROW(PL_scopestack_max);
 122         Renew(PL_scopestack, new_max, I32);
 123 #ifdef DEBUGGING
 124         Renew(PL_scopestack_name, new_max, const char*);
 125 #endif
 126         PL_scopestack_max = new_max;
 127     }
 128 #ifdef DEBUGGING
 129     PL_scopestack_name[PL_scopestack_ix] = "unknown";
 130 #endif
 131     PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
 132
 133 }
 134
 135 /*
 136 =for apidoc_section $callback
 137 =for apidoc pop_scope
 138
 139 Implements L<perlapi/C<LEAVE>>
 140
 141 =cut
 142 */
 143
 144 void
 145 Perl_pop_scope(pTHX)
 146 {
 147     const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
 148     LEAVE_SCOPE(oldsave);
 149 }
 150
 151 I32 *
 152 Perl_markstack_grow(pTHX)
 153 {
 154     const I32 oldmax = PL_markstack_max - PL_markstack;
 155     const I32 newmax = GROW(oldmax);
 156
 157     Renew(PL_markstack, newmax, I32);
 158     PL_markstack_max = PL_markstack + newmax;
 159     PL_markstack_ptr = PL_markstack + oldmax;
 160     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 161             "MARK grow %p %" IVdf " by %" IVdf "\n",
 162             PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax)));
 163     return PL_markstack_ptr;
 164 }
 165
 166 void
 167 Perl_savestack_grow(pTHX)
 168 {
 169     const I32 by = PL_savestack_max - PL_savestack_ix;
 170     Perl_savestack_grow_cnt(aTHX_ by);
 171 }
 172
 173 void
 174 Perl_savestack_grow_cnt(pTHX_ I32 need)
 175 {
 176     /* NOTE: PL_savestack_max and PL_savestack_ix are I32.
 177      *
 178      * This makes sense when you consider that having I32_MAX items on
 179      * the stack would be quite large.
 180      *
 181      * However, we use IV here so that we can detect if the new requested
 182      * amount is larger than I32_MAX.
 183      */
 184     const IV new_floor = PL_savestack_max + need; /* what we need */
 185     /* the GROW() macro normally does scales by 1.5 but under
 186      * STRESS_REALLOC it simply adds 1 */
 187     IV new_max         = GROW(new_floor); /* and some extra */
 188
 189     /* the new_max < PL_savestack_max is for cases where IV is I32
 190      * and we have rolled over from I32_MAX to a small value */
 191     if (new_max > I32_MAX || new_max < PL_savestack_max) {
 192         if (new_floor > I32_MAX || new_floor < PL_savestack_max) {
 193             Perl_croak(aTHX_ "panic: savestack overflows I32_MAX");
 194         }
 195         new_max = new_floor;
 196     }
 197
 198     /* Note that we add an additional SS_MAXPUSH slots on top of
 199      * PL_savestack_max so that SS_ADD_END(), SSGROW() etc can do
 200      * a simper check and if necessary realloc *after* apparently
 201      * overwriting the current PL_savestack_max. See scope.h.
 202      *
 203      * The +1 is because new_max/PL_savestack_max is the highest
 204      * index, by Renew needs the number of items, which is one
 205      * larger than the highest index. */
 206     Renew(PL_savestack, new_max + SS_MAXPUSH + 1, ANY);
 207     PL_savestack_max = new_max;
 208 }
 209
 210 #undef GROW
 211
 212 /*  The original function was called Perl_tmps_grow and was removed from public
 213     API, Perl_tmps_grow_p is the replacement and it used in public macros but
 214     isn't public itself.
 215
 216     Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by,
 217     where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max
 218     Upon return, PL_tmps_stack[ix] will be a valid address. For machine code
 219     optimization and register usage reasons, the proposed ix passed into
 220     tmps_grow is returned to the caller which the caller can then use to write
 221     an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in
 222     pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of
 223     tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller
 224     must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is
 225     appropriate. The assignment to PL_temps_ix can happen before or after
 226     tmps_grow call since tmps_grow doesn't look at PL_tmps_ix.
 227  */
 228
 229 SSize_t
 230 Perl_tmps_grow_p(pTHX_ SSize_t ix)
 231 {
 232     SSize_t extend_to = ix;
 233 #ifndef STRESS_REALLOC
 234     if (ix - PL_tmps_max < 128)
 235         extend_to += (PL_tmps_max < 512) ? 128 : 512;
 236 #endif
 237     Renew(PL_tmps_stack, extend_to + 1, SV*);
 238     PL_tmps_max = extend_to + 1;
 239     return ix;
 240 }
 241
 242
 243 void
 244 Perl_free_tmps(pTHX)
 245 {
 246     /* XXX should tmps_floor live in cxstack? */
 247     const SSize_t myfloor = PL_tmps_floor;
 248     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
 249         SV* const sv = PL_tmps_stack[PL_tmps_ix--];
 250 #ifdef PERL_POISON
 251         PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
 252 #endif
 253         if (LIKELY(sv)) {
 254             SvTEMP_off(sv);
 255             SvREFCNT_dec_NN(sv);                /* note, can modify tmps_ix!!! */
 256         }
 257     }
 258 }
 259
 260 /*
 261 =for apidoc save_scalar_at
 262
 263 A helper function for localizing the SV referenced by C<*sptr>.
 264
 265 If C<SAVEf_KEEPOLDELEM> is set in in C<flags>, the function returns the input
 266 scalar untouched.
 267
 268 Otherwise it replaces C<*sptr> with a new C<undef> scalar, and returns that.
 269 The new scalar will have the old one's magic (if any) copied to it.
 270 If there is such magic, and C<SAVEf_SETMAGIC> is set in in C<flags>, 'set'
 271 magic will be processed on the new scalar.  If unset, 'set' magic will be
 272 skipped.  The latter typically means that assignment will soon follow (I<e.g.>,
 273 S<C<'local $x = $y'>>), and that will handle the magic.
 274
 275 =for apidoc Amnh ||SAVEf_KEEPOLDELEM
 276 =for apidoc Amnh ||SAVEf_SETMAGIC
 277
 278 =cut
 279 */
 280
 281 STATIC SV *
 282 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
 283 {
 284     SV * osv;
 285     SV *sv;
 286
 287     PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
 288
 289     osv = *sptr;
 290     if (flags & SAVEf_KEEPOLDELEM)
 291         sv = osv;
 292     else {
 293         sv  = (*sptr = newSV_type(SVt_NULL));
 294         if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv))
 295             mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
 296     }
 297
 298     return sv;
 299 }
 300
 301 void
 302 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
 303 {
 304     dSS_ADD;
 305     SS_ADD_PTR(ptr1);
 306     SS_ADD_PTR(ptr2);
 307     SS_ADD_UV(type);
 308     SS_ADD_END(3);
 309 }
 310
 311 SV *
 312 Perl_save_scalar(pTHX_ GV *gv)
 313 {
 314     SV ** const sptr = &GvSVn(gv);
 315
 316     PERL_ARGS_ASSERT_SAVE_SCALAR;
 317
 318     if (UNLIKELY(SvGMAGICAL(*sptr))) {
 319         PL_localizing = 1;
 320         (void)mg_get(*sptr);
 321         PL_localizing = 0;
 322     }
 323     save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
 324     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
 325 }
 326
 327 /*
 328 =for apidoc save_generic_svref
 329
 330 Implements C<SAVEGENERICSV>.
 331
 332 Like save_sptr(), but also SvREFCNT_dec()s the new value.  Can be used to
 333 restore a global SV to its prior contents, freeing new value.
 334
 335 =cut
 336  */
 337
 338 void
 339 Perl_save_generic_svref(pTHX_ SV **sptr)
 340 {
 341     PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
 342
 343     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
 344 }
 345
 346
 347 /*
 348 =for apidoc save_rcpv
 349
 350 Implements C<SAVERCPV>.
 351
 352 Saves and restores a refcounted string, similar to what
 353 save_generic_svref would do for a SV*. Can be used to restore
 354 a refcounted string to its previous state. Performs the
 355 appropriate refcount counting so that nothing should leak
 356 or be prematurely freed.
 357
 358 =cut
 359  */
 360 void
 361 Perl_save_rcpv(pTHX_ char **prcpv) {
 362     PERL_ARGS_ASSERT_SAVE_RCPV;
 363     save_pushptrptr(prcpv, rcpv_copy(*prcpv), SAVEt_RCPV);
 364 }
 365
 366 /*
 367 =for apidoc save_freercpv
 368
 369 Implements C<SAVEFREERCPV>.
 370
 371 Saves and frees a refcounted string. Calls rcpv_free()
 372 on the argument when the current pseudo block is finished.
 373
 374 =cut
 375  */
 376 void
 377 Perl_save_freercpv(pTHX_ char *rcpv) {
 378     PERL_ARGS_ASSERT_SAVE_FREERCPV;
 379     save_pushptr(rcpv, SAVEt_FREERCPV);
 380 }
 381
 382
 383 /*
 384 =for apidoc_section $callback
 385 =for apidoc save_generic_pvref
 386
 387 Implements C<SAVEGENERICPV>.
 388
 389 Like save_pptr(), but also Safefree()s the new value if it is different
 390 from the old one.  Can be used to restore a global char* to its prior
 391 contents, freeing new value.
 392
 393 =cut
 394  */
 395
 396 void
 397 Perl_save_generic_pvref(pTHX_ char **str)
 398 {
 399     PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
 400
 401     save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
 402 }
 403
 404 /*
 405 =for apidoc_section $callback
 406 =for apidoc save_shared_pvref
 407
 408 Implements C<SAVESHAREDPV>.
 409
 410 Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
 411 Can be used to restore a shared global char* to its prior
 412 contents, freeing new value.
 413
 414 =cut
 415  */
 416
 417 void
 418 Perl_save_shared_pvref(pTHX_ char **str)
 419 {
 420     PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
 421
 422     save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
 423 }
 424
 425
 426 /*
 427 =for apidoc_section $callback
 428 =for apidoc save_set_svflags
 429
 430 Implements C<SAVESETSVFLAGS>.
 431
 432 Set the SvFLAGS specified by mask to the values in val
 433
 434 =cut
 435  */
 436
 437 void
 438 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
 439 {
 440     dSS_ADD;
 441
 442     PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
 443
 444     SS_ADD_PTR(sv);
 445     SS_ADD_INT(mask);
 446     SS_ADD_INT(val);
 447     SS_ADD_UV(SAVEt_SET_SVFLAGS);
 448     SS_ADD_END(4);
 449 }
 450
 451 /*
 452
 453 =for apidoc_section $GV
 454
 455 =for apidoc save_gp
 456
 457 Saves the current GP of gv on the save stack to be restored on scope exit.
 458
 459 If C<empty> is true, replace the GP with a new GP.
 460
 461 If C<empty> is false, mark C<gv> with C<GVf_INTRO> so the next reference
 462 assigned is localized, which is how S<C< local *foo = $someref; >> works.
 463
 464 =cut
 465 */
 466
 467 void
 468 Perl_save_gp(pTHX_ GV *gv, I32 empty)
 469 {
 470     PERL_ARGS_ASSERT_SAVE_GP;
 471
 472     /* XXX For now, we just upgrade any coderef in the stash to a full GV
 473            during localisation.  Maybe at some point we could make localis-
 474            ation work without needing the upgrade.  (In which case our
 475            callers should probably call a different function, not save_gp.)
 476      */
 477     if (!isGV(gv)) {
 478         assert(isGV_or_RVCV(gv));
 479         (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */
 480         assert(isGV(gv));
 481     }
 482
 483     save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
 484
 485     if (empty) {
 486         GP *gp = Perl_newGP(aTHX_ gv);
 487         HV * const stash = GvSTASH(gv);
 488         bool isa_changed = 0;
 489
 490         if (stash && HvHasENAME(stash)) {
 491             if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
 492                 isa_changed = TRUE;
 493             else if (GvCVu(gv))
 494                 /* taking a method out of circulation ("local")*/
 495                 mro_method_changed_in(stash);
 496         }
 497         if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
 498             gp->gp_io = newIO();
 499             IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
 500         }
 501         GvGP_set(gv,gp);
 502         if (isa_changed) mro_isa_changed_in(stash);
 503     }
 504     else {
 505         gp_ref(GvGP(gv));
 506         GvINTRO_on(gv);
 507     }
 508 }
 509
 510 AV *
 511 Perl_save_ary(pTHX_ GV *gv)
 512 {
 513     AV * const oav = GvAVn(gv);
 514     AV *av;
 515
 516     PERL_ARGS_ASSERT_SAVE_ARY;
 517
 518     if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav)))
 519         av_reify(oav);
 520     save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
 521
 522     GvAV(gv) = NULL;
 523     av = GvAVn(gv);
 524     if (UNLIKELY(SvMAGIC(oav)))
 525         mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
 526     return av;
 527 }
 528
 529 HV *
 530 Perl_save_hash(pTHX_ GV *gv)
 531 {
 532     HV *ohv, *hv;
 533
 534     PERL_ARGS_ASSERT_SAVE_HASH;
 535
 536     save_pushptrptr(
 537         SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
 538     );
 539
 540     GvHV(gv) = NULL;
 541     hv = GvHVn(gv);
 542     if (UNLIKELY(SvMAGIC(ohv)))
 543         mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
 544     return hv;
 545 }
 546
 547 void
 548 Perl_save_item(pTHX_ SV *item)
 549 {
 550     SV * const sv = newSVsv(item);
 551
 552     PERL_ARGS_ASSERT_SAVE_ITEM;
 553
 554     save_pushptrptr(item, /* remember the pointer */
 555                     sv,   /* remember the value */
 556                     SAVEt_ITEM);
 557 }
 558
 559 void
 560 Perl_save_bool(pTHX_ bool *boolp)
 561 {
 562     dSS_ADD;
 563
 564     PERL_ARGS_ASSERT_SAVE_BOOL;
 565
 566     SS_ADD_PTR(boolp);
 567     SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
 568     SS_ADD_END(2);
 569 }
 570
 571 void
 572 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
 573 {
 574     dSS_ADD;
 575
 576     SS_ADD_INT(i);
 577     SS_ADD_PTR(ptr);
 578     SS_ADD_UV(type);
 579     SS_ADD_END(3);
 580 }
 581
 582 void
 583 Perl_save_int(pTHX_ int *intp)
 584 {
 585     const int i = *intp;
 586     UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
 587     int size = 2;
 588     dSS_ADD;
 589
 590     PERL_ARGS_ASSERT_SAVE_INT;
 591
 592     if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) {
 593         SS_ADD_INT(i);
 594         type = SAVEt_INT;
 595         size++;
 596     }
 597     SS_ADD_PTR(intp);
 598     SS_ADD_UV(type);
 599     SS_ADD_END(size);
 600 }
 601
 602 void
 603 Perl_save_I8(pTHX_ I8 *bytep)
 604 {
 605     dSS_ADD;
 606
 607     PERL_ARGS_ASSERT_SAVE_I8;
 608
 609     SS_ADD_PTR(bytep);
 610     SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
 611     SS_ADD_END(2);
 612 }
 613
 614 void
 615 Perl_save_I16(pTHX_ I16 *intp)
 616 {
 617     dSS_ADD;
 618
 619     PERL_ARGS_ASSERT_SAVE_I16;
 620
 621     SS_ADD_PTR(intp);
 622     SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
 623     SS_ADD_END(2);
 624 }
 625
 626 void
 627 Perl_save_I32(pTHX_ I32 *intp)
 628 {
 629     const I32 i = *intp;
 630     UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
 631     int size = 2;
 632     dSS_ADD;
 633
 634     PERL_ARGS_ASSERT_SAVE_I32;
 635
 636     if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
 637         SS_ADD_INT(i);
 638         type = SAVEt_I32;
 639         size++;
 640     }
 641     SS_ADD_PTR(intp);
 642     SS_ADD_UV(type);
 643     SS_ADD_END(size);
 644 }
 645
 646 void
 647 Perl_save_strlen(pTHX_ STRLEN *ptr)
 648 {
 649     const IV i = *ptr;
 650     UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_STRLEN_SMALL);
 651     int size = 2;
 652     dSS_ADD;
 653
 654     PERL_ARGS_ASSERT_SAVE_STRLEN;
 655
 656     if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
 657         SS_ADD_IV(*ptr);
 658         type = SAVEt_STRLEN;
 659         size++;
 660     }
 661
 662     SS_ADD_PTR(ptr);
 663     SS_ADD_UV(type);
 664     SS_ADD_END(size);
 665 }
 666
 667 void
 668 Perl_save_iv(pTHX_ IV *ivp)
 669 {
 670     PERL_ARGS_ASSERT_SAVE_IV;
 671
 672     SSGROW(3);
 673     SSPUSHIV(*ivp);
 674     SSPUSHPTR(ivp);
 675     SSPUSHUV(SAVEt_IV);
 676 }
 677
 678 /* Cannot use save_sptr() to store a char* since the SV** cast will
 679  * force word-alignment and we'll miss the pointer.
 680  */
 681 void
 682 Perl_save_pptr(pTHX_ char **pptr)
 683 {
 684     PERL_ARGS_ASSERT_SAVE_PPTR;
 685
 686     save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
 687 }
 688
 689 /*
 690 =for apidoc_section $callback
 691 =for apidoc save_vptr
 692
 693 Implements C<SAVEVPTR>.
 694
 695 =cut
 696  */
 697
 698 void
 699 Perl_save_vptr(pTHX_ void *ptr)
 700 {
 701     PERL_ARGS_ASSERT_SAVE_VPTR;
 702
 703     save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
 704 }
 705
 706 void
 707 Perl_save_sptr(pTHX_ SV **sptr)
 708 {
 709     PERL_ARGS_ASSERT_SAVE_SPTR;
 710
 711     save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
 712 }
 713
 714 /*
 715 =for apidoc_section $callback
 716 =for apidoc save_padsv_and_mortalize
 717
 718 Implements C<SAVEPADSVANDMORTALIZE>.
 719
 720 =cut
 721  */
 722
 723 void
 724 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
 725 {
 726     dSS_ADD;
 727
 728     ASSERT_CURPAD_ACTIVE("save_padsv");
 729     SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
 730     SS_ADD_PTR(PL_comppad);
 731     SS_ADD_UV((UV)off);
 732     SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
 733     SS_ADD_END(4);
 734 }
 735
 736 void
 737 Perl_save_hptr(pTHX_ HV **hptr)
 738 {
 739     PERL_ARGS_ASSERT_SAVE_HPTR;
 740
 741     save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
 742 }
 743
 744 void
 745 Perl_save_aptr(pTHX_ AV **aptr)
 746 {
 747     PERL_ARGS_ASSERT_SAVE_APTR;
 748
 749     save_pushptrptr(*aptr, aptr, SAVEt_APTR);
 750 }
 751
 752 /*
 753 =for apidoc_section $callback
 754 =for apidoc save_pushptr
 755
 756 The refcnt of object C<ptr> will be decremented at the end of the current
 757 I<pseudo-block>.  C<type> gives the type of C<ptr>, expressed as one of the
 758 constants in F<scope.h> whose name begins with C<SAVEt_>.
 759
 760 This is the underlying implementation of several macros, like
 761 C<SAVEFREESV>.
 762
 763 =cut
 764 */
 765
 766 void
 767 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
 768 {
 769     dSS_ADD;
 770     SS_ADD_PTR(ptr);
 771     SS_ADD_UV(type);
 772     SS_ADD_END(2);
 773 }
 774
 775 void
 776 Perl_save_clearsv(pTHX_ SV **svp)
 777 {
 778     const UV offset = svp - PL_curpad;
 779     const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
 780
 781     PERL_ARGS_ASSERT_SAVE_CLEARSV;
 782
 783     ASSERT_CURPAD_ACTIVE("save_clearsv");
 784     assert(*svp);
 785     SvPADSTALE_off(*svp); /* mark lexical as active */
 786     if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) {
 787         Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)",
 788                    offset, svp, PL_curpad);
 789     }
 790
 791     {
 792         dSS_ADD;
 793         SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
 794         SS_ADD_END(1);
 795     }
 796 }
 797
 798 void
 799 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 800 {
 801     PERL_ARGS_ASSERT_SAVE_DELETE;
 802
 803     save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
 804 }
 805
 806 /*
 807 =for apidoc_section $callback
 808 =for apidoc save_hdelete
 809
 810 Implements C<SAVEHDELETE>.
 811
 812 =cut
 813 */
 814
 815 void
 816 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
 817 {
 818     STRLEN len;
 819     I32 klen;
 820     const char *key;
 821
 822     PERL_ARGS_ASSERT_SAVE_HDELETE;
 823
 824     key  = SvPV_const(keysv, len);
 825     klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
 826     SvREFCNT_inc_simple_void_NN(hv);
 827     save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
 828 }
 829
 830 /*
 831 =for apidoc_section $callback
 832 =for apidoc save_adelete
 833
 834 Implements C<SAVEADELETE>.
 835
 836 =cut
 837 */
 838
 839 void
 840 Perl_save_adelete(pTHX_ AV *av, SSize_t key)
 841 {
 842     dSS_ADD;
 843
 844     PERL_ARGS_ASSERT_SAVE_ADELETE;
 845
 846     SvREFCNT_inc_void(av);
 847     SS_ADD_UV(key);
 848     SS_ADD_PTR(av);
 849     SS_ADD_IV(SAVEt_ADELETE);
 850     SS_ADD_END(3);
 851 }
 852
 853 void
 854 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 855 {
 856     dSS_ADD;
 857     PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
 858
 859     SS_ADD_DPTR(f);
 860     SS_ADD_PTR(p);
 861     SS_ADD_UV(SAVEt_DESTRUCTOR);
 862     SS_ADD_END(3);
 863 }
 864
 865 void
 866 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 867 {
 868     dSS_ADD;
 869
 870     SS_ADD_DXPTR(f);
 871     SS_ADD_PTR(p);
 872     SS_ADD_UV(SAVEt_DESTRUCTOR_X);
 873     SS_ADD_END(3);
 874 }
 875
 876 /*
 877 =for apidoc_section $callback
 878 =for apidoc save_hints
 879
 880 Implements C<SAVEHINTS>.
 881
 882 =cut
 883  */
 884
 885 void
 886 Perl_save_hints(pTHX)
 887 {
 888     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
 889     if (PL_hints & HINT_LOCALIZE_HH) {
 890         HV *oldhh = GvHV(PL_hintgv);
 891         {
 892             dSS_ADD;
 893             SS_ADD_INT(PL_hints);
 894             SS_ADD_PTR(save_cophh);
 895             SS_ADD_PTR(oldhh);
 896             SS_ADD_UV(SAVEt_HINTS_HH | (PL_prevailing_version << 8));
 897             SS_ADD_END(4);
 898         }
 899         GvHV(PL_hintgv) = NULL; /* in case copying dies */
 900         GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
 901         SAVEFEATUREBITS();
 902     } else {
 903         save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS | (PL_prevailing_version << 8));
 904     }
 905 }
 906
 907 static void
 908 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
 909                         const int type)
 910 {
 911     dSS_ADD;
 912     SS_ADD_PTR(ptr1);
 913     SS_ADD_INT(i);
 914     SS_ADD_PTR(ptr2);
 915     SS_ADD_UV(type);
 916     SS_ADD_END(4);
 917 }
 918
 919 /*
 920 =for apidoc_section $callback
 921 =for apidoc      save_aelem
 922 =for apidoc_item save_aelem_flags
 923
 924 These each arrange for the value of the array element C<av[idx]> to be restored
 925 at the end of the enclosing I<pseudo-block>.
 926
 927 In C<save_aelem>, the SV at C**sptr> will be replaced by a new C<undef>
 928 scalar.  That scalar will inherit any magic from the original C<**sptr>,
 929 and any 'set' magic will be processed.
 930
 931 In C<save_aelem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
 932 the function to forgo all that:  the scalar at C<**sptr> is untouched.
 933 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
 934 new C<undef> scalar.  That scalar will inherit any magic from the original
 935 C<**sptr>.  Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
 936 is set in in C<flags>.
 937
 938 =cut
 939 */
 940
 941 void
 942 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr,
 943                             const U32 flags)
 944 {
 945     dSS_ADD;
 946     SV *sv;
 947
 948     PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
 949
 950     SvGETMAGIC(*sptr);
 951     SS_ADD_PTR(SvREFCNT_inc_simple(av));
 952     SS_ADD_IV(idx);
 953     SS_ADD_PTR(SvREFCNT_inc(*sptr));
 954     SS_ADD_UV(SAVEt_AELEM);
 955     SS_ADD_END(4);
 956     /* The array needs to hold a reference count on its new element, so it
 957        must be AvREAL. */
 958     if (UNLIKELY(!AvREAL(av) && AvREIFY(av)))
 959         av_reify(av);
 960     save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
 961     if (flags & SAVEf_KEEPOLDELEM)
 962         return;
 963     sv = *sptr;
 964     /* If we're localizing a tied array element, this new sv
 965      * won't actually be stored in the array - so it won't get
 966      * reaped when the localize ends. Ensure it gets reaped by
 967      * mortifying it instead. DAPM */
 968     if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied)))
 969         sv_2mortal(sv);
 970 }
 971
 972 /*
 973 =for apidoc_section $callback
 974 =for apidoc      save_helem
 975 =for apidoc_item save_helem_flags
 976
 977 These each arrange for the value of the hash element (in Perlish terms)
 978 C<$hv{key}]> to be restored at the end of the enclosing I<pseudo-block>.
 979
 980 In C<save_helem>, the SV at C**sptr> will be replaced by a new C<undef>
 981 scalar.  That scalar will inherit any magic from the original C<**sptr>,
 982 and any 'set' magic will be processed.
 983
 984 In C<save_helem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
 985 the function to forgo all that:  the scalar at C<**sptr> is untouched.
 986 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
 987 new C<undef> scalar.  That scalar will inherit any magic from the original
 988 C<**sptr>.  Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
 989 is set in in C<flags>.
 990
 991 =cut
 992 */
 993
 994 void
 995 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
 996 {
 997     SV *sv;
 998
 999     PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
1000
1001     SvGETMAGIC(*sptr);
1002     {
1003         dSS_ADD;
1004         SS_ADD_PTR(SvREFCNT_inc_simple(hv));
1005         SS_ADD_PTR(newSVsv(key));
1006         SS_ADD_PTR(SvREFCNT_inc(*sptr));
1007         SS_ADD_UV(SAVEt_HELEM);
1008         SS_ADD_END(4);
1009     }
1010     save_scalar_at(sptr, flags);
1011     if (flags & SAVEf_KEEPOLDELEM)
1012         return;
1013     sv = *sptr;
1014     /* If we're localizing a tied hash element, this new sv
1015      * won't actually be stored in the hash - so it won't get
1016      * reaped when the localize ends. Ensure it gets reaped by
1017      * mortifying it instead. DAPM */
1018     if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)))
1019         sv_2mortal(sv);
1020 }
1021
1022 SV*
1023 Perl_save_svref(pTHX_ SV **sptr)
1024 {
1025     PERL_ARGS_ASSERT_SAVE_SVREF;
1026
1027     SvGETMAGIC(*sptr);
1028     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
1029     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
1030 }
1031
1032
1033 void
1034 Perl_savetmps(pTHX)
1035 {
1036     dSS_ADD;
1037     SS_ADD_IV(PL_tmps_floor);
1038     PL_tmps_floor = PL_tmps_ix;
1039     SS_ADD_UV(SAVEt_TMPSFLOOR);
1040     SS_ADD_END(2);
1041 }
1042
1043 /*
1044 =for apidoc_section $stack
1045 =for apidoc save_alloc
1046
1047 Implements L<perlapi/C<SSNEW>> and kin, which should be used instead of this
1048 function.
1049
1050 =cut
1051 */
1052
1053 SSize_t
1054 Perl_save_alloc(pTHX_ SSize_t size, I32 pad)
1055 {
1056     const SSize_t start = pad + ((char*)&PL_savestack[PL_savestack_ix]
1057                           - (char*)PL_savestack);
1058     const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
1059     const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
1060
1061     if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems))
1062         Perl_croak(aTHX_
1063             "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")",
1064                    elems, (IV)size, (IV)pad);
1065
1066     SSGROW(elems + 1);
1067
1068     PL_savestack_ix += elems;
1069     SSPUSHUV(SAVEt_ALLOC | elems_shifted);
1070     return start;
1071 }
1072
1073
1074
1075 /*
1076 =for apidoc_section $callback
1077 =for apidoc leave_scope
1078
1079 Implements C<LEAVE_SCOPE> which you should use instead.
1080
1081 =cut
1082  */
1083
1084 void
1085 Perl_leave_scope(pTHX_ I32 base)
1086 {
1087     /* Localise the effects of the TAINT_NOT inside the loop.  */
1088     bool was = TAINT_get;
1089
1090     if (UNLIKELY(base < -1))
1091         Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
1092     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
1093                         (long)PL_savestack_ix, (long)base));
1094     while (PL_savestack_ix > base) {
1095         UV uv;
1096         U8 type;
1097         ANY *ap; /* arg pointer */
1098         ANY a0, a1, a2; /* up to 3 args */
1099
1100         TAINT_NOT;
1101
1102         {
1103             U8  argcount;
1104             I32 ix = PL_savestack_ix - 1;
1105
1106             ap = &PL_savestack[ix];
1107             uv = ap->any_uv;
1108             type = (U8)uv & SAVE_MASK;
1109             argcount = leave_scope_arg_counts[type];
1110             PL_savestack_ix = ix - argcount;
1111             ap -= argcount;
1112         }
1113
1114         switch (type) {
1115         case SAVEt_ITEM:                        /* normal string */
1116             a0 = ap[0]; a1 = ap[1];
1117             sv_replace(a0.any_sv, a1.any_sv);
1118             if (UNLIKELY(SvSMAGICAL(a0.any_sv))) {
1119                 PL_localizing = 2;
1120                 mg_set(a0.any_sv);
1121                 PL_localizing = 0;
1122             }
1123             break;
1124
1125             /* This would be a mathom, but Perl_save_svref() calls a static
1126                function, S_save_scalar_at(), so has to stay in this file.  */
1127         case SAVEt_SVREF:                       /* scalar reference */
1128             a0 = ap[0]; a1 = ap[1];
1129             a2.any_svp = a0.any_svp;
1130             a0.any_sv = NULL; /* what to refcnt_dec */
1131             goto restore_sv;
1132
1133         case SAVEt_SV:                          /* scalar reference */
1134             a0 = ap[0]; a1 = ap[1];
1135             a2.any_svp = &GvSV(a0.any_gv);
1136         restore_sv:
1137         {
1138             /* do *a2.any_svp = a1 and free a0 */
1139             SV * const sv = *a2.any_svp;
1140             *a2.any_svp = a1.any_sv;
1141             SvREFCNT_dec(sv);
1142             if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1143                 /* mg_set could die, skipping the freeing of a0 and
1144                  * a1; Ensure that they're always freed in that case */
1145                 dSS_ADD;
1146                 SS_ADD_PTR(a1.any_sv);
1147                 SS_ADD_UV(SAVEt_FREESV);
1148                 SS_ADD_PTR(a0.any_sv);
1149                 SS_ADD_UV(SAVEt_FREESV);
1150                 SS_ADD_END(4);
1151                 PL_localizing = 2;
1152                 mg_set(a1.any_sv);
1153                 PL_localizing = 0;
1154                 break;
1155             }
1156             SvREFCNT_dec_NN(a1.any_sv);
1157             SvREFCNT_dec(a0.any_sv);
1158             break;
1159         }
1160
1161         case SAVEt_GENERIC_PVREF:               /* generic pv */
1162             a0 = ap[0]; a1 = ap[1];
1163             if (*a1.any_pvp != a0.any_pv) {
1164                 Safefree(*a1.any_pvp);
1165                 *a1.any_pvp = a0.any_pv;
1166             }
1167             break;
1168
1169         case SAVEt_SHARED_PVREF:                /* shared pv */
1170             a0 = ap[0]; a1 = ap[1];
1171             if (*a0.any_pvp != a1.any_pv) {
1172                 PerlMemShared_free(*a0.any_pvp);
1173                 *a0.any_pvp = a1.any_pv;
1174             }
1175             break;
1176
1177         case SAVEt_GVSV:                        /* scalar slot in GV */
1178             a0 = ap[0]; a1 = ap[1];
1179             a0.any_svp = &GvSV(a0.any_gv);
1180             goto restore_svp;
1181
1182
1183         case SAVEt_GENERIC_SVREF:               /* generic sv */
1184             a0 = ap[0]; a1 = ap[1];
1185         restore_svp:
1186         {
1187             /* do *a0.any_svp = a1 */
1188             SV * const sv = *a0.any_svp;
1189             *a0.any_svp = a1.any_sv;
1190             SvREFCNT_dec(sv);
1191             SvREFCNT_dec(a1.any_sv);
1192             break;
1193         }
1194
1195         case SAVEt_RCPV:           /* like generic sv, but for struct rcpv */
1196         {
1197             a0 = ap[0]; a1 = ap[1];
1198             char *old = *a0.any_pvp;
1199             *a0.any_pvp = a1.any_pv;
1200             (void)rcpv_free(old);
1201             (void)rcpv_free(a1.any_pv);
1202             break;
1203         }
1204
1205         case SAVEt_FREERCPV:           /* like SAVEt_FREEPV but for a RCPV */
1206         {
1207             a0 = ap[0];
1208             char *rcpv = a0.any_pv;
1209             (void)rcpv_free(rcpv);
1210             break;
1211         }
1212
1213         case SAVEt_GVSLOT:                      /* any slot in GV */
1214         {
1215             HV * hv;
1216             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1217             hv = GvSTASH(a0.any_gv);
1218             if (hv && HvHasENAME(hv) && (
1219                     (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV)
1220                  || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV)
1221                ))
1222             {
1223                 if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv)
1224                  || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp)
1225                  || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */
1226                     PL_sub_generation++;
1227                 else mro_method_changed_in(hv);
1228             }
1229             a0.any_svp = a1.any_svp;
1230             a1.any_sv  = a2.any_sv;
1231             goto restore_svp;
1232         }
1233
1234         case SAVEt_AV:                          /* array reference */
1235             a0 = ap[0]; a1 = ap[1];
1236             SvREFCNT_dec(GvAV(a0.any_gv));
1237             GvAV(a0.any_gv) = a1.any_av;
1238           avhv_common:
1239             if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1240                 /* mg_set might die, so make sure a0 isn't leaked */
1241                 dSS_ADD;
1242                 SS_ADD_PTR(a0.any_sv);
1243                 SS_ADD_UV(SAVEt_FREESV);
1244                 SS_ADD_END(2);
1245                 PL_localizing = 2;
1246                 mg_set(a1.any_sv);
1247                 PL_localizing = 0;
1248                 break;
1249             }
1250             SvREFCNT_dec_NN(a0.any_sv);
1251             break;
1252
1253         case SAVEt_HV:                          /* hash reference */
1254             a0 = ap[0]; a1 = ap[1];
1255             SvREFCNT_dec(GvHV(a0.any_gv));
1256             GvHV(a0.any_gv) = a1.any_hv;
1257             goto avhv_common;
1258
1259         case SAVEt_INT_SMALL:
1260             a0 = ap[0];
1261             *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
1262             break;
1263
1264         case SAVEt_INT:                         /* int reference */
1265             a0 = ap[0]; a1 = ap[1];
1266             *(int*)a1.any_ptr = (int)a0.any_i32;
1267             break;
1268
1269         case SAVEt_STRLEN_SMALL:
1270             a0 = ap[0];
1271             *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT);
1272             break;
1273
1274         case SAVEt_STRLEN:                      /* STRLEN/size_t ref */
1275             a0 = ap[0]; a1 = ap[1];
1276             *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv;
1277             break;
1278
1279         case SAVEt_TMPSFLOOR:                   /* restore PL_tmps_floor */
1280             a0 = ap[0];
1281             PL_tmps_floor = (SSize_t)a0.any_iv;
1282             break;
1283
1284         case SAVEt_BOOL:                        /* bool reference */
1285             a0 = ap[0];
1286             *(bool*)a0.any_ptr = cBOOL(uv >> 8);
1287 #ifdef NO_TAINT_SUPPORT
1288             PERL_UNUSED_VAR(was);
1289 #else
1290             if (UNLIKELY(a0.any_ptr == &(PL_tainted))) {
1291                 /* If we don't update <was>, to reflect what was saved on the
1292                  * stack for PL_tainted, then we will overwrite this attempt to
1293                  * restore it when we exit this routine.  Note that this won't
1294                  * work if this value was saved in a wider-than necessary type,
1295                  * such as I32 */
1296                 was = *(bool*)a0.any_ptr;
1297             }
1298 #endif
1299             break;
1300
1301         case SAVEt_I32_SMALL:
1302             a0 = ap[0];
1303             *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
1304             break;
1305
1306         case SAVEt_I32:                         /* I32 reference */
1307             a0 = ap[0]; a1 = ap[1];
1308 #ifdef PERL_DEBUG_READONLY_OPS
1309             if (*(I32*)a1.any_ptr != a0.any_i32)
1310 #endif
1311                 *(I32*)a1.any_ptr = a0.any_i32;
1312             break;
1313
1314         case SAVEt_SPTR:                        /* SV* reference */
1315         case SAVEt_VPTR:                        /* random* reference */
1316         case SAVEt_PPTR:                        /* char* reference */
1317         case SAVEt_HPTR:                        /* HV* reference */
1318         case SAVEt_APTR:                        /* AV* reference */
1319             a0 = ap[0]; a1 = ap[1];
1320             *a1.any_svp= a0.any_sv;
1321             break;
1322
1323         case SAVEt_GP:                          /* scalar reference */
1324         {
1325             HV *hv;
1326             bool had_method;
1327
1328             a0 = ap[0]; a1 = ap[1];
1329             /* possibly taking a method out of circulation */
1330             had_method = cBOOL(GvCVu(a0.any_gv));
1331             gp_free(a0.any_gv);
1332             GvGP_set(a0.any_gv, (GP*)a1.any_ptr);
1333             if ((hv=GvSTASH(a0.any_gv)) && HvHasENAME(hv)) {
1334                 if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA"))
1335                     mro_isa_changed_in(hv);
1336                 else if (had_method || GvCVu(a0.any_gv))
1337                     /* putting a method back into circulation ("local")*/
1338                     gv_method_changed(a0.any_gv);
1339             }
1340             SvREFCNT_dec_NN(a0.any_gv);
1341             break;
1342         }
1343
1344         case SAVEt_FREESV:
1345             a0 = ap[0];
1346             SvREFCNT_dec(a0.any_sv);
1347             break;
1348
1349         case SAVEt_FREEPADNAME:
1350             a0 = ap[0];
1351             PadnameREFCNT_dec((PADNAME *)a0.any_ptr);
1352             break;
1353
1354         case SAVEt_FREECOPHH:
1355             a0 = ap[0];
1356             cophh_free((COPHH *)a0.any_ptr);
1357             break;
1358
1359         case SAVEt_MORTALIZESV:
1360             a0 = ap[0];
1361             sv_2mortal(a0.any_sv);
1362             break;
1363
1364         case SAVEt_FREEOP:
1365             a0 = ap[0];
1366             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
1367             op_free(a0.any_op);
1368             break;
1369
1370         case SAVEt_FREEPV:
1371             a0 = ap[0];
1372             Safefree(a0.any_ptr);
1373             break;
1374
1375         case SAVEt_CLEARPADRANGE:
1376         {
1377             I32 i;
1378             SV **svp;
1379             i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1380             svp = &PL_curpad[uv >>
1381                     (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1382             goto clearsv;
1383         case SAVEt_CLEARSV:
1384             svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1385             i = 1;
1386           clearsv:
1387             for (; i; i--, svp--) {
1388                 SV *sv = *svp;
1389
1390                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1391              "Pad 0x%" UVxf "[0x%" UVxf "] clearsv: %ld sv=0x%" UVxf "<%" IVdf "> %s\n",
1392                     PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1393                     (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1394                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1395                 ));
1396
1397                 /* Can clear pad variable in place? */
1398                 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
1399
1400                     /* these flags are the union of all the relevant flags
1401                      * in the individual conditions within */
1402                     if (UNLIKELY(SvFLAGS(sv) & (
1403                             SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
1404                           | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
1405                           | SVf_OOK
1406                           | SVf_THINKFIRST)))
1407                     {
1408                         /* if a my variable that was made readonly is
1409                          * going out of scope, we want to remove the
1410                          * readonlyness so that it can go out of scope
1411                          * quietly
1412                          */
1413                         if (SvREADONLY(sv))
1414                             SvREADONLY_off(sv);
1415
1416                         if (SvTYPE(sv) == SVt_PVHV && HvHasAUX(sv))
1417                             Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1418                         else if(SvOOK(sv))
1419                             sv_backoff(sv);
1420
1421                         if (SvMAGICAL(sv)) {
1422                             /* note that backrefs (either in HvAUX or magic)
1423                              * must be removed before other magic */
1424                             sv_unmagic(sv, PERL_MAGIC_backref);
1425                             if (SvTYPE(sv) != SVt_PVCV)
1426                                 mg_free(sv);
1427                         }
1428                         if (SvTHINKFIRST(sv))
1429                             sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1430                                                      |SV_COW_DROP_PV);
1431
1432                     }
1433                     switch (SvTYPE(sv)) {
1434                     case SVt_NULL:
1435                         break;
1436                     case SVt_PVAV:
1437                         av_clear(MUTABLE_AV(sv));
1438                         break;
1439                     case SVt_PVHV:
1440                         hv_clear(MUTABLE_HV(sv));
1441                         break;
1442                     case SVt_PVCV:
1443                     {
1444                         HEK *hek = CvGvNAME_HEK(sv);
1445                         assert(hek);
1446                         (void)share_hek_hek(hek);
1447                         cv_undef((CV *)sv);
1448                         CvNAME_HEK_set(sv, hek);
1449                         CvLEXICAL_on(sv);
1450                         break;
1451                     }
1452                     default:
1453                         /* This looks odd, but these two macros are for use in
1454                            expressions and finish with a trailing comma, so
1455                            adding a ; after them would be wrong. */
1456                         assert_not_ROK(sv)
1457                         assert_not_glob(sv)
1458                         SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
1459                         break;
1460                     }
1461                     SvPADTMP_off(sv);
1462                     SvPADSTALE_on(sv); /* mark as no longer live */
1463                 }
1464                 else {  /* Someone has a claim on this, so abandon it. */
1465                     switch (SvTYPE(sv)) {       /* Console ourselves with a new value */
1466                     case SVt_PVAV:      *svp = MUTABLE_SV(newAV());     break;
1467                     case SVt_PVHV:      *svp = MUTABLE_SV(newHV());     break;
1468                     case SVt_PVCV:
1469                     {
1470                         HEK * const hek = CvGvNAME_HEK(sv);
1471
1472                         /* Create a stub */
1473                         *svp = newSV_type(SVt_PVCV);
1474
1475                         /* Share name */
1476                         CvNAME_HEK_set(*svp,
1477                                        share_hek_hek(hek));
1478                         CvLEXICAL_on(*svp);
1479                         break;
1480                     }
1481                     default:    *svp = newSV_type(SVt_NULL);            break;
1482                     }
1483                     SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1484                     /* preserve pad nature, but also mark as not live
1485                      * for any closure capturing */
1486                     SvFLAGS(*svp) |= SVs_PADSTALE;
1487                 }
1488             }
1489             break;
1490         }
1491
1492         case SAVEt_DELETE:
1493             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1494             /* hv_delete could die, so free the key and SvREFCNT_dec the
1495              * hv by pushing new save actions
1496              */
1497             /* ap[0] is the key */
1498             ap[1].any_uv = SAVEt_FREEPV; /* was len */
1499             /* ap[2] is the hv */
1500             ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */
1501             PL_savestack_ix += 4;
1502             (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD);
1503             break;
1504
1505         case SAVEt_ADELETE:
1506             a0 = ap[0]; a1 = ap[1];
1507             /* av_delete could die, so SvREFCNT_dec the av by pushing a
1508              * new save action
1509              */
1510             ap[0].any_av = a1.any_av;
1511             ap[1].any_uv = SAVEt_FREESV;
1512             PL_savestack_ix += 2;
1513             (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD);
1514             break;
1515
1516         case SAVEt_DESTRUCTOR_X:
1517             a0 = ap[0]; a1 = ap[1];
1518             (*a0.any_dxptr)(aTHX_ a1.any_ptr);
1519             break;
1520
1521         case SAVEt_REGCONTEXT:
1522             /* regexp must have croaked */
1523         case SAVEt_ALLOC:
1524             PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1525             break;
1526
1527         case SAVEt_STACK_POS:           /* Position on Perl stack */
1528             a0 = ap[0];
1529             PL_stack_sp = PL_stack_base + a0.any_i32;
1530             break;
1531
1532         case SAVEt_AELEM:               /* array element */
1533         {
1534             SV **svp;
1535             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1536             svp = av_fetch(a0.any_av, a1.any_iv, 1);
1537             if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */
1538                 SvREFCNT_dec(a2.any_sv);
1539             if (LIKELY(svp)) {
1540                 SV * const sv = *svp;
1541                 if (LIKELY(sv && sv != &PL_sv_undef)) {
1542                     if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied)))
1543                         SvREFCNT_inc_void_NN(sv);
1544                     a1.any_sv  = a2.any_sv;
1545                     a2.any_svp = svp;
1546                     goto restore_sv;
1547                 }
1548             }
1549             SvREFCNT_dec(a0.any_av);
1550             SvREFCNT_dec(a2.any_sv);
1551             break;
1552         }
1553
1554         case SAVEt_HELEM:               /* hash element */
1555         {
1556             HE *he;
1557
1558             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1559             he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0);
1560             SvREFCNT_dec(a1.any_sv);
1561             if (LIKELY(he)) {
1562                 const SV * const oval = HeVAL(he);
1563                 if (LIKELY(oval && oval != &PL_sv_undef)) {
1564                     SV **svp = &HeVAL(he);
1565                     if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied)))
1566                         SvREFCNT_inc_void(*svp);
1567                     a1.any_sv  = a2.any_sv;
1568                     a2.any_svp = svp;
1569                     goto restore_sv;
1570                 }
1571             }
1572             SvREFCNT_dec(a0.any_hv);
1573             SvREFCNT_dec(a2.any_sv);
1574             break;
1575         }
1576
1577         case SAVEt_OP:
1578             a0 = ap[0];
1579             PL_op = (OP*)a0.any_ptr;
1580             break;
1581
1582         case SAVEt_HINTS_HH:
1583             a2 = ap[2];
1584             /* FALLTHROUGH */
1585         case SAVEt_HINTS:
1586             a0 = ap[0]; a1 = ap[1];
1587             if ((PL_hints & HINT_LOCALIZE_HH)) {
1588               while (GvHV(PL_hintgv)) {
1589                 HV *hv = GvHV(PL_hintgv);
1590                 GvHV(PL_hintgv) = NULL;
1591                 SvREFCNT_dec(MUTABLE_SV(hv));
1592               }
1593             }
1594             cophh_free(CopHINTHASH_get(&PL_compiling));
1595             CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr);
1596             *(I32*)&PL_hints = a0.any_i32;
1597             PL_prevailing_version = (U16)(uv >> 8);
1598             if (type == SAVEt_HINTS_HH) {
1599                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1600                 GvHV(PL_hintgv) = MUTABLE_HV(a2.any_ptr);
1601             }
1602             if (!GvHV(PL_hintgv)) {
1603                 /* Need to add a new one manually, else rv2hv can
1604                    add one via GvHVn and it won't have the magic set.  */
1605                 HV *const hv = newHV();
1606                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1607                 GvHV(PL_hintgv) = hv;
1608             }
1609             assert(GvHV(PL_hintgv));
1610             break;
1611
1612         case SAVEt_COMPPAD:
1613             a0 = ap[0];
1614             PL_comppad = (PAD*)a0.any_ptr;
1615             if (LIKELY(PL_comppad))
1616                 PL_curpad = AvARRAY(PL_comppad);
1617             else
1618                 PL_curpad = NULL;
1619             break;
1620
1621         case SAVEt_PADSV_AND_MORTALIZE:
1622             {
1623                 SV **svp;
1624
1625                 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1626                 assert (a1.any_ptr);
1627                 svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv;
1628                 /* This mortalizing used to be done by CX_POOPLOOP() via
1629                    itersave.  But as we have all the information here, we
1630                    can do it here, save even having to have itersave in
1631                    the struct.
1632                    */
1633                 sv_2mortal(*svp);
1634                 *svp = a0.any_sv;
1635             }
1636             break;
1637
1638         case SAVEt_SAVESWITCHSTACK:
1639             {
1640                 dSP;
1641
1642                 a0 = ap[0]; a1 = ap[1];
1643                 SWITCHSTACK(a1.any_av, a0.any_av);
1644                 PL_curstackinfo->si_stack = a0.any_av;
1645             }
1646             break;
1647
1648         case SAVEt_SET_SVFLAGS:
1649             a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1650             SvFLAGS(a0.any_sv) &= ~(a1.any_u32);
1651             SvFLAGS(a0.any_sv) |= a2.any_u32;
1652             break;
1653
1654             /* These are only saved in mathoms.c */
1655         case SAVEt_NSTAB:
1656             a0 = ap[0];
1657             (void)sv_clear(a0.any_sv);
1658             break;
1659
1660         case SAVEt_LONG:                        /* long reference */
1661             a0 = ap[0]; a1 = ap[1];
1662             *(long*)a1.any_ptr = a0.any_long;
1663             break;
1664
1665         case SAVEt_IV:                          /* IV reference */
1666             a0 = ap[0]; a1 = ap[1];
1667             *(IV*)a1.any_ptr = a0.any_iv;
1668             break;
1669
1670         case SAVEt_I16:                         /* I16 reference */
1671             a0 = ap[0];
1672             *(I16*)a0.any_ptr = (I16)(uv >> 8);
1673             break;
1674
1675         case SAVEt_I8:                          /* I8 reference */
1676             a0 = ap[0];
1677             *(I8*)a0.any_ptr = (I8)(uv >> 8);
1678             break;
1679
1680         case SAVEt_DESTRUCTOR:
1681             a0 = ap[0]; a1 = ap[1];
1682             (*a0.any_dptr)(a1.any_ptr);
1683             break;
1684
1685         case SAVEt_COMPILE_WARNINGS:
1686             /* NOTE: we can't put &PL_compiling or PL_curcop on the save
1687              *       stack directly, as we currently cannot translate
1688              *       them to the correct addresses after a thread start
1689              *       or win32 fork start. - Yves
1690              */
1691             a0 = ap[0];
1692             free_and_set_cop_warnings(&PL_compiling, a0.any_pv);
1693             break;
1694
1695         case SAVEt_CURCOP_WARNINGS:
1696             /* NOTE: see comment above about SAVEt_COMPILE_WARNINGS */
1697             a0 = ap[0];
1698             free_and_set_cop_warnings(PL_curcop, a0.any_pv);
1699             break;
1700
1701         case SAVEt_PARSER:
1702             a0 = ap[0];
1703             parser_free((yy_parser *)a0.any_ptr);
1704             break;
1705
1706         case SAVEt_READONLY_OFF:
1707             a0 = ap[0];
1708             SvREADONLY_off(a0.any_sv);
1709             break;
1710
1711         default:
1712             Perl_croak(aTHX_ "panic: leave_scope inconsistency %u",
1713                     (U8)uv & SAVE_MASK);
1714         }
1715     }
1716
1717     TAINT_set(was);
1718 }
1719
1720 void
1721 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1722 {
1723     PERL_ARGS_ASSERT_CX_DUMP;
1724
1725 #ifdef DEBUGGING
1726     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1727     if (CxTYPE(cx) != CXt_SUBST) {
1728         const char *gimme_text;
1729         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1730         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n",
1731                       PTR2UV(cx->blk_oldcop));
1732         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1733         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1734         PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix);
1735         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n",
1736                       PTR2UV(cx->blk_oldpm));
1737         switch (cx->blk_gimme) {
1738             case G_VOID:
1739                 gimme_text = "VOID";
1740                 break;
1741             case G_SCALAR:
1742                 gimme_text = "SCALAR";
1743                 break;
1744             case G_LIST:
1745                 gimme_text = "LIST";
1746                 break;
1747             default:
1748                 gimme_text = "UNKNOWN";
1749                 break;
1750         }
1751         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1752     }
1753     switch (CxTYPE(cx)) {
1754     case CXt_NULL:
1755     case CXt_BLOCK:
1756     case CXt_DEFER:
1757         break;
1758     case CXt_FORMAT:
1759         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n",
1760                 PTR2UV(cx->blk_format.cv));
1761         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n",
1762                 PTR2UV(cx->blk_format.gv));
1763         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n",
1764                 PTR2UV(cx->blk_format.dfoutgv));
1765         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1766                       (int)CxHASARGS(cx));
1767         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n",
1768                 PTR2UV(cx->blk_format.retop));
1769         break;
1770     case CXt_SUB:
1771         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n",
1772                 PTR2UV(cx->blk_sub.cv));
1773         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1774                 (long)cx->blk_sub.olddepth);
1775         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1776                 (int)CxHASARGS(cx));
1777         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1778         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n",
1779                 PTR2UV(cx->blk_sub.retop));
1780         break;
1781     case CXt_EVAL:
1782         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1783                 (long)CxOLD_IN_EVAL(cx));
1784         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1785                 PL_op_name[CxOLD_OP_TYPE(cx)],
1786                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1787         if (cx->blk_eval.old_namesv)
1788             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1789                           SvPVX_const(cx->blk_eval.old_namesv));
1790         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n",
1791                 PTR2UV(cx->blk_eval.old_eval_root));
1792         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n",
1793                 PTR2UV(cx->blk_eval.retop));
1794         break;
1795
1796     case CXt_LOOP_PLAIN:
1797     case CXt_LOOP_LAZYIV:
1798     case CXt_LOOP_LAZYSV:
1799     case CXt_LOOP_LIST:
1800     case CXt_LOOP_ARY:
1801         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1802         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n",
1803                 PTR2UV(cx->blk_loop.my_op));
1804         if (CxTYPE(cx) != CXt_LOOP_PLAIN) {
1805             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n",
1806                     PTR2UV(CxITERVAR(cx)));
1807             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n",
1808                     PTR2UV(cx->blk_loop.itersave));
1809         }
1810         if (CxTYPE(cx) == CXt_LOOP_ARY) {
1811             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n",
1812                     PTR2UV(cx->blk_loop.state_u.ary.ary));
1813             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1814                     (long)cx->blk_loop.state_u.ary.ix);
1815         }
1816         break;
1817
1818     case CXt_SUBST:
1819         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1820                 (long)cx->sb_iters);
1821         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1822                 (long)cx->sb_maxiters);
1823         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1824                 (long)cx->sb_rflags);
1825         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1826                 (long)CxONCE(cx));
1827         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1828                 cx->sb_orig);
1829         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n",
1830                 PTR2UV(cx->sb_dstr));
1831         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n",
1832                 PTR2UV(cx->sb_targ));
1833         PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n",
1834                 PTR2UV(cx->sb_s));
1835         PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n",
1836                 PTR2UV(cx->sb_m));
1837         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n",
1838                 PTR2UV(cx->sb_strend));
1839         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n",
1840                 PTR2UV(cx->sb_rxres));
1841         break;
1842     }
1843 #else
1844     PERL_UNUSED_CONTEXT;
1845     PERL_UNUSED_ARG(cx);
1846 #endif  /* DEBUGGING */
1847 }
1848
1849 /*
1850 =for apidoc_section $callback
1851 =for apidoc mortal_destructor_sv
1852
1853 This function arranges for either a Perl code reference, or a C function
1854 reference to be called at the B<end of the current statement>.
1855
1856 The C<coderef> argument determines the type of function that will be
1857 called. If it is C<SvROK()> it is assumed to be a reference to a CV and
1858 will arrange for the coderef to be called. If it is not SvROK() then it
1859 is assumed to be a C<SvIV()> which is C<SvIOK()> whose value is a pointer
1860 to a C function of type C<DESTRUCTORFUNC_t> created using C<PTR2INT()>.
1861 Either way the C<args> parameter will be provided to the callback as a
1862 parameter, although the rules for doing so differ between the Perl and
1863 C mode. Normally this function is only used directly for the Perl case
1864 and the wrapper C<mortal_destructor_x()> is used for the C function case.
1865
1866 When operating in Perl callback mode the C<args> parameter may be NULL
1867 in which case the code reference is called with no arguments, otherwise
1868 if it is an AV (SvTYPE(args) == SVt_PVAV) then the contents of the AV
1869 will be used as the arguments to the code reference, and if it is any
1870 other type then the C<args> SV will be provided as a single argument to
1871 the code reference.
1872
1873 When operating in a C callback mode the C<args> parameter will be passed
1874 directly to the C function as a C<void *> pointer. No additional
1875 processing of the argument will be peformed, and it is the callers
1876 responsibility to free the C<args> parameter if necessary.
1877
1878 Be aware that there is a signficant difference in timing between the
1879 I<end of the current statement> and the I<end of the current pseudo
1880 block>. If you are looking for a mechanism to trigger a function at the
1881 end of the B<current pseudo block> you should look at
1882 C<SAVEDESTRUCTORX()> instead of this function.
1883
1884 =for apidoc mortal_svfunc_x
1885
1886 This function arranges for a C function reference to be called at the
1887 B<end of the current statement> with the arguments provided. It is a
1888 wrapper around C<mortal_destructor_sv()> which ensures that the latter
1889 function is called appropriately.
1890
1891 Be aware that there is a signficant difference in timing between the
1892 I<end of the current statement> and the I<end of the current pseudo
1893 block>. If you are looking for a mechanism to trigger a function at the
1894 end of the B<current pseudo block> you should look at
1895 C<SAVEDESTRUCTORX()> instead of this function.
1896
1897 =for apidoc magic_freedestruct
1898
1899 This function is called via magic to implement the
1900 C<mortal_destructor_sv()> and C<mortal_destructor_x()> functions. It
1901 should not be called directly and has no user servicable parts.
1902
1903 =cut
1904 */
1905
1906 void
1907 Perl_mortal_destructor_sv(pTHX_ SV *coderef, SV *args) {
1908     PERL_ARGS_ASSERT_MORTAL_DESTRUCTOR_SV;
1909     assert(
1910         (SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) /* perl coderef */
1911          ||
1912         (SvIOK(coderef) && !SvROK(coderef))                  /* C function ref */
1913     );
1914     SV *variable = newSV_type_mortal(SVt_IV);
1915     (void)sv_magicext(variable, coderef, PERL_MAGIC_destruct,
1916                       &PL_vtbl_destruct, (char *)args, args ? HEf_SVKEY : 0);
1917 }
1918
1919
1920 void
1921 Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f, SV *sv) {
1922     PERL_ARGS_ASSERT_MORTAL_SVFUNC_X;
1923     SV *sviv = newSViv(PTR2IV(f));
1924     mortal_destructor_sv(sviv,sv);
1925 }
1926
1927
1928 int
1929 Perl_magic_freedestruct(pTHX_ SV* sv, MAGIC* mg) {
1930     PERL_ARGS_ASSERT_MAGIC_FREEDESTRUCT;
1931     dSP;
1932     union {
1933         SV   *sv;
1934         AV   *av;
1935         char *pv;
1936     } args_any;
1937     SV *coderef;
1938
1939     IV nargs = 0;
1940     if (PL_phase == PERL_PHASE_DESTRUCT) {
1941         Perl_warn(aTHX_ "Can't call destructor for 0x%p in global destruction\n", sv);
1942         return 1;
1943     }
1944
1945     args_any.pv = mg->mg_ptr;
1946     coderef = mg->mg_obj;
1947
1948     /* Deal with C function destructor */
1949     if (SvTYPE(coderef) == SVt_IV && !SvROK(coderef)) {
1950         SVFUNC_t f = INT2PTR(SVFUNC_t, SvIV(coderef));
1951         (f)(aTHX_ args_any.sv);
1952         return 0;
1953     }
1954
1955     if (args_any.sv) {
1956         if (SvTYPE(args_any.sv) == SVt_PVAV) {
1957             nargs = av_len(args_any.av) + 1;
1958         } else {
1959             nargs = 1;
1960         }
1961     }
1962     PUSHSTACKi(PERLSI_MAGIC);
1963     ENTER_with_name("call_freedestruct");
1964     SAVETMPS;
1965     EXTEND(SP, nargs);
1966     PUSHMARK(SP);
1967     if (args_any.sv) {
1968         if (SvTYPE(args_any.sv) == SVt_PVAV) {
1969             IV n;
1970             for (n = 0 ; n < nargs ; n++ ) {
1971                 SV **argp = av_fetch(args_any.av, n, 0);
1972                 if (argp && *argp)
1973                     PUSHs(*argp);
1974             }
1975         } else {
1976             PUSHs(args_any.sv);
1977         }
1978     }
1979     PUTBACK;
1980     (void)call_sv(coderef, G_VOID | G_EVAL | G_KEEPERR);
1981     FREETMPS;
1982     LEAVE_with_name("call_freedestruct");
1983     POPSTACK;
1984     return 0;
1985 }
1986
1987
1988 /*
1989  * ex: set ts=8 sts=4 sw=4 et:
1990  */