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