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