scope.c

   1 /*    scope.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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
  16 /* This file contains functions to manipulate several of Perl's stacks;
  17  * in particular it contains code to push various types of things onto
  18  * the savestack, then to pop them off and perform the correct restorative
  19  * action for each one. This corresponds to the cleanup Perl does at
  20  * each scope exit.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_SCOPE_C
  25 #include "perl.h"
  26
  27 SV**
  28 Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
  29 {
  30     dVAR;
  31     PL_stack_sp = sp;
  32 #ifndef STRESS_REALLOC
  33     av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
  34 #else
  35     av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
  36 #endif
  37     return PL_stack_sp;
  38 }
  39
  40 #ifndef STRESS_REALLOC
  41 #define GROW(old) ((old) * 3 / 2)
  42 #else
  43 #define GROW(old) ((old) + 1)
  44 #endif
  45
  46 PERL_SI *
  47 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
  48 {
  49     dVAR;
  50     PERL_SI *si;
  51     Newx(si, 1, PERL_SI);
  52     si->si_stack = newAV();
  53     AvREAL_off(si->si_stack);
  54     av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
  55     AvALLOC(si->si_stack)[0] = &PL_sv_undef;
  56     AvFILLp(si->si_stack) = 0;
  57     si->si_prev = 0;
  58     si->si_next = 0;
  59     si->si_cxmax = cxitems - 1;
  60     si->si_cxix = -1;
  61     si->si_type = PERLSI_UNDEF;
  62     Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
  63     /* Without any kind of initialising PUSHSUBST()
  64      * in pp_subst() will read uninitialised heap. */
  65     PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
  66     return si;
  67 }
  68
  69 I32
  70 Perl_cxinc(pTHX)
  71 {
  72     dVAR;
  73     const IV old_max = cxstack_max;
  74     cxstack_max = GROW(cxstack_max);
  75     Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);      /* XXX should fix CXINC macro */
  76     /* Without any kind of initialising deep enough recursion
  77      * will end up reading uninitialised PERL_CONTEXTs. */
  78     PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
  79     return cxstack_ix + 1;
  80 }
  81
  82 void
  83 Perl_push_scope(pTHX)
  84 {
  85     dVAR;
  86     if (PL_scopestack_ix == PL_scopestack_max) {
  87         PL_scopestack_max = GROW(PL_scopestack_max);
  88         Renew(PL_scopestack, PL_scopestack_max, I32);
  89     }
  90     PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
  91
  92 }
  93
  94 void
  95 Perl_pop_scope(pTHX)
  96 {
  97     dVAR;
  98     const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
  99     LEAVE_SCOPE(oldsave);
 100 }
 101
 102 void
 103 Perl_markstack_grow(pTHX)
 104 {
 105     dVAR;
 106     const I32 oldmax = PL_markstack_max - PL_markstack;
 107     const I32 newmax = GROW(oldmax);
 108
 109     Renew(PL_markstack, newmax, I32);
 110     PL_markstack_ptr = PL_markstack + oldmax;
 111     PL_markstack_max = PL_markstack + newmax;
 112 }
 113
 114 void
 115 Perl_savestack_grow(pTHX)
 116 {
 117     dVAR;
 118     PL_savestack_max = GROW(PL_savestack_max) + 4;
 119     Renew(PL_savestack, PL_savestack_max, ANY);
 120 }
 121
 122 void
 123 Perl_savestack_grow_cnt(pTHX_ I32 need)
 124 {
 125     dVAR;
 126     PL_savestack_max = PL_savestack_ix + need;
 127     Renew(PL_savestack, PL_savestack_max, ANY);
 128 }
 129
 130 #undef GROW
 131
 132 void
 133 Perl_tmps_grow(pTHX_ I32 n)
 134 {
 135     dVAR;
 136 #ifndef STRESS_REALLOC
 137     if (n < 128)
 138         n = (PL_tmps_max < 512) ? 128 : 512;
 139 #endif
 140     PL_tmps_max = PL_tmps_ix + n + 1;
 141     Renew(PL_tmps_stack, PL_tmps_max, SV*);
 142 }
 143
 144
 145 void
 146 Perl_free_tmps(pTHX)
 147 {
 148     dVAR;
 149     /* XXX should tmps_floor live in cxstack? */
 150     const I32 myfloor = PL_tmps_floor;
 151     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
 152         SV* const sv = PL_tmps_stack[PL_tmps_ix];
 153         PL_tmps_stack[PL_tmps_ix--] = NULL;
 154         if (sv && sv != &PL_sv_undef) {
 155             SvTEMP_off(sv);
 156             SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
 157         }
 158     }
 159 }
 160
 161 STATIC SV *
 162 S_save_scalar_at(pTHX_ SV **sptr)
 163 {
 164     dVAR;
 165     SV * const osv = *sptr;
 166     register SV * const sv = *sptr = newSV(0);
 167
 168     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
 169         if (SvGMAGICAL(osv)) {
 170             const bool oldtainted = PL_tainted;
 171             SvFLAGS(osv) |= (SvFLAGS(osv) &
 172                (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 173             PL_tainted = oldtainted;
 174         }
 175         mg_localize(osv, sv);
 176     }
 177     return sv;
 178 }
 179
 180 SV *
 181 Perl_save_scalar(pTHX_ GV *gv)
 182 {
 183     dVAR;
 184     SV ** const sptr = &GvSVn(gv);
 185     PL_localizing = 1;
 186     SvGETMAGIC(*sptr);
 187     PL_localizing = 0;
 188     SSCHECK(3);
 189     SSPUSHPTR(SvREFCNT_inc_simple(gv));
 190     SSPUSHPTR(SvREFCNT_inc(*sptr));
 191     SSPUSHINT(SAVEt_SV);
 192     return save_scalar_at(sptr);
 193 }
 194
 195 /* Like save_sptr(), but also SvREFCNT_dec()s the new value.  Can be used to
 196  * restore a global SV to its prior contents, freeing new value. */
 197 void
 198 Perl_save_generic_svref(pTHX_ SV **sptr)
 199 {
 200     dVAR;
 201     SSCHECK(3);
 202     SSPUSHPTR(sptr);
 203     SSPUSHPTR(SvREFCNT_inc(*sptr));
 204     SSPUSHINT(SAVEt_GENERIC_SVREF);
 205 }
 206
 207 /* Like save_pptr(), but also Safefree()s the new value if it is different
 208  * from the old one.  Can be used to restore a global char* to its prior
 209  * contents, freeing new value. */
 210 void
 211 Perl_save_generic_pvref(pTHX_ char **str)
 212 {
 213     dVAR;
 214     SSCHECK(3);
 215     SSPUSHPTR(*str);
 216     SSPUSHPTR(str);
 217     SSPUSHINT(SAVEt_GENERIC_PVREF);
 218 }
 219
 220 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
 221  * Can be used to restore a shared global char* to its prior
 222  * contents, freeing new value. */
 223 void
 224 Perl_save_shared_pvref(pTHX_ char **str)
 225 {
 226     dVAR;
 227     SSCHECK(3);
 228     SSPUSHPTR(str);
 229     SSPUSHPTR(*str);
 230     SSPUSHINT(SAVEt_SHARED_PVREF);
 231 }
 232
 233 /* set the SvFLAGS specified by mask to the values in val */
 234
 235 void
 236 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
 237 {
 238     dVAR;
 239     SSCHECK(4);
 240     SSPUSHPTR(sv);
 241     SSPUSHINT(mask);
 242     SSPUSHINT(val);
 243     SSPUSHINT(SAVEt_SET_SVFLAGS);
 244 }
 245
 246 void
 247 Perl_save_gp(pTHX_ GV *gv, I32 empty)
 248 {
 249     dVAR;
 250     SSGROW(3);
 251     SSPUSHPTR(SvREFCNT_inc(gv));
 252     SSPUSHPTR(GvGP(gv));
 253     SSPUSHINT(SAVEt_GP);
 254
 255     if (empty) {
 256         GP *gp = Perl_newGP(aTHX_ gv);
 257
 258         if (GvCVu(gv))
 259             mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
 260         if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
 261             gp->gp_io = newIO();
 262             IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
 263         }
 264 #ifdef PERL_DONT_CREATE_GVSV
 265         if (gv == PL_errgv) {
 266             /* We could scatter this logic everywhere by changing the
 267                definition of ERRSV from GvSV() to GvSVn(), but it seems more
 268                efficient to do this check once here.  */
 269             gp->gp_sv = newSV(0);
 270         }
 271 #endif
 272         GvGP(gv) = gp;
 273     }
 274     else {
 275         gp_ref(GvGP(gv));
 276         GvINTRO_on(gv);
 277     }
 278 }
 279
 280 AV *
 281 Perl_save_ary(pTHX_ GV *gv)
 282 {
 283     dVAR;
 284     AV * const oav = GvAVn(gv);
 285     AV *av;
 286
 287     if (!AvREAL(oav) && AvREIFY(oav))
 288         av_reify(oav);
 289     SSCHECK(3);
 290     SSPUSHPTR(gv);
 291     SSPUSHPTR(oav);
 292     SSPUSHINT(SAVEt_AV);
 293
 294     GvAV(gv) = NULL;
 295     av = GvAVn(gv);
 296     if (SvMAGIC(oav))
 297         mg_localize((SV*)oav, (SV*)av);
 298     return av;
 299 }
 300
 301 HV *
 302 Perl_save_hash(pTHX_ GV *gv)
 303 {
 304     dVAR;
 305     HV *ohv, *hv;
 306
 307     SSCHECK(3);
 308     SSPUSHPTR(gv);
 309     SSPUSHPTR(ohv = GvHVn(gv));
 310     SSPUSHINT(SAVEt_HV);
 311
 312     GvHV(gv) = NULL;
 313     hv = GvHVn(gv);
 314     if (SvMAGIC(ohv))
 315         mg_localize((SV*)ohv, (SV*)hv);
 316     return hv;
 317 }
 318
 319 void
 320 Perl_save_item(pTHX_ register SV *item)
 321 {
 322     dVAR;
 323     register SV * const sv = newSVsv(item);
 324
 325     SSCHECK(3);
 326     SSPUSHPTR(item);            /* remember the pointer */
 327     SSPUSHPTR(sv);              /* remember the value */
 328     SSPUSHINT(SAVEt_ITEM);
 329 }
 330
 331 void
 332 Perl_save_int(pTHX_ int *intp)
 333 {
 334     dVAR;
 335     SSCHECK(3);
 336     SSPUSHINT(*intp);
 337     SSPUSHPTR(intp);
 338     SSPUSHINT(SAVEt_INT);
 339 }
 340
 341 void
 342 Perl_save_bool(pTHX_ bool *boolp)
 343 {
 344     dVAR;
 345     SSCHECK(3);
 346     SSPUSHBOOL(*boolp);
 347     SSPUSHPTR(boolp);
 348     SSPUSHINT(SAVEt_BOOL);
 349 }
 350
 351 void
 352 Perl_save_I8(pTHX_ I8 *bytep)
 353 {
 354     dVAR;
 355     SSCHECK(3);
 356     SSPUSHINT(*bytep);
 357     SSPUSHPTR(bytep);
 358     SSPUSHINT(SAVEt_I8);
 359 }
 360
 361 void
 362 Perl_save_I16(pTHX_ I16 *intp)
 363 {
 364     dVAR;
 365     SSCHECK(3);
 366     SSPUSHINT(*intp);
 367     SSPUSHPTR(intp);
 368     SSPUSHINT(SAVEt_I16);
 369 }
 370
 371 void
 372 Perl_save_I32(pTHX_ I32 *intp)
 373 {
 374     dVAR;
 375     SSCHECK(3);
 376     SSPUSHINT(*intp);
 377     SSPUSHPTR(intp);
 378     SSPUSHINT(SAVEt_I32);
 379 }
 380
 381 /* Cannot use save_sptr() to store a char* since the SV** cast will
 382  * force word-alignment and we'll miss the pointer.
 383  */
 384 void
 385 Perl_save_pptr(pTHX_ char **pptr)
 386 {
 387     dVAR;
 388     SSCHECK(3);
 389     SSPUSHPTR(*pptr);
 390     SSPUSHPTR(pptr);
 391     SSPUSHINT(SAVEt_PPTR);
 392 }
 393
 394 void
 395 Perl_save_vptr(pTHX_ void *ptr)
 396 {
 397     dVAR;
 398     SSCHECK(3);
 399     SSPUSHPTR(*(char**)ptr);
 400     SSPUSHPTR(ptr);
 401     SSPUSHINT(SAVEt_VPTR);
 402 }
 403
 404 void
 405 Perl_save_sptr(pTHX_ SV **sptr)
 406 {
 407     dVAR;
 408     SSCHECK(3);
 409     SSPUSHPTR(*sptr);
 410     SSPUSHPTR(sptr);
 411     SSPUSHINT(SAVEt_SPTR);
 412 }
 413
 414 void
 415 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
 416 {
 417     dVAR;
 418     SSCHECK(4);
 419     ASSERT_CURPAD_ACTIVE("save_padsv");
 420     SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
 421     SSPUSHPTR(PL_comppad);
 422     SSPUSHLONG((long)off);
 423     SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE);
 424 }
 425
 426 void
 427 Perl_save_hptr(pTHX_ HV **hptr)
 428 {
 429     dVAR;
 430     SSCHECK(3);
 431     SSPUSHPTR(*hptr);
 432     SSPUSHPTR(hptr);
 433     SSPUSHINT(SAVEt_HPTR);
 434 }
 435
 436 void
 437 Perl_save_aptr(pTHX_ AV **aptr)
 438 {
 439     dVAR;
 440     SSCHECK(3);
 441     SSPUSHPTR(*aptr);
 442     SSPUSHPTR(aptr);
 443     SSPUSHINT(SAVEt_APTR);
 444 }
 445
 446 void
 447 Perl_save_freesv(pTHX_ SV *sv)
 448 {
 449     dVAR;
 450     SSCHECK(2);
 451     SSPUSHPTR(sv);
 452     SSPUSHINT(SAVEt_FREESV);
 453 }
 454
 455 void
 456 Perl_save_mortalizesv(pTHX_ SV *sv)
 457 {
 458     dVAR;
 459     SSCHECK(2);
 460     SSPUSHPTR(sv);
 461     SSPUSHINT(SAVEt_MORTALIZESV);
 462 }
 463
 464 void
 465 Perl_save_freeop(pTHX_ OP *o)
 466 {
 467     dVAR;
 468     SSCHECK(2);
 469     SSPUSHPTR(o);
 470     SSPUSHINT(SAVEt_FREEOP);
 471 }
 472
 473 void
 474 Perl_save_freepv(pTHX_ char *pv)
 475 {
 476     dVAR;
 477     SSCHECK(2);
 478     SSPUSHPTR(pv);
 479     SSPUSHINT(SAVEt_FREEPV);
 480 }
 481
 482 void
 483 Perl_save_clearsv(pTHX_ SV **svp)
 484 {
 485     dVAR;
 486     ASSERT_CURPAD_ACTIVE("save_clearsv");
 487     SSCHECK(2);
 488     SSPUSHLONG((long)(svp-PL_curpad));
 489     SSPUSHINT(SAVEt_CLEARSV);
 490     SvPADSTALE_off(*svp); /* mark lexical as active */
 491 }
 492
 493 void
 494 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 495 {
 496     dVAR;
 497     SSCHECK(4);
 498     SSPUSHINT(klen);
 499     SSPUSHPTR(key);
 500     SSPUSHPTR(SvREFCNT_inc_simple(hv));
 501     SSPUSHINT(SAVEt_DELETE);
 502 }
 503
 504 void
 505 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 506 {
 507     dVAR;
 508     SSCHECK(3);
 509     SSPUSHDPTR(f);
 510     SSPUSHPTR(p);
 511     SSPUSHINT(SAVEt_DESTRUCTOR);
 512 }
 513
 514 void
 515 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 516 {
 517     dVAR;
 518     SSCHECK(3);
 519     SSPUSHDXPTR(f);
 520     SSPUSHPTR(p);
 521     SSPUSHINT(SAVEt_DESTRUCTOR_X);
 522 }
 523
 524 void
 525 Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
 526 {
 527     dVAR;
 528     SV *sv;
 529     SvGETMAGIC(*sptr);
 530     SSCHECK(4);
 531     SSPUSHPTR(SvREFCNT_inc_simple(av));
 532     SSPUSHINT(idx);
 533     SSPUSHPTR(SvREFCNT_inc(*sptr));
 534     SSPUSHINT(SAVEt_AELEM);
 535     /* if it gets reified later, the restore will have the wrong refcnt */
 536     if (!AvREAL(av) && AvREIFY(av))
 537         SvREFCNT_inc_void(*sptr);
 538     save_scalar_at(sptr);
 539     sv = *sptr;
 540     /* If we're localizing a tied array element, this new sv
 541      * won't actually be stored in the array - so it won't get
 542      * reaped when the localize ends. Ensure it gets reaped by
 543      * mortifying it instead. DAPM */
 544     if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
 545         sv_2mortal(sv);
 546 }
 547
 548 void
 549 Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
 550 {
 551     dVAR;
 552     SV *sv;
 553     SvGETMAGIC(*sptr);
 554     SSCHECK(4);
 555     SSPUSHPTR(SvREFCNT_inc_simple(hv));
 556     SSPUSHPTR(newSVsv(key));
 557     SSPUSHPTR(SvREFCNT_inc(*sptr));
 558     SSPUSHINT(SAVEt_HELEM);
 559     save_scalar_at(sptr);
 560     sv = *sptr;
 561     /* If we're localizing a tied hash element, this new sv
 562      * won't actually be stored in the hash - so it won't get
 563      * reaped when the localize ends. Ensure it gets reaped by
 564      * mortifying it instead. DAPM */
 565     if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
 566         sv_2mortal(sv);
 567 }
 568
 569 SV*
 570 Perl_save_svref(pTHX_ SV **sptr)
 571 {
 572     dVAR;
 573     SvGETMAGIC(*sptr);
 574     SSCHECK(3);
 575     SSPUSHPTR(sptr);
 576     SSPUSHPTR(SvREFCNT_inc(*sptr));
 577     SSPUSHINT(SAVEt_SVREF);
 578     return save_scalar_at(sptr);
 579 }
 580
 581 void
 582 Perl_save_op(pTHX)
 583 {
 584     dVAR;
 585     SSCHECK(2);
 586     SSPUSHPTR(PL_op);
 587     SSPUSHINT(SAVEt_OP);
 588 }
 589
 590 I32
 591 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 592 {
 593     dVAR;
 594     register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
 595                                 - (char*)PL_savestack);
 596     register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
 597
 598     SSGROW(elems + 2);
 599
 600     PL_savestack_ix += elems;
 601     SSPUSHINT(elems);
 602     SSPUSHINT(SAVEt_ALLOC);
 603     return start;
 604 }
 605
 606 void
 607 Perl_leave_scope(pTHX_ I32 base)
 608 {
 609     dVAR;
 610     register SV *sv;
 611     register SV *value;
 612     register GV *gv;
 613     register AV *av;
 614     register HV *hv;
 615     void* ptr;
 616     register char* str;
 617     I32 i;
 618
 619     if (base < -1)
 620         Perl_croak(aTHX_ "panic: corrupt saved stack index");
 621     while (PL_savestack_ix > base) {
 622         switch (SSPOPINT) {
 623         case SAVEt_ITEM:                        /* normal string */
 624             value = (SV*)SSPOPPTR;
 625             sv = (SV*)SSPOPPTR;
 626             sv_replace(sv,value);
 627             PL_localizing = 2;
 628             SvSETMAGIC(sv);
 629             PL_localizing = 0;
 630             break;
 631         case SAVEt_SV:                          /* scalar reference */
 632             value = (SV*)SSPOPPTR;
 633             gv = (GV*)SSPOPPTR;
 634             ptr = &GvSV(gv);
 635             av = (AV*)gv; /* what to refcnt_dec */
 636         restore_sv:
 637             sv = *(SV**)ptr;
 638             DEBUG_S(PerlIO_printf(Perl_debug_log,
 639                                   "restore svref: %p %p:%s -> %p:%s\n",
 640                                   (void*)ptr, (void*)sv, SvPEEK(sv),
 641                                   (void*)value, SvPEEK(value)));
 642             *(SV**)ptr = value;
 643             SvREFCNT_dec(sv);
 644             PL_localizing = 2;
 645             SvSETMAGIC(value);
 646             PL_localizing = 0;
 647             SvREFCNT_dec(value);
 648             if (av) /* actually an av, hv or gv */
 649                 SvREFCNT_dec(av);
 650             break;
 651         case SAVEt_GENERIC_PVREF:               /* generic pv */
 652             ptr = SSPOPPTR;
 653             str = (char*)SSPOPPTR;
 654             if (*(char**)ptr != str) {
 655                 Safefree(*(char**)ptr);
 656                 *(char**)ptr = str;
 657             }
 658             break;
 659         case SAVEt_SHARED_PVREF:                /* shared pv */
 660             str = (char*)SSPOPPTR;
 661             ptr = SSPOPPTR;
 662             if (*(char**)ptr != str) {
 663 #ifdef NETWARE
 664                 PerlMem_free(*(char**)ptr);
 665 #else
 666                 PerlMemShared_free(*(char**)ptr);
 667 #endif
 668                 *(char**)ptr = str;
 669             }
 670             break;
 671         case SAVEt_GENERIC_SVREF:               /* generic sv */
 672             value = (SV*)SSPOPPTR;
 673             ptr = SSPOPPTR;
 674             sv = *(SV**)ptr;
 675             *(SV**)ptr = value;
 676             SvREFCNT_dec(sv);
 677             SvREFCNT_dec(value);
 678             break;
 679         case SAVEt_AV:                          /* array reference */
 680             av = (AV*)SSPOPPTR;
 681             gv = (GV*)SSPOPPTR;
 682             if (GvAV(gv)) {
 683                 SvREFCNT_dec(GvAV(gv));
 684             }
 685             GvAV(gv) = av;
 686             if (SvMAGICAL(av)) {
 687                 PL_localizing = 2;
 688                 SvSETMAGIC((SV*)av);
 689                 PL_localizing = 0;
 690             }
 691             break;
 692         case SAVEt_HV:                          /* hash reference */
 693             hv = (HV*)SSPOPPTR;
 694             gv = (GV*)SSPOPPTR;
 695             if (GvHV(gv)) {
 696                 SvREFCNT_dec(GvHV(gv));
 697             }
 698             GvHV(gv) = hv;
 699             if (SvMAGICAL(hv)) {
 700                 PL_localizing = 2;
 701                 SvSETMAGIC((SV*)hv);
 702                 PL_localizing = 0;
 703             }
 704             break;
 705         case SAVEt_INT:                         /* int reference */
 706             ptr = SSPOPPTR;
 707             *(int*)ptr = (int)SSPOPINT;
 708             break;
 709         case SAVEt_BOOL:                        /* bool reference */
 710             ptr = SSPOPPTR;
 711             *(bool*)ptr = (bool)SSPOPBOOL;
 712             break;
 713         case SAVEt_I32:                         /* I32 reference */
 714             ptr = SSPOPPTR;
 715 #ifdef PERL_DEBUG_READONLY_OPS
 716             {
 717                 const I32 val = SSPOPINT;
 718                 if (*(I32*)ptr != val)
 719                     *(I32*)ptr = val;
 720             }
 721 #else
 722             *(I32*)ptr = (I32)SSPOPINT;
 723 #endif
 724             break;
 725         case SAVEt_SPTR:                        /* SV* reference */
 726             ptr = SSPOPPTR;
 727             *(SV**)ptr = (SV*)SSPOPPTR;
 728             break;
 729         case SAVEt_VPTR:                        /* random* reference */
 730         case SAVEt_PPTR:                        /* char* reference */
 731             ptr = SSPOPPTR;
 732             *(char**)ptr = (char*)SSPOPPTR;
 733             break;
 734         case SAVEt_HPTR:                        /* HV* reference */
 735             ptr = SSPOPPTR;
 736             *(HV**)ptr = (HV*)SSPOPPTR;
 737             break;
 738         case SAVEt_APTR:                        /* AV* reference */
 739             ptr = SSPOPPTR;
 740             *(AV**)ptr = (AV*)SSPOPPTR;
 741             break;
 742         case SAVEt_GP:                          /* scalar reference */
 743             ptr = SSPOPPTR;
 744             gv = (GV*)SSPOPPTR;
 745             gp_free(gv);
 746             GvGP(gv) = (GP*)ptr;
 747             /* putting a method back into circulation ("local")*/
 748             if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
 749                 mro_method_changed_in(hv);
 750             SvREFCNT_dec(gv);
 751             break;
 752         case SAVEt_FREESV:
 753             ptr = SSPOPPTR;
 754             SvREFCNT_dec((SV*)ptr);
 755             break;
 756         case SAVEt_MORTALIZESV:
 757             ptr = SSPOPPTR;
 758             sv_2mortal((SV*)ptr);
 759             break;
 760         case SAVEt_FREEOP:
 761             ptr = SSPOPPTR;
 762             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
 763             op_free((OP*)ptr);
 764             break;
 765         case SAVEt_FREEPV:
 766             ptr = SSPOPPTR;
 767             Safefree(ptr);
 768             break;
 769         case SAVEt_CLEARSV:
 770             ptr = (void*)&PL_curpad[SSPOPLONG];
 771             sv = *(SV**)ptr;
 772
 773             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 774              "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
 775                 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
 776                 (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
 777                 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
 778             ));
 779
 780             /* Can clear pad variable in place? */
 781             if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
 782                 /*
 783                  * if a my variable that was made readonly is going out of
 784                  * scope, we want to remove the readonlyness so that it can
 785                  * go out of scope quietly
 786                  */
 787                 if (SvPADMY(sv) && !SvFAKE(sv))
 788                     SvREADONLY_off(sv);
 789
 790                 if (SvTHINKFIRST(sv))
 791                     sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
 792                 if (SvMAGICAL(sv))
 793                     mg_free(sv);
 794
 795                 switch (SvTYPE(sv)) {
 796                 case SVt_NULL:
 797                     break;
 798                 case SVt_PVAV:
 799                     av_clear((AV*)sv);
 800                     break;
 801                 case SVt_PVHV:
 802                     hv_clear((HV*)sv);
 803                     break;
 804                 case SVt_PVCV:
 805                     Perl_croak(aTHX_ "panic: leave_scope pad code");
 806                 default:
 807                     SvOK_off(sv);
 808                     break;
 809                 }
 810                 SvPADSTALE_on(sv); /* mark as no longer live */
 811             }
 812             else {      /* Someone has a claim on this, so abandon it. */
 813                 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
 814                 switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
 815                 case SVt_PVAV:  *(SV**)ptr = (SV*)newAV();      break;
 816                 case SVt_PVHV:  *(SV**)ptr = (SV*)newHV();      break;
 817                 default:        *(SV**)ptr = newSV(0);          break;
 818                 }
 819                 SvREFCNT_dec(sv);       /* Cast current value to the winds. */
 820                 /* preserve pad nature, but also mark as not live
 821                  * for any closure capturing */
 822                 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
 823             }
 824             break;
 825         case SAVEt_DELETE:
 826             ptr = SSPOPPTR;
 827             hv = (HV*)ptr;
 828             ptr = SSPOPPTR;
 829             (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
 830             SvREFCNT_dec(hv);
 831             Safefree(ptr);
 832             break;
 833         case SAVEt_DESTRUCTOR_X:
 834             ptr = SSPOPPTR;
 835             (*SSPOPDXPTR)(aTHX_ ptr);
 836             break;
 837         case SAVEt_REGCONTEXT:
 838         case SAVEt_ALLOC:
 839             i = SSPOPINT;
 840             PL_savestack_ix -= i;       /* regexp must have croaked */
 841             break;
 842         case SAVEt_STACK_POS:           /* Position on Perl stack */
 843             i = SSPOPINT;
 844             PL_stack_sp = PL_stack_base + i;
 845             break;
 846         case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
 847             i = SSPOPINT;
 848             cxstack[i].blk_oldsp = SSPOPINT;
 849             break;
 850         case SAVEt_AELEM:               /* array element */
 851             value = (SV*)SSPOPPTR;
 852             i = SSPOPINT;
 853             av = (AV*)SSPOPPTR;
 854             ptr = av_fetch(av,i,1);
 855             if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
 856                 SvREFCNT_dec(value);
 857             if (ptr) {
 858                 sv = *(SV**)ptr;
 859                 if (sv && sv != &PL_sv_undef) {
 860                     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 861                         SvREFCNT_inc_void_NN(sv);
 862                     goto restore_sv;
 863                 }
 864             }
 865             SvREFCNT_dec(av);
 866             SvREFCNT_dec(value);
 867             break;
 868         case SAVEt_HELEM:               /* hash element */
 869             value = (SV*)SSPOPPTR;
 870             sv = (SV*)SSPOPPTR;
 871             hv = (HV*)SSPOPPTR;
 872             ptr = hv_fetch_ent(hv, sv, 1, 0);
 873             if (ptr) {
 874                 const SV * const oval = HeVAL((HE*)ptr);
 875                 if (oval && oval != &PL_sv_undef) {
 876                     ptr = &HeVAL((HE*)ptr);
 877                     if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
 878                         SvREFCNT_inc_void(*(SV**)ptr);
 879                     SvREFCNT_dec(sv);
 880                     av = (AV*)hv; /* what to refcnt_dec */
 881                     goto restore_sv;
 882                 }
 883             }
 884             SvREFCNT_dec(hv);
 885             SvREFCNT_dec(sv);
 886             SvREFCNT_dec(value);
 887             break;
 888         case SAVEt_OP:
 889             PL_op = (OP*)SSPOPPTR;
 890             break;
 891         case SAVEt_HINTS:
 892             if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
 893                 SvREFCNT_dec((SV*)GvHV(PL_hintgv));
 894                 GvHV(PL_hintgv) = NULL;
 895             }
 896             *(I32*)&PL_hints = (I32)SSPOPINT;
 897             Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
 898             PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR;
 899             if (PL_hints & HINT_LOCALIZE_HH) {
 900                 SvREFCNT_dec((SV*)GvHV(PL_hintgv));
 901                 GvHV(PL_hintgv) = (HV*)SSPOPPTR;
 902                 assert(GvHV(PL_hintgv));
 903             } else if (!GvHV(PL_hintgv)) {
 904                 /* Need to add a new one manually, else gv_fetchpv() can
 905                    add one in this code:
 906
 907                    if (SvTYPE(gv) == SVt_PVGV) {
 908                        if (add) {
 909                        GvMULTI_on(gv);
 910                        gv_init_sv(gv, sv_type);
 911                        if (*name=='!' && sv_type == SVt_PVHV && len==1)
 912                            require_errno(gv);
 913                        }
 914                        return gv;
 915                    }
 916
 917                    and it won't have the magic set.  */
 918
 919                 HV *const hv = newHV();
 920                 hv_magic(hv, NULL, PERL_MAGIC_hints);
 921                 GvHV(PL_hintgv) = hv;
 922             }
 923             assert(GvHV(PL_hintgv));
 924             break;
 925         case SAVEt_COMPPAD:
 926             PL_comppad = (PAD*)SSPOPPTR;
 927             if (PL_comppad)
 928                 PL_curpad = AvARRAY(PL_comppad);
 929             else
 930                 PL_curpad = NULL;
 931             break;
 932         case SAVEt_PADSV_AND_MORTALIZE:
 933             {
 934                 const PADOFFSET off = (PADOFFSET)SSPOPLONG;
 935                 SV **svp;
 936                 ptr = SSPOPPTR;
 937                 assert (ptr);
 938                 svp = AvARRAY((PAD*)ptr) + off;
 939                 /* This mortalizing used to be done by POPLOOP() via itersave.
 940                    But as we have all the information here, we can do it here,
 941                    save even having to have itersave in the struct.  */
 942                 sv_2mortal(*svp);
 943                 *svp = (SV*)SSPOPPTR;
 944             }
 945             break;
 946         case SAVEt_SAVESWITCHSTACK:
 947             {
 948                 dSP;
 949                 AV* const t = (AV*)SSPOPPTR;
 950                 AV* const f = (AV*)SSPOPPTR;
 951                 SWITCHSTACK(t,f);
 952                 PL_curstackinfo->si_stack = f;
 953             }
 954             break;
 955         case SAVEt_SET_SVFLAGS:
 956             {
 957                 const U32 val  = (U32)SSPOPINT;
 958                 const U32 mask = (U32)SSPOPINT;
 959                 sv = (SV*)SSPOPPTR;
 960                 SvFLAGS(sv) &= ~mask;
 961                 SvFLAGS(sv) |= val;
 962             }
 963             break;
 964             /* These are only saved in mathoms.c */
 965         case SAVEt_SVREF:                       /* scalar reference */
 966             value = (SV*)SSPOPPTR;
 967             ptr = SSPOPPTR;
 968             av = NULL; /* what to refcnt_dec */
 969             goto restore_sv;
 970         case SAVEt_LONG:                        /* long reference */
 971             ptr = SSPOPPTR;
 972             *(long*)ptr = (long)SSPOPLONG;
 973             break;
 974         case SAVEt_I16:                         /* I16 reference */
 975             ptr = SSPOPPTR;
 976             *(I16*)ptr = (I16)SSPOPINT;
 977             break;
 978         case SAVEt_I8:                          /* I8 reference */
 979             ptr = SSPOPPTR;
 980             *(I8*)ptr = (I8)SSPOPINT;
 981             break;
 982         case SAVEt_IV:                          /* IV reference */
 983             ptr = SSPOPPTR;
 984             *(IV*)ptr = (IV)SSPOPIV;
 985             break;
 986         case SAVEt_NSTAB:
 987             gv = (GV*)SSPOPPTR;
 988             (void)sv_clear((SV*)gv);
 989             break;
 990         case SAVEt_DESTRUCTOR:
 991             ptr = SSPOPPTR;
 992             (*SSPOPDPTR)(ptr);
 993             break;
 994         case SAVEt_COP_ARYBASE:
 995             ptr = SSPOPPTR;
 996             i = SSPOPINT;
 997             CopARYBASE_set((COP *)ptr, i);
 998             break;
 999         case SAVEt_COMPILE_WARNINGS:
1000             ptr = SSPOPPTR;
1001
1002             if (!specialWARN(PL_compiling.cop_warnings))
1003                 PerlMemShared_free(PL_compiling.cop_warnings);
1004
1005             PL_compiling.cop_warnings = (STRLEN*)ptr;
1006             break;
1007         case SAVEt_RE_STATE:
1008             {
1009                 const struct re_save_state *const state
1010                     = (struct re_save_state *)
1011                     (PL_savestack + PL_savestack_ix
1012                      - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
1013                 PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
1014
1015                 if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
1016                     Safefree(PL_reg_start_tmp);
1017                 }
1018                 if (PL_reg_poscache != state->re_state_reg_poscache) {
1019                     Safefree(PL_reg_poscache);
1020                 }
1021                 Copy(state, &PL_reg_state, 1, struct re_save_state);
1022             }
1023             break;
1024         case SAVEt_PARSER:
1025             ptr = SSPOPPTR;
1026             parser_free((yy_parser *) ptr);
1027             break;
1028         default:
1029             Perl_croak(aTHX_ "panic: leave_scope inconsistency");
1030         }
1031     }
1032 }
1033
1034 void
1035 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1036 {
1037     dVAR;
1038 #ifdef DEBUGGING
1039     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1040     if (CxTYPE(cx) != CXt_SUBST) {
1041         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1042         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1043                       PTR2UV(cx->blk_oldcop));
1044         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1045         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1046         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1047                       PTR2UV(cx->blk_oldpm));
1048         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
1049     }
1050     switch (CxTYPE(cx)) {
1051     case CXt_NULL:
1052     case CXt_BLOCK:
1053         break;
1054     case CXt_FORMAT:
1055         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1056                 PTR2UV(cx->blk_format.cv));
1057         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1058                 PTR2UV(cx->blk_format.gv));
1059         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1060                 PTR2UV(cx->blk_format.dfoutgv));
1061         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1062                       (int)CxHASARGS(cx));
1063         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1064                 PTR2UV(cx->blk_format.retop));
1065         break;
1066     case CXt_SUB:
1067         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1068                 PTR2UV(cx->blk_sub.cv));
1069         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1070                 (long)cx->blk_sub.olddepth);
1071         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1072                 (int)CxHASARGS(cx));
1073         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1074         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1075                 PTR2UV(cx->blk_sub.retop));
1076         break;
1077     case CXt_EVAL:
1078         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1079                 (long)CxOLD_IN_EVAL(cx));
1080         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1081                 PL_op_name[CxOLD_OP_TYPE(cx)],
1082                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1083         if (cx->blk_eval.old_namesv)
1084             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1085                           SvPVX_const(cx->blk_eval.old_namesv));
1086         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1087                 PTR2UV(cx->blk_eval.old_eval_root));
1088         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1089                 PTR2UV(cx->blk_eval.retop));
1090         break;
1091
1092     case CXt_LOOP_LAZYIV:
1093     case CXt_LOOP_LAZYSV:
1094     case CXt_LOOP_FOR:
1095     case CXt_LOOP_PLAIN:
1096         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1097         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1098                 (long)cx->blk_loop.resetsp);
1099         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1100                 PTR2UV(cx->blk_loop.my_op));
1101         PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
1102                 PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
1103         /* XXX: not accurate for LAZYSV/IV */
1104         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1105                 PTR2UV(cx->blk_loop.state_u.ary.ary));
1106         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1107                 (long)cx->blk_loop.state_u.ary.ix);
1108         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1109                 PTR2UV(CxITERVAR(cx)));
1110         break;
1111
1112     case CXt_SUBST:
1113         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1114                 (long)cx->sb_iters);
1115         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1116                 (long)cx->sb_maxiters);
1117         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1118                 (long)cx->sb_rflags);
1119         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1120                 (long)CxONCE(cx));
1121         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1122                 cx->sb_orig);
1123         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1124                 PTR2UV(cx->sb_dstr));
1125         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1126                 PTR2UV(cx->sb_targ));
1127         PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1128                 PTR2UV(cx->sb_s));
1129         PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1130                 PTR2UV(cx->sb_m));
1131         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1132                 PTR2UV(cx->sb_strend));
1133         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1134                 PTR2UV(cx->sb_rxres));
1135         break;
1136     }
1137 #else
1138     PERL_UNUSED_CONTEXT;
1139     PERL_UNUSED_ARG(cx);
1140 #endif  /* DEBUGGING */
1141 }
1142
1143 /*
1144  * Local variables:
1145  * c-indentation-style: bsd
1146  * c-basic-offset: 4
1147  * indent-tabs-mode: t
1148  * End:
1149  *
1150  * ex: set ts=8 sts=4 sw=4 noet:
1151  */