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 int i = *intp;
 395     UV type = ((UV)(i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
 396     int size = 2;
 397     dSS_ADD;
 398
 399     PERL_ARGS_ASSERT_SAVE_INT;
 400
 401     if ((int)(type >> SAVE_TIGHT_SHIFT) != i) {
 402         SS_ADD_INT(i);
 403         type = SAVEt_INT;
 404         size++;
 405     }
 406     SS_ADD_PTR(intp);
 407     SS_ADD_UV(type);
 408     SS_ADD_END(size);
 409 }
 410
 411 void
 412 Perl_save_I8(pTHX_ I8 *bytep)
 413 {
 414     dVAR;
 415     dSS_ADD;
 416
 417     PERL_ARGS_ASSERT_SAVE_I8;
 418
 419     SS_ADD_PTR(bytep);
 420     SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
 421     SS_ADD_END(2);
 422 }
 423
 424 void
 425 Perl_save_I16(pTHX_ I16 *intp)
 426 {
 427     dVAR;
 428     dSS_ADD;
 429
 430     PERL_ARGS_ASSERT_SAVE_I16;
 431
 432     SS_ADD_PTR(intp);
 433     SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
 434     SS_ADD_END(2);
 435 }
 436
 437 void
 438 Perl_save_I32(pTHX_ I32 *intp)
 439 {
 440     dVAR;
 441     const I32 i = *intp;
 442     UV type = ((I32)(i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
 443     int size = 2;
 444     dSS_ADD;
 445
 446     PERL_ARGS_ASSERT_SAVE_I32;
 447
 448     if ((I32)(type >> SAVE_TIGHT_SHIFT) != i) {
 449         SS_ADD_INT(i);
 450         type = SAVEt_I32;
 451         size++;
 452     }
 453     SS_ADD_PTR(intp);
 454     SS_ADD_UV(type);
 455     SS_ADD_END(size);
 456 }
 457
 458 /* Cannot use save_sptr() to store a char* since the SV** cast will
 459  * force word-alignment and we'll miss the pointer.
 460  */
 461 void
 462 Perl_save_pptr(pTHX_ char **pptr)
 463 {
 464     dVAR;
 465
 466     PERL_ARGS_ASSERT_SAVE_PPTR;
 467
 468     save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
 469 }
 470
 471 void
 472 Perl_save_vptr(pTHX_ void *ptr)
 473 {
 474     dVAR;
 475
 476     PERL_ARGS_ASSERT_SAVE_VPTR;
 477
 478     save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
 479 }
 480
 481 void
 482 Perl_save_sptr(pTHX_ SV **sptr)
 483 {
 484     dVAR;
 485
 486     PERL_ARGS_ASSERT_SAVE_SPTR;
 487
 488     save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
 489 }
 490
 491 void
 492 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
 493 {
 494     dVAR;
 495     dSS_ADD;
 496
 497     ASSERT_CURPAD_ACTIVE("save_padsv");
 498     SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
 499     SS_ADD_PTR(PL_comppad);
 500     SS_ADD_LONG((long)off);
 501     SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
 502     SS_ADD_END(4);
 503 }
 504
 505 void
 506 Perl_save_hptr(pTHX_ HV **hptr)
 507 {
 508     dVAR;
 509
 510     PERL_ARGS_ASSERT_SAVE_HPTR;
 511
 512     save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
 513 }
 514
 515 void
 516 Perl_save_aptr(pTHX_ AV **aptr)
 517 {
 518     dVAR;
 519
 520     PERL_ARGS_ASSERT_SAVE_APTR;
 521
 522     save_pushptrptr(*aptr, aptr, SAVEt_APTR);
 523 }
 524
 525 void
 526 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
 527 {
 528     dVAR;
 529     dSS_ADD;
 530     SS_ADD_PTR(ptr);
 531     SS_ADD_UV(type);
 532     SS_ADD_END(2);
 533 }
 534
 535 void
 536 Perl_save_clearsv(pTHX_ SV **svp)
 537 {
 538     dVAR;
 539     const UV offset = svp - PL_curpad;
 540     const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
 541
 542     PERL_ARGS_ASSERT_SAVE_CLEARSV;
 543
 544     ASSERT_CURPAD_ACTIVE("save_clearsv");
 545     SvPADSTALE_off(*svp); /* mark lexical as active */
 546     if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset) {
 547         Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
 548                    offset, svp, PL_curpad);
 549     }
 550
 551     {
 552         dSS_ADD;
 553         SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
 554         SS_ADD_END(1);
 555     }
 556 }
 557
 558 void
 559 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 560 {
 561     dVAR;
 562
 563     PERL_ARGS_ASSERT_SAVE_DELETE;
 564
 565     save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
 566 }
 567
 568 void
 569 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
 570 {
 571     STRLEN len;
 572     I32 klen;
 573     const char *key;
 574
 575     PERL_ARGS_ASSERT_SAVE_HDELETE;
 576
 577     key  = SvPV_const(keysv, len);
 578     klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
 579     SvREFCNT_inc_simple_void_NN(hv);
 580     save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
 581 }
 582
 583 void
 584 Perl_save_adelete(pTHX_ AV *av, I32 key)
 585 {
 586     dVAR;
 587
 588     PERL_ARGS_ASSERT_SAVE_ADELETE;
 589
 590     SvREFCNT_inc_void(av);
 591     save_pushi32ptr(key, av, SAVEt_ADELETE);
 592 }
 593
 594 void
 595 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 596 {
 597     dVAR;
 598     dSS_ADD;
 599
 600     PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
 601
 602     SS_ADD_DPTR(f);
 603     SS_ADD_PTR(p);
 604     SS_ADD_UV(SAVEt_DESTRUCTOR);
 605     SS_ADD_END(3);
 606 }
 607
 608 void
 609 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 610 {
 611     dVAR;
 612     dSS_ADD;
 613
 614     SS_ADD_DXPTR(f);
 615     SS_ADD_PTR(p);
 616     SS_ADD_UV(SAVEt_DESTRUCTOR_X);
 617     SS_ADD_END(3);
 618 }
 619
 620 void
 621 Perl_save_hints(pTHX)
 622 {
 623     dVAR;
 624     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
 625     if (PL_hints & HINT_LOCALIZE_HH) {
 626         HV *oldhh = GvHV(PL_hintgv);
 627         save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
 628         GvHV(PL_hintgv) = NULL; /* in case copying dies */
 629         GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
 630     } else {
 631         save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
 632     }
 633 }
 634
 635 static void
 636 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
 637                         const int type)
 638 {
 639     dSS_ADD;
 640     SS_ADD_PTR(ptr1);
 641     SS_ADD_INT(i);
 642     SS_ADD_PTR(ptr2);
 643     SS_ADD_UV(type);
 644     SS_ADD_END(4);
 645 }
 646
 647 void
 648 Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
 649 {
 650     dVAR;
 651     SV *sv;
 652
 653     PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
 654
 655     SvGETMAGIC(*sptr);
 656     save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr),
 657                        SAVEt_AELEM);
 658     /* The array needs to hold a reference count on its new element, so it
 659        must be AvREAL. */
 660     if (!AvREAL(av) && AvREIFY(av))
 661         av_reify(av);
 662     save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
 663     if (flags & SAVEf_KEEPOLDELEM)
 664         return;
 665     sv = *sptr;
 666     /* If we're localizing a tied array element, this new sv
 667      * won't actually be stored in the array - so it won't get
 668      * reaped when the localize ends. Ensure it gets reaped by
 669      * mortifying it instead. DAPM */
 670     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 671         sv_2mortal(sv);
 672 }
 673
 674 void
 675 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
 676 {
 677     dVAR;
 678     SV *sv;
 679
 680     PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
 681
 682     SvGETMAGIC(*sptr);
 683     {
 684         dSS_ADD;
 685         SS_ADD_PTR(SvREFCNT_inc_simple(hv));
 686         SS_ADD_PTR(newSVsv(key));
 687         SS_ADD_PTR(SvREFCNT_inc(*sptr));
 688         SS_ADD_UV(SAVEt_HELEM);
 689         SS_ADD_END(4);
 690     }
 691     save_scalar_at(sptr, flags);
 692     if (flags & SAVEf_KEEPOLDELEM)
 693         return;
 694     sv = *sptr;
 695     /* If we're localizing a tied hash element, this new sv
 696      * won't actually be stored in the hash - so it won't get
 697      * reaped when the localize ends. Ensure it gets reaped by
 698      * mortifying it instead. DAPM */
 699     if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
 700         sv_2mortal(sv);
 701 }
 702
 703 SV*
 704 Perl_save_svref(pTHX_ SV **sptr)
 705 {
 706     dVAR;
 707
 708     PERL_ARGS_ASSERT_SAVE_SVREF;
 709
 710     SvGETMAGIC(*sptr);
 711     save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
 712     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
 713 }
 714
 715 I32
 716 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 717 {
 718     dVAR;
 719     const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
 720                           - (char*)PL_savestack);
 721     const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
 722     const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
 723
 724     if ((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)
 725         Perl_croak(aTHX_ "panic: save_alloc elems %"UVuf" out of range (%ld-%ld)",
 726                    elems, size, pad);
 727
 728     SSGROW(elems + 1);
 729
 730     PL_savestack_ix += elems;
 731     SSPUSHUV(SAVEt_ALLOC | elems_shifted);
 732     return start;
 733 }
 734
 735 void
 736 Perl_leave_scope(pTHX_ I32 base)
 737 {
 738     dVAR;
 739     SV *sv;
 740     SV *value;
 741     GV *gv;
 742     AV *av;
 743     HV *hv;
 744     void* ptr;
 745     char* str;
 746     I32 i;
 747     /* Localise the effects of the TAINT_NOT inside the loop.  */
 748     bool was = TAINT_get;
 749
 750     if (base < -1)
 751         Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
 752     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
 753                         (long)PL_savestack_ix, (long)base));
 754     while (PL_savestack_ix > base) {
 755         UV uv = SSPOPUV;
 756         const U8 type = (U8)uv & SAVE_MASK;
 757         TAINT_NOT;
 758
 759         switch (type) {
 760         case SAVEt_ITEM:                        /* normal string */
 761             value = MUTABLE_SV(SSPOPPTR);
 762             sv = MUTABLE_SV(SSPOPPTR);
 763             sv_replace(sv,value);
 764             PL_localizing = 2;
 765             SvSETMAGIC(sv);
 766             PL_localizing = 0;
 767             break;
 768         case SAVEt_SV:                          /* scalar reference */
 769             value = MUTABLE_SV(SSPOPPTR);
 770             gv = MUTABLE_GV(SSPOPPTR);
 771             ptr = &GvSV(gv);
 772             av = MUTABLE_AV(gv); /* what to refcnt_dec */
 773         restore_sv:
 774             sv = *(SV**)ptr;
 775             *(SV**)ptr = value;
 776             SvREFCNT_dec(sv);
 777             PL_localizing = 2;
 778             SvSETMAGIC(value);
 779             PL_localizing = 0;
 780             SvREFCNT_dec(value);
 781             SvREFCNT_dec(av); /* av may actually be an AV, HV or GV */
 782             break;
 783         case SAVEt_GENERIC_PVREF:               /* generic pv */
 784             ptr = SSPOPPTR;
 785             str = (char*)SSPOPPTR;
 786             if (*(char**)ptr != str) {
 787                 Safefree(*(char**)ptr);
 788                 *(char**)ptr = str;
 789             }
 790             break;
 791         case SAVEt_SHARED_PVREF:                /* shared pv */
 792             str = (char*)SSPOPPTR;
 793             ptr = SSPOPPTR;
 794             if (*(char**)ptr != str) {
 795 #ifdef NETWARE
 796                 PerlMem_free(*(char**)ptr);
 797 #else
 798                 PerlMemShared_free(*(char**)ptr);
 799 #endif
 800                 *(char**)ptr = str;
 801             }
 802             break;
 803         case SAVEt_GVSV:                        /* scalar slot in GV */
 804             value = MUTABLE_SV(SSPOPPTR);
 805             gv = MUTABLE_GV(SSPOPPTR);
 806             ptr = &GvSV(gv);
 807             goto restore_svp;
 808         case SAVEt_GENERIC_SVREF:               /* generic sv */
 809             value = MUTABLE_SV(SSPOPPTR);
 810             ptr = SSPOPPTR;
 811         restore_svp:
 812             sv = *(SV**)ptr;
 813             *(SV**)ptr = value;
 814             SvREFCNT_dec(sv);
 815             SvREFCNT_dec(value);
 816             break;
 817         case SAVEt_GVSLOT:                      /* any slot in GV */
 818             value = MUTABLE_SV(SSPOPPTR);
 819             ptr = SSPOPPTR;
 820             gv = MUTABLE_GV(SSPOPPTR);
 821             hv = GvSTASH(gv);
 822             if (hv && HvENAME(hv) && (
 823                     (value && SvTYPE(value) == SVt_PVCV)
 824                  || (*(SV **)ptr && SvTYPE(*(SV**)ptr) == SVt_PVCV)
 825                ))
 826             {
 827                 if ((char *)ptr < (char *)GvGP(gv)
 828                  || (char *)ptr > (char *)GvGP(gv) + sizeof(struct gp)
 829                  || GvREFCNT(gv) > 1)
 830                     PL_sub_generation++;
 831                 else mro_method_changed_in(hv);
 832             }
 833             goto restore_svp;
 834         case SAVEt_AV:                          /* array reference */
 835             av = MUTABLE_AV(SSPOPPTR);
 836             gv = MUTABLE_GV(SSPOPPTR);
 837             SvREFCNT_dec(GvAV(gv));
 838             GvAV(gv) = av;
 839             if (SvMAGICAL(av)) {
 840                 PL_localizing = 2;
 841                 SvSETMAGIC(MUTABLE_SV(av));
 842                 PL_localizing = 0;
 843             }
 844             SvREFCNT_dec(gv);
 845             break;
 846         case SAVEt_HV:                          /* hash reference */
 847             hv = MUTABLE_HV(SSPOPPTR);
 848             gv = MUTABLE_GV(SSPOPPTR);
 849             SvREFCNT_dec(GvHV(gv));
 850             GvHV(gv) = hv;
 851             if (SvMAGICAL(hv)) {
 852                 PL_localizing = 2;
 853                 SvSETMAGIC(MUTABLE_SV(hv));
 854                 PL_localizing = 0;
 855             }
 856             SvREFCNT_dec(gv);
 857             break;
 858         case SAVEt_INT_SMALL:
 859             ptr = SSPOPPTR;
 860             *(int*)ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
 861             break;
 862         case SAVEt_INT:                         /* int reference */
 863             ptr = SSPOPPTR;
 864             *(int*)ptr = (int)SSPOPINT;
 865             break;
 866         case SAVEt_BOOL:                        /* bool reference */
 867             ptr = SSPOPPTR;
 868             *(bool*)ptr = cBOOL(uv >> 8);
 869 #if !NO_TAINT_SUPPORT
 870             if (ptr == &(TAINT_get)) {
 871                 /* If we don't update <was>, to reflect what was saved on the
 872                  * stack for PL_tainted, then we will overwrite this attempt to
 873                  * restore it when we exit this routine.  Note that this won't
 874                  * work if this value was saved in a wider-than necessary type,
 875                  * such as I32 */
 876                 was = *(bool*)ptr;
 877             }
 878 #endif
 879             break;
 880         case SAVEt_I32_SMALL:
 881             ptr = SSPOPPTR;
 882             *(I32*)ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
 883             break;
 884         case SAVEt_I32:                         /* I32 reference */
 885             ptr = SSPOPPTR;
 886 #ifdef PERL_DEBUG_READONLY_OPS
 887             {
 888                 const I32 val = SSPOPINT;
 889                 if (*(I32*)ptr != val)
 890                     *(I32*)ptr = val;
 891             }
 892 #else
 893             *(I32*)ptr = (I32)SSPOPINT;
 894 #endif
 895             break;
 896         case SAVEt_SPTR:                        /* SV* reference */
 897             ptr = SSPOPPTR;
 898             *(SV**)ptr = MUTABLE_SV(SSPOPPTR);
 899             break;
 900         case SAVEt_VPTR:                        /* random* reference */
 901         case SAVEt_PPTR:                        /* char* reference */
 902             ptr = SSPOPPTR;
 903             *(char**)ptr = (char*)SSPOPPTR;
 904             break;
 905         case SAVEt_HPTR:                        /* HV* reference */
 906             ptr = SSPOPPTR;
 907             *(HV**)ptr = MUTABLE_HV(SSPOPPTR);
 908             break;
 909         case SAVEt_APTR:                        /* AV* reference */
 910             ptr = SSPOPPTR;
 911             *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
 912             break;
 913         case SAVEt_GP:                          /* scalar reference */
 914             ptr = SSPOPPTR;
 915             gv = MUTABLE_GV(SSPOPPTR);
 916             {
 917              /* possibly taking a method out of circulation */
 918              const bool had_method = !!GvCVu(gv);
 919              gp_free(gv);
 920              GvGP_set(gv, (GP*)ptr);
 921              if ((hv=GvSTASH(gv)) && HvENAME_get(hv)) {
 922               if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3))
 923                 mro_isa_changed_in(hv);
 924               else if (had_method || GvCVu(gv))
 925                 /* putting a method back into circulation ("local")*/
 926                 gv_method_changed(gv);
 927              }
 928             }
 929             SvREFCNT_dec(gv);
 930             break;
 931         case SAVEt_FREESV:
 932             ptr = SSPOPPTR;
 933             SvREFCNT_dec(MUTABLE_SV(ptr));
 934             break;
 935         case SAVEt_FREECOPHH:
 936             ptr = SSPOPPTR;
 937             cophh_free((COPHH *)ptr);
 938             break;
 939         case SAVEt_MORTALIZESV:
 940             ptr = SSPOPPTR;
 941             sv_2mortal(MUTABLE_SV(ptr));
 942             break;
 943         case SAVEt_FREEOP:
 944             ptr = SSPOPPTR;
 945             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
 946             op_free((OP*)ptr);
 947             break;
 948         case SAVEt_FREEPV:
 949             ptr = SSPOPPTR;
 950             Safefree(ptr);
 951             break;
 952
 953         {
 954           SV **svp;
 955         case SAVEt_CLEARPADRANGE:
 956             i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
 957             svp = &PL_curpad[uv >>
 958                     (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
 959             goto clearsv;
 960         case SAVEt_CLEARSV:
 961             svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
 962             i = 1;
 963           clearsv:
 964             for (; i; i--, svp--) {
 965                 sv = *svp;
 966
 967                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 968              "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
 969                     PTR2UV(PL_comppad), PTR2UV(PL_curpad),
 970                     (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
 971                     (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
 972                 ));
 973
 974                 /* Can clear pad variable in place? */
 975                 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
 976                     /*
 977                      * if a my variable that was made readonly is going out of
 978                      * scope, we want to remove the readonlyness so that it can
 979                      * go out of scope quietly
 980                      */
 981                     if (SvPADMY(sv) && !SvFAKE(sv))
 982                         SvREADONLY_off(sv);
 983
 984                     if (SvTHINKFIRST(sv))
 985                         sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
 986                                                  |SV_COW_DROP_PV);
 987                     if (SvTYPE(sv) == SVt_PVHV)
 988                         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
 989                     if (SvMAGICAL(sv))
 990                     {
 991                       sv_unmagic(sv, PERL_MAGIC_backref);
 992                       if (SvTYPE(sv) != SVt_PVCV)
 993                         mg_free(sv);
 994                     }
 995
 996                     switch (SvTYPE(sv)) {
 997                     case SVt_NULL:
 998                         break;
 999                     case SVt_PVAV:
1000                         av_clear(MUTABLE_AV(sv));
1001                         break;
1002                     case SVt_PVHV:
1003                         hv_clear(MUTABLE_HV(sv));
1004                         break;
1005                     case SVt_PVCV:
1006                     {
1007                         HEK * const hek = CvNAME_HEK((CV *)sv);
1008                         assert(hek);
1009                         share_hek_hek(hek);
1010                         cv_undef((CV *)sv);
1011                         CvNAME_HEK_set(sv, hek);
1012                         break;
1013                     }
1014                     default:
1015                         SvOK_off(sv);
1016                         break;
1017                     }
1018                     SvPADSTALE_on(sv); /* mark as no longer live */
1019                 }
1020                 else {  /* Someone has a claim on this, so abandon it. */
1021                     assert(  SvFLAGS(sv) & SVs_PADMY);
1022                     assert(!(SvFLAGS(sv) & SVs_PADTMP));
1023                     switch (SvTYPE(sv)) {       /* Console ourselves with a new value */
1024                     case SVt_PVAV:      *svp = MUTABLE_SV(newAV());     break;
1025                     case SVt_PVHV:      *svp = MUTABLE_SV(newHV());     break;
1026                     case SVt_PVCV:
1027                     {
1028                         /* Create a stub */
1029                         *svp = newSV_type(SVt_PVCV);
1030
1031                         /* Share name */
1032                         assert(CvNAMED(sv));
1033                         CvNAME_HEK_set(*svp,
1034                             share_hek_hek(CvNAME_HEK((CV *)sv)));
1035                         break;
1036                     }
1037                     default:    *svp = newSV(0);                break;
1038                     }
1039                     SvREFCNT_dec(sv);   /* Cast current value to the winds. */
1040                     /* preserve pad nature, but also mark as not live
1041                      * for any closure capturing */
1042                     SvFLAGS(*svp) |= (SVs_PADMY|SVs_PADSTALE);
1043                 }
1044             }
1045             break;
1046         }
1047         case SAVEt_DELETE:
1048             ptr = SSPOPPTR;
1049             hv = MUTABLE_HV(ptr);
1050             i = SSPOPINT;
1051             ptr = SSPOPPTR;
1052             (void)hv_delete(hv, (char*)ptr, i, G_DISCARD);
1053             SvREFCNT_dec(hv);
1054             Safefree(ptr);
1055             break;
1056         case SAVEt_ADELETE:
1057             ptr = SSPOPPTR;
1058             av = MUTABLE_AV(ptr);
1059             i = SSPOPINT;
1060             (void)av_delete(av, i, G_DISCARD);
1061             SvREFCNT_dec(av);
1062             break;
1063         case SAVEt_DESTRUCTOR_X:
1064             ptr = SSPOPPTR;
1065             (*SSPOPDXPTR)(aTHX_ ptr);
1066             break;
1067         case SAVEt_REGCONTEXT:
1068             /* regexp must have croaked */
1069         case SAVEt_ALLOC:
1070             PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1071             break;
1072         case SAVEt_STACK_POS:           /* Position on Perl stack */
1073             i = SSPOPINT;
1074             PL_stack_sp = PL_stack_base + i;
1075             break;
1076         case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
1077             i = SSPOPINT;
1078             cxstack[i].blk_oldsp = SSPOPINT;
1079             break;
1080         case SAVEt_AELEM:               /* array element */
1081             value = MUTABLE_SV(SSPOPPTR);
1082             i = SSPOPINT;
1083             av = MUTABLE_AV(SSPOPPTR);
1084             ptr = av_fetch(av,i,1);
1085             if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
1086                 SvREFCNT_dec(value);
1087             if (ptr) {
1088                 sv = *(SV**)ptr;
1089                 if (sv && sv != &PL_sv_undef) {
1090                     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
1091                         SvREFCNT_inc_void_NN(sv);
1092                     goto restore_sv;
1093                 }
1094             }
1095             SvREFCNT_dec(av);
1096             SvREFCNT_dec(value);
1097             break;
1098         case SAVEt_HELEM:               /* hash element */
1099             value = MUTABLE_SV(SSPOPPTR);
1100             sv = MUTABLE_SV(SSPOPPTR);
1101             hv = MUTABLE_HV(SSPOPPTR);
1102             ptr = hv_fetch_ent(hv, sv, 1, 0);
1103             SvREFCNT_dec(sv);
1104             if (ptr) {
1105                 const SV * const oval = HeVAL((HE*)ptr);
1106                 if (oval && oval != &PL_sv_undef) {
1107                     ptr = &HeVAL((HE*)ptr);
1108                     if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1109                         SvREFCNT_inc_void(*(SV**)ptr);
1110                     av = MUTABLE_AV(hv); /* what to refcnt_dec */
1111                     goto restore_sv;
1112                 }
1113             }
1114             SvREFCNT_dec(hv);
1115             SvREFCNT_dec(value);
1116             break;
1117         case SAVEt_OP:
1118             PL_op = (OP*)SSPOPPTR;
1119             break;
1120         case SAVEt_HINTS:
1121             if ((PL_hints & HINT_LOCALIZE_HH)) {
1122               while (GvHV(PL_hintgv)) {
1123                 HV *hv = GvHV(PL_hintgv);
1124                 GvHV(PL_hintgv) = NULL;
1125                 SvREFCNT_dec(MUTABLE_SV(hv));
1126               }
1127             }
1128             cophh_free(CopHINTHASH_get(&PL_compiling));
1129             CopHINTHASH_set(&PL_compiling, (COPHH*)SSPOPPTR);
1130             *(I32*)&PL_hints = (I32)SSPOPINT;
1131             if (PL_hints & HINT_LOCALIZE_HH) {
1132                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1133                 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
1134             }
1135             if (!GvHV(PL_hintgv)) {
1136                 /* Need to add a new one manually, else rv2hv can
1137                    add one via GvHVn and it won't have the magic set.  */
1138                 HV *const hv = newHV();
1139                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1140                 GvHV(PL_hintgv) = hv;
1141             }
1142             assert(GvHV(PL_hintgv));
1143             break;
1144         case SAVEt_COMPPAD:
1145             PL_comppad = (PAD*)SSPOPPTR;
1146             if (PL_comppad)
1147                 PL_curpad = AvARRAY(PL_comppad);
1148             else
1149                 PL_curpad = NULL;
1150             break;
1151         case SAVEt_PADSV_AND_MORTALIZE:
1152             {
1153                 const PADOFFSET off = (PADOFFSET)SSPOPLONG;
1154                 SV **svp;
1155                 ptr = SSPOPPTR;
1156                 assert (ptr);
1157                 svp = AvARRAY((PAD*)ptr) + off;
1158                 /* This mortalizing used to be done by POPLOOP() via itersave.
1159                    But as we have all the information here, we can do it here,
1160                    save even having to have itersave in the struct.  */
1161                 sv_2mortal(*svp);
1162                 *svp = MUTABLE_SV(SSPOPPTR);
1163             }
1164             break;
1165         case SAVEt_SAVESWITCHSTACK:
1166             {
1167                 dSP;
1168                 AV *const t = MUTABLE_AV(SSPOPPTR);
1169                 AV *const f = MUTABLE_AV(SSPOPPTR);
1170                 SWITCHSTACK(t,f);
1171                 PL_curstackinfo->si_stack = f;
1172             }
1173             break;
1174         case SAVEt_SET_SVFLAGS:
1175             {
1176                 const U32 val  = (U32)SSPOPINT;
1177                 const U32 mask = (U32)SSPOPINT;
1178                 sv = MUTABLE_SV(SSPOPPTR);
1179                 SvFLAGS(sv) &= ~mask;
1180                 SvFLAGS(sv) |= val;
1181             }
1182             break;
1183
1184             /* This would be a mathom, but Perl_save_svref() calls a static
1185                function, S_save_scalar_at(), so has to stay in this file.  */
1186         case SAVEt_SVREF:                       /* scalar reference */
1187             value = MUTABLE_SV(SSPOPPTR);
1188             ptr = SSPOPPTR;
1189             av = NULL; /* what to refcnt_dec */
1190             goto restore_sv;
1191
1192             /* These are only saved in mathoms.c */
1193         case SAVEt_NSTAB:
1194             gv = MUTABLE_GV(SSPOPPTR);
1195             (void)sv_clear(MUTABLE_SV(gv));
1196             break;
1197         case SAVEt_LONG:                        /* long reference */
1198             ptr = SSPOPPTR;
1199             *(long*)ptr = (long)SSPOPLONG;
1200             break;
1201         case SAVEt_IV:                          /* IV reference */
1202             ptr = SSPOPPTR;
1203             *(IV*)ptr = (IV)SSPOPIV;
1204             break;
1205
1206         case SAVEt_I16:                         /* I16 reference */
1207             ptr = SSPOPPTR;
1208             *(I16*)ptr = (I16)(uv >> 8);
1209             break;
1210         case SAVEt_I8:                          /* I8 reference */
1211             ptr = SSPOPPTR;
1212             *(I8*)ptr = (I8)(uv >> 8);
1213             break;
1214         case SAVEt_DESTRUCTOR:
1215             ptr = SSPOPPTR;
1216             (*SSPOPDPTR)(ptr);
1217             break;
1218         case SAVEt_COMPILE_WARNINGS:
1219             ptr = SSPOPPTR;
1220
1221             if (!specialWARN(PL_compiling.cop_warnings))
1222                 PerlMemShared_free(PL_compiling.cop_warnings);
1223
1224             PL_compiling.cop_warnings = (STRLEN*)ptr;
1225             break;
1226         case SAVEt_RE_STATE:
1227             {
1228                 const struct re_save_state *const state
1229                     = (struct re_save_state *)
1230                     (PL_savestack + PL_savestack_ix
1231                      - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
1232                 PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
1233
1234                 if (PL_reg_poscache != state->re_state_reg_poscache) {
1235                     Safefree(PL_reg_poscache);
1236                 }
1237                 Copy(state, &PL_reg_state, 1, struct re_save_state);
1238             }
1239             break;
1240         case SAVEt_PARSER:
1241             ptr = SSPOPPTR;
1242             parser_free((yy_parser *) ptr);
1243             break;
1244         default:
1245             Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
1246         }
1247     }
1248
1249     TAINT_set(was);
1250
1251     PERL_ASYNC_CHECK();
1252 }
1253
1254 void
1255 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1256 {
1257     dVAR;
1258
1259     PERL_ARGS_ASSERT_CX_DUMP;
1260
1261 #ifdef DEBUGGING
1262     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1263     if (CxTYPE(cx) != CXt_SUBST) {
1264         const char *gimme_text;
1265         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1266         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1267                       PTR2UV(cx->blk_oldcop));
1268         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1269         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1270         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1271                       PTR2UV(cx->blk_oldpm));
1272         switch (cx->blk_gimme) {
1273             case G_VOID:
1274                 gimme_text = "VOID";
1275                 break;
1276             case G_SCALAR:
1277                 gimme_text = "SCALAR";
1278                 break;
1279             case G_ARRAY:
1280                 gimme_text = "LIST";
1281                 break;
1282             default:
1283                 gimme_text = "UNKNOWN";
1284                 break;
1285         }
1286         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1287     }
1288     switch (CxTYPE(cx)) {
1289     case CXt_NULL:
1290     case CXt_BLOCK:
1291         break;
1292     case CXt_FORMAT:
1293         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1294                 PTR2UV(cx->blk_format.cv));
1295         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1296                 PTR2UV(cx->blk_format.gv));
1297         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1298                 PTR2UV(cx->blk_format.dfoutgv));
1299         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1300                       (int)CxHASARGS(cx));
1301         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1302                 PTR2UV(cx->blk_format.retop));
1303         break;
1304     case CXt_SUB:
1305         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1306                 PTR2UV(cx->blk_sub.cv));
1307         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1308                 (long)cx->blk_sub.olddepth);
1309         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1310                 (int)CxHASARGS(cx));
1311         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1312         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1313                 PTR2UV(cx->blk_sub.retop));
1314         break;
1315     case CXt_EVAL:
1316         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1317                 (long)CxOLD_IN_EVAL(cx));
1318         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1319                 PL_op_name[CxOLD_OP_TYPE(cx)],
1320                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1321         if (cx->blk_eval.old_namesv)
1322             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1323                           SvPVX_const(cx->blk_eval.old_namesv));
1324         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1325                 PTR2UV(cx->blk_eval.old_eval_root));
1326         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1327                 PTR2UV(cx->blk_eval.retop));
1328         break;
1329
1330     case CXt_LOOP_LAZYIV:
1331     case CXt_LOOP_LAZYSV:
1332     case CXt_LOOP_FOR:
1333     case CXt_LOOP_PLAIN:
1334         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1335         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1336                 (long)cx->blk_loop.resetsp);
1337         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1338                 PTR2UV(cx->blk_loop.my_op));
1339         /* XXX: not accurate for LAZYSV/IV */
1340         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1341                 PTR2UV(cx->blk_loop.state_u.ary.ary));
1342         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1343                 (long)cx->blk_loop.state_u.ary.ix);
1344         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1345                 PTR2UV(CxITERVAR(cx)));
1346         break;
1347
1348     case CXt_SUBST:
1349         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1350                 (long)cx->sb_iters);
1351         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1352                 (long)cx->sb_maxiters);
1353         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1354                 (long)cx->sb_rflags);
1355         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1356                 (long)CxONCE(cx));
1357         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1358                 cx->sb_orig);
1359         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1360                 PTR2UV(cx->sb_dstr));
1361         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1362                 PTR2UV(cx->sb_targ));
1363         PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1364                 PTR2UV(cx->sb_s));
1365         PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1366                 PTR2UV(cx->sb_m));
1367         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1368                 PTR2UV(cx->sb_strend));
1369         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1370                 PTR2UV(cx->sb_rxres));
1371         break;
1372     }
1373 #else
1374     PERL_UNUSED_CONTEXT;
1375     PERL_UNUSED_ARG(cx);
1376 #endif  /* DEBUGGING */
1377 }
1378
1379 /*
1380  * Local variables:
1381  * c-indentation-style: bsd
1382  * c-basic-offset: 4
1383  * indent-tabs-mode: nil
1384  * End:
1385  *
1386  * ex: set ts=8 sts=4 sw=4 et:
1387  */