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