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