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