scope.c

   1 /*    scope.c
   2  *
   3  *    Copyright (c) 1991-1997, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "For the fashion of Minas Tirith was such that it was built on seven
  12  * levels..."
  13  */
  14
  15 #include "EXTERN.h"
  16 #include "perl.h"
  17
  18 static void setjmp_tryblock _((CPERLarg_ TRYVTBL *vtbl, void *locals));
  19
  20 void
  21 install_tryblock_method(tryblock_f fn)
  22 {
  23     if (fn)
  24         tryblock_function = fn;
  25     else
  26         tryblock_function = setjmp_tryblock;
  27 }
  28
  29 SV**
  30 stack_grow(SV **sp, SV **p, int n)
  31 {
  32     dTHR;
  33 #if defined(DEBUGGING) && !defined(USE_THREADS)
  34     static int growing = 0;
  35     if (growing++)
  36       abort();
  37 #endif
  38     stack_sp = sp;
  39 #ifndef STRESS_REALLOC
  40     av_extend(curstack, (p - stack_base) + (n) + 128);
  41 #else
  42     av_extend(curstack, (p - stack_base) + (n) + 1);
  43 #endif
  44 #if defined(DEBUGGING) && !defined(USE_THREADS)
  45     growing--;
  46 #endif
  47     return stack_sp;
  48 }
  49
  50 #ifndef STRESS_REALLOC
  51 #define GROW(old) ((old) * 3 / 2)
  52 #else
  53 #define GROW(old) ((old) + 1)
  54 #endif
  55
  56 PERL_SI *
  57 new_stackinfo(I32 stitems, I32 cxitems)
  58 {
  59     PERL_SI *si;
  60     PERL_CONTEXT *cxt;
  61     New(56, si, 1, PERL_SI);
  62     si->si_stack = newAV();
  63     AvREAL_off(si->si_stack);
  64     av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
  65     AvALLOC(si->si_stack)[0] = &sv_undef;
  66     AvFILLp(si->si_stack) = 0;
  67     si->si_prev = 0;
  68     si->si_next = 0;
  69     si->si_cxmax = cxitems - 1;
  70     si->si_cxix = -1;
  71     si->si_type = SI_UNDEF;
  72     New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
  73     return si;
  74 }
  75
  76 I32
  77 cxinc(void)
  78 {
  79     dTHR;
  80     cxstack_max = GROW(cxstack_max);
  81     Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);      /* XXX should fix CXINC macro */
  82     return cxstack_ix + 1;
  83 }
  84
  85 void
  86 push_return(OP *retop)
  87 {
  88     dTHR;
  89     if (retstack_ix == retstack_max) {
  90         retstack_max = GROW(retstack_max);
  91         Renew(retstack, retstack_max, OP*);
  92     }
  93     retstack[retstack_ix++] = retop;
  94 }
  95
  96 OP *
  97 pop_return(void)
  98 {
  99     dTHR;
 100     if (retstack_ix > 0)
 101         return retstack[--retstack_ix];
 102     else
 103         return Nullop;
 104 }
 105
 106 void
 107 push_scope(void)
 108 {
 109     dTHR;
 110     if (scopestack_ix == scopestack_max) {
 111         scopestack_max = GROW(scopestack_max);
 112         Renew(scopestack, scopestack_max, I32);
 113     }
 114     scopestack[scopestack_ix++] = savestack_ix;
 115
 116 }
 117
 118 void
 119 pop_scope(void)
 120 {
 121     dTHR;
 122     I32 oldsave = scopestack[--scopestack_ix];
 123     LEAVE_SCOPE(oldsave);
 124 }
 125
 126 void
 127 markstack_grow(void)
 128 {
 129     dTHR;
 130     I32 oldmax = markstack_max - markstack;
 131     I32 newmax = GROW(oldmax);
 132
 133     Renew(markstack, newmax, I32);
 134     markstack_ptr = markstack + oldmax;
 135     markstack_max = markstack + newmax;
 136 }
 137
 138 void
 139 savestack_grow(void)
 140 {
 141     dTHR;
 142     savestack_max = GROW(savestack_max) + 4;
 143     Renew(savestack, savestack_max, ANY);
 144 }
 145
 146 #undef GROW
 147
 148 void
 149 free_tmps(void)
 150 {
 151     dTHR;
 152     /* XXX should tmps_floor live in cxstack? */
 153     I32 myfloor = tmps_floor;
 154     while (tmps_ix > myfloor) {      /* clean up after last statement */
 155         SV* sv = tmps_stack[tmps_ix];
 156         tmps_stack[tmps_ix--] = Nullsv;
 157         if (sv) {
 158 #ifdef DEBUGGING
 159             SvTEMP_off(sv);
 160 #endif
 161             SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
 162         }
 163     }
 164 }
 165
 166 STATIC SV *
 167 save_scalar_at(SV **sptr)
 168 {
 169     dTHR;
 170     register SV *sv;
 171     SV *osv = *sptr;
 172
 173     sv = *sptr = NEWSV(0,0);
 174     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
 175         sv_upgrade(sv, SvTYPE(osv));
 176         if (SvGMAGICAL(osv)) {
 177             MAGIC* mg;
 178             bool oldtainted = tainted;
 179             mg_get(osv);
 180             if (tainting && tainted && (mg = mg_find(osv, 't'))) {
 181                 SAVESPTR(mg->mg_obj);
 182                 mg->mg_obj = osv;
 183             }
 184             SvFLAGS(osv) |= (SvFLAGS(osv) &
 185                 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 186             tainted = oldtainted;
 187         }
 188         SvMAGIC(sv) = SvMAGIC(osv);
 189         SvFLAGS(sv) |= SvMAGICAL(osv);
 190         localizing = 1;
 191         SvSETMAGIC(sv);
 192         localizing = 0;
 193     }
 194     return sv;
 195 }
 196
 197 SV *
 198 save_scalar(GV *gv)
 199 {
 200     dTHR;
 201     SV **sptr = &GvSV(gv);
 202     SSCHECK(3);
 203     SSPUSHPTR(SvREFCNT_inc(gv));
 204     SSPUSHPTR(SvREFCNT_inc(*sptr));
 205     SSPUSHINT(SAVEt_SV);
 206     return save_scalar_at(sptr);
 207 }
 208
 209 SV*
 210 save_svref(SV **sptr)
 211 {
 212     dTHR;
 213     SSCHECK(3);
 214     SSPUSHPTR(sptr);
 215     SSPUSHPTR(SvREFCNT_inc(*sptr));
 216     SSPUSHINT(SAVEt_SVREF);
 217     return save_scalar_at(sptr);
 218 }
 219
 220 void
 221 save_gp(GV *gv, I32 empty)
 222 {
 223     dTHR;
 224     SSCHECK(6);
 225     SSPUSHIV((IV)SvLEN(gv));
 226     SvLEN(gv) = 0; /* forget that anything was allocated here */
 227     SSPUSHIV((IV)SvCUR(gv));
 228     SSPUSHPTR(SvPVX(gv));
 229     SvPOK_off(gv);
 230     SSPUSHPTR(SvREFCNT_inc(gv));
 231     SSPUSHPTR(GvGP(gv));
 232     SSPUSHINT(SAVEt_GP);
 233
 234     if (empty) {
 235         register GP *gp;
 236
 237         if (GvCVu(gv))
 238             sub_generation++;   /* taking a method out of circulation */
 239         Newz(602, gp, 1, GP);
 240         GvGP(gv) = gp_ref(gp);
 241         GvSV(gv) = NEWSV(72,0);
 242         GvLINE(gv) = curcop->cop_line;
 243         GvEGV(gv) = gv;
 244     }
 245     else {
 246         gp_ref(GvGP(gv));
 247         GvINTRO_on(gv);
 248     }
 249 }
 250
 251 AV *
 252 save_ary(GV *gv)
 253 {
 254     dTHR;
 255     AV *oav = GvAVn(gv);
 256     AV *av;
 257
 258     if (!AvREAL(oav) && AvREIFY(oav))
 259         av_reify(oav);
 260     SSCHECK(3);
 261     SSPUSHPTR(gv);
 262     SSPUSHPTR(oav);
 263     SSPUSHINT(SAVEt_AV);
 264
 265     GvAV(gv) = Null(AV*);
 266     av = GvAVn(gv);
 267     if (SvMAGIC(oav)) {
 268         SvMAGIC(av) = SvMAGIC(oav);
 269         SvFLAGS(av) |= SvMAGICAL(oav);
 270         SvMAGICAL_off(oav);
 271         SvMAGIC(oav) = 0;
 272         localizing = 1;
 273         SvSETMAGIC((SV*)av);
 274         localizing = 0;
 275     }
 276     return av;
 277 }
 278
 279 HV *
 280 save_hash(GV *gv)
 281 {
 282     dTHR;
 283     HV *ohv, *hv;
 284
 285     SSCHECK(3);
 286     SSPUSHPTR(gv);
 287     SSPUSHPTR(ohv = GvHVn(gv));
 288     SSPUSHINT(SAVEt_HV);
 289
 290     GvHV(gv) = Null(HV*);
 291     hv = GvHVn(gv);
 292     if (SvMAGIC(ohv)) {
 293         SvMAGIC(hv) = SvMAGIC(ohv);
 294         SvFLAGS(hv) |= SvMAGICAL(ohv);
 295         SvMAGICAL_off(ohv);
 296         SvMAGIC(ohv) = 0;
 297         localizing = 1;
 298         SvSETMAGIC((SV*)hv);
 299         localizing = 0;
 300     }
 301     return hv;
 302 }
 303
 304 void
 305 save_item(register SV *item)
 306 {
 307     dTHR;
 308     register SV *sv = NEWSV(0,0);
 309
 310     sv_setsv(sv,item);
 311     SSCHECK(3);
 312     SSPUSHPTR(item);            /* remember the pointer */
 313     SSPUSHPTR(sv);              /* remember the value */
 314     SSPUSHINT(SAVEt_ITEM);
 315 }
 316
 317 void
 318 save_int(int *intp)
 319 {
 320     dTHR;
 321     SSCHECK(3);
 322     SSPUSHINT(*intp);
 323     SSPUSHPTR(intp);
 324     SSPUSHINT(SAVEt_INT);
 325 }
 326
 327 void
 328 save_long(long int *longp)
 329 {
 330     dTHR;
 331     SSCHECK(3);
 332     SSPUSHLONG(*longp);
 333     SSPUSHPTR(longp);
 334     SSPUSHINT(SAVEt_LONG);
 335 }
 336
 337 void
 338 save_I32(I32 *intp)
 339 {
 340     dTHR;
 341     SSCHECK(3);
 342     SSPUSHINT(*intp);
 343     SSPUSHPTR(intp);
 344     SSPUSHINT(SAVEt_I32);
 345 }
 346
 347 void
 348 save_I16(I16 *intp)
 349 {
 350     dTHR;
 351     SSCHECK(3);
 352     SSPUSHINT(*intp);
 353     SSPUSHPTR(intp);
 354     SSPUSHINT(SAVEt_I16);
 355 }
 356
 357 void
 358 save_iv(IV *ivp)
 359 {
 360     dTHR;
 361     SSCHECK(3);
 362     SSPUSHIV(*ivp);
 363     SSPUSHPTR(ivp);
 364     SSPUSHINT(SAVEt_IV);
 365 }
 366
 367 /* Cannot use save_sptr() to store a char* since the SV** cast will
 368  * force word-alignment and we'll miss the pointer.
 369  */
 370 void
 371 save_pptr(char **pptr)
 372 {
 373     dTHR;
 374     SSCHECK(3);
 375     SSPUSHPTR(*pptr);
 376     SSPUSHPTR(pptr);
 377     SSPUSHINT(SAVEt_PPTR);
 378 }
 379
 380 void
 381 save_sptr(SV **sptr)
 382 {
 383     dTHR;
 384     SSCHECK(3);
 385     SSPUSHPTR(*sptr);
 386     SSPUSHPTR(sptr);
 387     SSPUSHINT(SAVEt_SPTR);
 388 }
 389
 390 SV **
 391 save_threadsv(PADOFFSET i)
 392 {
 393 #ifdef USE_THREADS
 394     dTHR;
 395     SV **svp = &THREADSV(i);    /* XXX Change to save by offset */
 396     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n",
 397                           i, svp, *svp, SvPEEK(*svp)));
 398     save_svref(svp);
 399     return svp;
 400 #else
 401     croak("panic: save_threadsv called in non-threaded perl");
 402     return 0;
 403 #endif /* USE_THREADS */
 404 }
 405
 406 void
 407 save_nogv(GV *gv)
 408 {
 409     dTHR;
 410     SSCHECK(2);
 411     SSPUSHPTR(gv);
 412     SSPUSHINT(SAVEt_NSTAB);
 413 }
 414
 415 void
 416 save_hptr(HV **hptr)
 417 {
 418     dTHR;
 419     SSCHECK(3);
 420     SSPUSHPTR(*hptr);
 421     SSPUSHPTR(hptr);
 422     SSPUSHINT(SAVEt_HPTR);
 423 }
 424
 425 void
 426 save_aptr(AV **aptr)
 427 {
 428     dTHR;
 429     SSCHECK(3);
 430     SSPUSHPTR(*aptr);
 431     SSPUSHPTR(aptr);
 432     SSPUSHINT(SAVEt_APTR);
 433 }
 434
 435 void
 436 save_freesv(SV *sv)
 437 {
 438     dTHR;
 439     SSCHECK(2);
 440     SSPUSHPTR(sv);
 441     SSPUSHINT(SAVEt_FREESV);
 442 }
 443
 444 void
 445 save_freeop(OP *o)
 446 {
 447     dTHR;
 448     SSCHECK(2);
 449     SSPUSHPTR(o);
 450     SSPUSHINT(SAVEt_FREEOP);
 451 }
 452
 453 void
 454 save_freepv(char *pv)
 455 {
 456     dTHR;
 457     SSCHECK(2);
 458     SSPUSHPTR(pv);
 459     SSPUSHINT(SAVEt_FREEPV);
 460 }
 461
 462 void
 463 save_clearsv(SV **svp)
 464 {
 465     dTHR;
 466     SSCHECK(2);
 467     SSPUSHLONG((long)(svp-curpad));
 468     SSPUSHINT(SAVEt_CLEARSV);
 469 }
 470
 471 void
 472 save_delete(HV *hv, char *key, I32 klen)
 473 {
 474     dTHR;
 475     SSCHECK(4);
 476     SSPUSHINT(klen);
 477     SSPUSHPTR(key);
 478     SSPUSHPTR(SvREFCNT_inc(hv));
 479     SSPUSHINT(SAVEt_DELETE);
 480 }
 481
 482 void
 483 save_list(register SV **sarg, I32 maxsarg)
 484 {
 485     dTHR;
 486     register SV *sv;
 487     register I32 i;
 488
 489     for (i = 1; i <= maxsarg; i++) {
 490         sv = NEWSV(0,0);
 491         sv_setsv(sv,sarg[i]);
 492         SSCHECK(3);
 493         SSPUSHPTR(sarg[i]);             /* remember the pointer */
 494         SSPUSHPTR(sv);                  /* remember the value */
 495         SSPUSHINT(SAVEt_ITEM);
 496     }
 497 }
 498
 499 void
 500 #ifdef PERL_OBJECT
 501 save_destructor(DESTRUCTORFUNC f, void* p)
 502 #else
 503 save_destructor(void (*f) (void *), void *p)
 504 #endif
 505 {
 506     dTHR;
 507     SSCHECK(3);
 508     SSPUSHDPTR(f);
 509     SSPUSHPTR(p);
 510     SSPUSHINT(SAVEt_DESTRUCTOR);
 511 }
 512
 513 void
 514 save_aelem(AV *av, I32 idx, SV **sptr)
 515 {
 516     dTHR;
 517     SSCHECK(4);
 518     SSPUSHPTR(SvREFCNT_inc(av));
 519     SSPUSHINT(idx);
 520     SSPUSHPTR(SvREFCNT_inc(*sptr));
 521     SSPUSHINT(SAVEt_AELEM);
 522     save_scalar_at(sptr);
 523 }
 524
 525 void
 526 save_helem(HV *hv, SV *key, SV **sptr)
 527 {
 528     dTHR;
 529     SSCHECK(4);
 530     SSPUSHPTR(SvREFCNT_inc(hv));
 531     SSPUSHPTR(SvREFCNT_inc(key));
 532     SSPUSHPTR(SvREFCNT_inc(*sptr));
 533     SSPUSHINT(SAVEt_HELEM);
 534     save_scalar_at(sptr);
 535 }
 536
 537 void
 538 save_op(void)
 539 {
 540     dTHR;
 541     SSCHECK(2);
 542     SSPUSHPTR(op);
 543     SSPUSHINT(SAVEt_OP);
 544 }
 545
 546 void
 547 leave_scope(I32 base)
 548 {
 549     dTHR;
 550     register SV *sv;
 551     register SV *value;
 552     register GV *gv;
 553     register AV *av;
 554     register HV *hv;
 555     register void* ptr;
 556     I32 i;
 557
 558     if (base < -1)
 559         croak("panic: corrupt saved stack index");
 560     while (savestack_ix > base) {
 561         switch (SSPOPINT) {
 562         case SAVEt_ITEM:                        /* normal string */
 563             value = (SV*)SSPOPPTR;
 564             sv = (SV*)SSPOPPTR;
 565             sv_replace(sv,value);
 566             localizing = 2;
 567             SvSETMAGIC(sv);
 568             localizing = 0;
 569             break;
 570         case SAVEt_SV:                          /* scalar reference */
 571             value = (SV*)SSPOPPTR;
 572             gv = (GV*)SSPOPPTR;
 573             ptr = &GvSV(gv);
 574             SvREFCNT_dec(gv);
 575             goto restore_sv;
 576         case SAVEt_SVREF:                       /* scalar reference */
 577             value = (SV*)SSPOPPTR;
 578             ptr = SSPOPPTR;
 579         restore_sv:
 580             sv = *(SV**)ptr;
 581             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 582                                   "restore svref: %p %p:%s -> %p:%s\n",
 583                                   ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
 584             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
 585                 SvTYPE(sv) != SVt_PVGV)
 586             {
 587                 (void)SvUPGRADE(value, SvTYPE(sv));
 588                 SvMAGIC(value) = SvMAGIC(sv);
 589                 SvFLAGS(value) |= SvMAGICAL(sv);
 590                 SvMAGICAL_off(sv);
 591                 SvMAGIC(sv) = 0;
 592             }
 593             else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
 594                      SvTYPE(value) != SVt_PVGV)
 595             {
 596                 SvFLAGS(value) |= (SvFLAGS(value) &
 597                                    (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 598                 SvMAGICAL_off(value);
 599                 SvMAGIC(value) = 0;
 600             }
 601             SvREFCNT_dec(sv);
 602             *(SV**)ptr = value;
 603             localizing = 2;
 604             SvSETMAGIC(value);
 605             localizing = 0;
 606             SvREFCNT_dec(value);
 607             break;
 608         case SAVEt_AV:                          /* array reference */
 609             av = (AV*)SSPOPPTR;
 610             gv = (GV*)SSPOPPTR;
 611             if (GvAV(gv)) {
 612                 AV *goner = GvAV(gv);
 613                 SvMAGIC(av) = SvMAGIC(goner);
 614                 SvFLAGS(av) |= SvMAGICAL(goner);
 615                 SvMAGICAL_off(goner);
 616                 SvMAGIC(goner) = 0;
 617                 SvREFCNT_dec(goner);
 618             }
 619             GvAV(gv) = av;
 620             if (SvMAGICAL(av)) {
 621                 localizing = 2;
 622                 SvSETMAGIC((SV*)av);
 623                 localizing = 0;
 624             }
 625             break;
 626         case SAVEt_HV:                          /* hash reference */
 627             hv = (HV*)SSPOPPTR;
 628             gv = (GV*)SSPOPPTR;
 629             if (GvHV(gv)) {
 630                 HV *goner = GvHV(gv);
 631                 SvMAGIC(hv) = SvMAGIC(goner);
 632                 SvFLAGS(hv) |= SvMAGICAL(goner);
 633                 SvMAGICAL_off(goner);
 634                 SvMAGIC(goner) = 0;
 635                 SvREFCNT_dec(goner);
 636             }
 637             GvHV(gv) = hv;
 638             if (SvMAGICAL(hv)) {
 639                 localizing = 2;
 640                 SvSETMAGIC((SV*)hv);
 641                 localizing = 0;
 642             }
 643             break;
 644         case SAVEt_INT:                         /* int reference */
 645             ptr = SSPOPPTR;
 646             *(int*)ptr = (int)SSPOPINT;
 647             break;
 648         case SAVEt_LONG:                        /* long reference */
 649             ptr = SSPOPPTR;
 650             *(long*)ptr = (long)SSPOPLONG;
 651             break;
 652         case SAVEt_I32:                         /* I32 reference */
 653             ptr = SSPOPPTR;
 654             *(I32*)ptr = (I32)SSPOPINT;
 655             break;
 656         case SAVEt_I16:                         /* I16 reference */
 657             ptr = SSPOPPTR;
 658             *(I16*)ptr = (I16)SSPOPINT;
 659             break;
 660         case SAVEt_IV:                          /* IV reference */
 661             ptr = SSPOPPTR;
 662             *(IV*)ptr = (IV)SSPOPIV;
 663             break;
 664         case SAVEt_SPTR:                        /* SV* reference */
 665             ptr = SSPOPPTR;
 666             *(SV**)ptr = (SV*)SSPOPPTR;
 667             break;
 668         case SAVEt_PPTR:                        /* char* reference */
 669             ptr = SSPOPPTR;
 670             *(char**)ptr = (char*)SSPOPPTR;
 671             break;
 672         case SAVEt_HPTR:                        /* HV* reference */
 673             ptr = SSPOPPTR;
 674             *(HV**)ptr = (HV*)SSPOPPTR;
 675             break;
 676         case SAVEt_APTR:                        /* AV* reference */
 677             ptr = SSPOPPTR;
 678             *(AV**)ptr = (AV*)SSPOPPTR;
 679             break;
 680         case SAVEt_NSTAB:
 681             gv = (GV*)SSPOPPTR;
 682             (void)sv_clear((SV*)gv);
 683             break;
 684         case SAVEt_GP:                          /* scalar reference */
 685             ptr = SSPOPPTR;
 686             gv = (GV*)SSPOPPTR;
 687             if (SvPOK(gv) && SvLEN(gv) > 0) {
 688                 Safefree(SvPVX(gv));
 689             }
 690             SvPVX(gv) = (char *)SSPOPPTR;
 691             SvCUR(gv) = (STRLEN)SSPOPIV;
 692             SvLEN(gv) = (STRLEN)SSPOPIV;
 693             gp_free(gv);
 694             GvGP(gv) = (GP*)ptr;
 695             if (GvCVu(gv))
 696                 sub_generation++;  /* putting a method back into circulation */
 697             SvREFCNT_dec(gv);
 698             break;
 699         case SAVEt_FREESV:
 700             ptr = SSPOPPTR;
 701             SvREFCNT_dec((SV*)ptr);
 702             break;
 703         case SAVEt_FREEOP:
 704             ptr = SSPOPPTR;
 705             if (comppad)
 706                 curpad = AvARRAY(comppad);
 707             op_free((OP*)ptr);
 708             break;
 709         case SAVEt_FREEPV:
 710             ptr = SSPOPPTR;
 711             Safefree((char*)ptr);
 712             break;
 713         case SAVEt_CLEARSV:
 714             ptr = (void*)&curpad[SSPOPLONG];
 715             sv = *(SV**)ptr;
 716             /* Can clear pad variable in place? */
 717             if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
 718                 if (SvTHINKFIRST(sv)) {
 719                     if (SvREADONLY(sv))
 720                         croak("panic: leave_scope clearsv");
 721                     if (SvROK(sv))
 722                         sv_unref(sv);
 723                 }
 724                 if (SvMAGICAL(sv))
 725                     mg_free(sv);
 726
 727                 switch (SvTYPE(sv)) {
 728                 case SVt_NULL:
 729                     break;
 730                 case SVt_PVAV:
 731                     av_clear((AV*)sv);
 732                     break;
 733                 case SVt_PVHV:
 734                     hv_clear((HV*)sv);
 735                     break;
 736                 case SVt_PVCV:
 737                     croak("panic: leave_scope pad code");
 738                 case SVt_RV:
 739                 case SVt_IV:
 740                 case SVt_NV:
 741                     (void)SvOK_off(sv);
 742                     break;
 743                 default:
 744                     (void)SvOK_off(sv);
 745                     (void)SvOOK_off(sv);
 746                     break;
 747                 }
 748             }
 749             else {      /* Someone has a claim on this, so abandon it. */
 750                 U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
 751                 switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
 752                 case SVt_PVAV:  *(SV**)ptr = (SV*)newAV();      break;
 753                 case SVt_PVHV:  *(SV**)ptr = (SV*)newHV();      break;
 754                 default:        *(SV**)ptr = NEWSV(0,0);        break;
 755                 }
 756                 SvREFCNT_dec(sv);       /* Cast current value to the winds. */
 757                 SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
 758             }
 759             break;
 760         case SAVEt_DELETE:
 761             ptr = SSPOPPTR;
 762             hv = (HV*)ptr;
 763             ptr = SSPOPPTR;
 764             (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
 765             SvREFCNT_dec(hv);
 766             Safefree(ptr);
 767             break;
 768         case SAVEt_DESTRUCTOR:
 769             ptr = SSPOPPTR;
 770             (CALLDESTRUCTOR)(ptr);
 771             break;
 772         case SAVEt_REGCONTEXT:
 773             i = SSPOPINT;
 774             savestack_ix -= i;          /* regexp must have croaked */
 775             break;
 776         case SAVEt_STACK_POS:           /* Position on Perl stack */
 777             i = SSPOPINT;
 778             stack_sp = stack_base + i;
 779             break;
 780         case SAVEt_AELEM:               /* array element */
 781             value = (SV*)SSPOPPTR;
 782             i = SSPOPINT;
 783             av = (AV*)SSPOPPTR;
 784             ptr = av_fetch(av,i,1);
 785             if (ptr) {
 786                 sv = *(SV**)ptr;
 787                 if (sv && sv != &sv_undef) {
 788                     if (SvRMAGICAL(av) && mg_find((SV*)av, 'P'))
 789                         (void)SvREFCNT_inc(sv);
 790                     SvREFCNT_dec(av);
 791                     goto restore_sv;
 792                 }
 793             }
 794             SvREFCNT_dec(av);
 795             SvREFCNT_dec(value);
 796             break;
 797         case SAVEt_HELEM:               /* hash element */
 798             value = (SV*)SSPOPPTR;
 799             sv = (SV*)SSPOPPTR;
 800             hv = (HV*)SSPOPPTR;
 801             ptr = hv_fetch_ent(hv, sv, 1, 0);
 802             if (ptr) {
 803                 SV *oval = HeVAL((HE*)ptr);
 804                 if (oval && oval != &sv_undef) {
 805                     ptr = &HeVAL((HE*)ptr);
 806                     if (SvRMAGICAL(hv) && mg_find((SV*)hv, 'P'))
 807                         (void)SvREFCNT_inc(*(SV**)ptr);
 808                     SvREFCNT_dec(hv);
 809                     SvREFCNT_dec(sv);
 810                     goto restore_sv;
 811                 }
 812             }
 813             SvREFCNT_dec(hv);
 814             SvREFCNT_dec(sv);
 815             SvREFCNT_dec(value);
 816             break;
 817         case SAVEt_OP:
 818             op = (OP*)SSPOPPTR;
 819             break;
 820         default:
 821             croak("panic: leave_scope inconsistency");
 822         }
 823     }
 824 }
 825
 826 void
 827 cx_dump(PERL_CONTEXT *cx)
 828 {
 829 #ifdef DEBUGGING
 830     dTHR;
 831     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
 832     if (cx->cx_type != CXt_SUBST) {
 833         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
 834         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
 835         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
 836         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
 837         PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
 838         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
 839         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
 840     }
 841     switch (cx->cx_type) {
 842     case CXt_NULL:
 843     case CXt_BLOCK:
 844         break;
 845     case CXt_SUB:
 846         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
 847                 (long)cx->blk_sub.cv);
 848         PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
 849                 (long)cx->blk_sub.gv);
 850         PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
 851                 (long)cx->blk_sub.dfoutgv);
 852         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
 853                 (long)cx->blk_sub.olddepth);
 854         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
 855                 (int)cx->blk_sub.hasargs);
 856         break;
 857     case CXt_EVAL:
 858         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
 859                 (long)cx->blk_eval.old_in_eval);
 860         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
 861                 op_name[cx->blk_eval.old_op_type],
 862                 op_desc[cx->blk_eval.old_op_type]);
 863         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
 864                 cx->blk_eval.old_name);
 865         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
 866                 (long)cx->blk_eval.old_eval_root);
 867         break;
 868
 869     case CXt_LOOP:
 870         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
 871                 cx->blk_loop.label);
 872         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
 873                 (long)cx->blk_loop.resetsp);
 874         PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n",
 875                 (long)cx->blk_loop.redo_op);
 876         PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n",
 877                 (long)cx->blk_loop.next_op);
 878         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n",
 879                 (long)cx->blk_loop.last_op);
 880         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
 881                 (long)cx->blk_loop.iterix);
 882         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
 883                 (long)cx->blk_loop.iterary);
 884         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n",
 885                 (long)cx->blk_loop.itervar);
 886         if (cx->blk_loop.itervar)
 887             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
 888                 (long)cx->blk_loop.itersave);
 889         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
 890                 (long)cx->blk_loop.iterlval);
 891         break;
 892
 893     case CXt_SUBST:
 894         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
 895                 (long)cx->sb_iters);
 896         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
 897                 (long)cx->sb_maxiters);
 898         PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
 899                 (long)cx->sb_safebase);
 900         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
 901                 (long)cx->sb_once);
 902         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
 903                 cx->sb_orig);
 904         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
 905                 (long)cx->sb_dstr);
 906         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
 907                 (long)cx->sb_targ);
 908         PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
 909                 (long)cx->sb_s);
 910         PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
 911                 (long)cx->sb_m);
 912         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
 913                 (long)cx->sb_strend);
 914         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n",
 915                 (long)cx->sb_rxres);
 916         break;
 917     }
 918 #endif  /* DEBUGGING */
 919 }
 920
 921 #include "XSUB.h"
 922
 923 /* make 'static' once JMPENV_PUSH is no longer used (see scope.h) XXX */
 924 void
 925 setjmp_jump(CPERLarg)
 926 {
 927     dTHR;
 928     PerlProc_longjmp(((SETJMPENV*)top_env)->je_buf, 1);
 929 }
 930
 931 static void
 932 setjmp_tryblock(CPERLarg_ TRYVTBL *vtbl, void *locals)
 933 {
 934     dTHR;
 935     int jmpstat;
 936     SETJMPENV je;
 937     JMPENV_INIT(je, setjmp_jump);
 938     PerlProc_setjmp(je.je_buf, 1);
 939     JMPENV_TRY(je);
 940     jmpstat = JMPENV_STAT(je);
 941     switch (jmpstat) {
 942     case JMP_NORMAL:
 943         assert(vtbl->try_normal[0]);
 944         (*vtbl->try_normal[0])(PERL_OBJECT_THIS_ locals);
 945         break;
 946     case JMP_EXCEPTION:
 947         if (vtbl->try_exception[0])
 948             (*vtbl->try_exception[0])(PERL_OBJECT_THIS_ locals);
 949         break;
 950     case JMP_MYEXIT:
 951         if (vtbl->try_myexit[0])
 952             (*vtbl->try_myexit[0])(PERL_OBJECT_THIS_ locals);
 953         break;
 954     default:
 955         if (jmpstat != JMP_ABNORMAL)
 956             PerlIO_printf(PerlIO_stderr(),
 957                           "JMPENV_JUMP(%d) is bogus\n", jmpstat);
 958         if (vtbl->try_abnormal[0])
 959             (*vtbl->try_abnormal[0])(PERL_OBJECT_THIS_ locals);
 960         break;
 961     }
 962     JMPENV_POP_JE(je);
 963     switch (JMPENV_STAT(je)) {
 964     case JMP_NORMAL:
 965         if (vtbl->try_normal[1])
 966             (*vtbl->try_normal[1])(PERL_OBJECT_THIS_ locals);
 967         break;
 968     case JMP_EXCEPTION:
 969         if (vtbl->try_exception[1])
 970             (*vtbl->try_exception[1])(PERL_OBJECT_THIS_ locals);
 971         break;
 972     case JMP_MYEXIT:
 973         if (vtbl->try_myexit[1])
 974             (*vtbl->try_myexit[1])(PERL_OBJECT_THIS_ locals);
 975         break;
 976     default:
 977         if (jmpstat != JMP_ABNORMAL)
 978             PerlIO_printf(PerlIO_stderr(),
 979                           "JMPENV_JUMP(%d) is bogus\n", jmpstat);
 980         if (vtbl->try_abnormal[1])
 981             (*vtbl->try_abnormal[1])(PERL_OBJECT_THIS_ locals);
 982         break;
 983     }
 984 }
 985