scope.c

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