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