Upper.xs

   1 /* This file is part of the Scope::Upper Perl module.
   2  * See http://search.cpan.org/dist/Scope-Upper/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__ "Scope::Upper"
  10
  11 #ifndef SU_DEBUG
  12 # define SU_DEBUG 0
  13 #endif
  14
  15 /* --- Compatibility ------------------------------------------------------- */
  16
  17 #ifndef NOOP
  18 # define NOOP
  19 #endif
  20
  21 #ifndef dNOOP
  22 # define dNOOP
  23 #endif
  24
  25 #ifndef dVAR
  26 # define dVAR dNOOP
  27 #endif
  28
  29 #ifndef MUTABLE_SV
  30 # define MUTABLE_SV(S) ((SV *) (S))
  31 #endif
  32
  33 #ifndef MUTABLE_AV
  34 # define MUTABLE_AV(A) ((AV *) (A))
  35 #endif
  36
  37 #ifndef MUTABLE_CV
  38 # define MUTABLE_CV(C) ((CV *) (C))
  39 #endif
  40
  41 #ifndef PERL_UNUSED_VAR
  42 # define PERL_UNUSED_VAR(V)
  43 #endif
  44
  45 #ifndef STMT_START
  46 # define STMT_START do
  47 #endif
  48
  49 #ifndef STMT_END
  50 # define STMT_END while (0)
  51 #endif
  52
  53 #if SU_DEBUG
  54 # define SU_D(X) STMT_START X STMT_END
  55 #else
  56 # define SU_D(X)
  57 #endif
  58
  59 #ifndef Newx
  60 # define Newx(v, n, c) New(0, v, n, c)
  61 #endif
  62
  63 #ifdef DEBUGGING
  64 # ifdef PoisonNew
  65 #  define SU_POISON(D, N, T) PoisonNew((D), (N), T)
  66 # elif defined(Poison)
  67 #  define SU_POISON(D, N, T) Poison((D), (N), T)
  68 # endif
  69 #endif
  70 #ifndef SU_POISON
  71 # define SU_POISON(D, N, T) NOOP
  72 #endif
  73
  74 #ifndef newSV_type
  75 STATIC SV *su_newSV_type(pTHX_ svtype t) {
  76  SV *sv = newSV(0);
  77  SvUPGRADE(sv, t);
  78  return sv;
  79 }
  80 # define newSV_type(T) su_newSV_type(aTHX_ (T))
  81 #endif
  82
  83 #ifndef SvPV_const
  84 # define SvPV_const(S, L) SvPV(S, L)
  85 #endif
  86
  87 #ifndef SvPVX_const
  88 # define SvPVX_const(S) SvPVX(S)
  89 #endif
  90
  91 #ifndef SvPV_nolen_const
  92 # define SvPV_nolen_const(S) SvPV_nolen(S)
  93 #endif
  94
  95 #ifndef SvREFCNT_inc_simple_void
  96 # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv))
  97 #endif
  98
  99 #ifndef mPUSHi
 100 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
 101 #endif
 102
 103 #ifndef GvCV_set
 104 # define GvCV_set(G, C) (GvCV(G) = (C))
 105 #endif
 106
 107 #ifndef CvGV_set
 108 # define CvGV_set(C, G) (CvGV(C) = (G))
 109 #endif
 110
 111 #ifndef CvSTASH_set
 112 # define CvSTASH_set(C, S) (CvSTASH(C) = (S))
 113 #endif
 114
 115 #ifndef CvISXSUB
 116 # define CvISXSUB(C) CvXSUB(C)
 117 #endif
 118
 119 #ifndef CxHASARGS
 120 # define CxHASARGS(C) ((C)->blk_sub.hasargs)
 121 #endif
 122
 123 #ifndef HvNAME_get
 124 # define HvNAME_get(H) HvNAME(H)
 125 #endif
 126
 127 #ifndef gv_fetchpvn_flags
 128 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 129 #endif
 130
 131 #ifndef PERL_MAGIC_tied
 132 # define PERL_MAGIC_tied 'P'
 133 #endif
 134
 135 #ifndef PERL_MAGIC_env
 136 # define PERL_MAGIC_env 'E'
 137 #endif
 138
 139 #ifndef NEGATIVE_INDICES_VAR
 140 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
 141 #endif
 142
 143 #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
 144 #define SU_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S)))
 145
 146 /* --- Threads and multiplicity -------------------------------------------- */
 147
 148 #ifndef SU_MULTIPLICITY
 149 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
 150 #  define SU_MULTIPLICITY 1
 151 # else
 152 #  define SU_MULTIPLICITY 0
 153 # endif
 154 #endif
 155 #if SU_MULTIPLICITY && !defined(tTHX)
 156 # define tTHX PerlInterpreter*
 157 #endif
 158
 159 #if SU_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
 160 # define SU_THREADSAFE 1
 161 # ifndef MY_CXT_CLONE
 162 #  define MY_CXT_CLONE \
 163     dMY_CXT_SV;                                                      \
 164     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
 165     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
 166     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 167 # endif
 168 #else
 169 # define SU_THREADSAFE 0
 170 # undef  dMY_CXT
 171 # define dMY_CXT      dNOOP
 172 # undef  MY_CXT
 173 # define MY_CXT       su_globaldata
 174 # undef  START_MY_CXT
 175 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
 176 # undef  MY_CXT_INIT
 177 # define MY_CXT_INIT  NOOP
 178 # undef  MY_CXT_CLONE
 179 # define MY_CXT_CLONE NOOP
 180 #endif
 181
 182 /* --- unwind() global storage --------------------------------------------- */
 183
 184 typedef struct {
 185  I32      cxix;
 186  I32      items;
 187  SV     **savesp;
 188  LISTOP   return_op;
 189  OP       proxy_op;
 190 } su_unwind_storage;
 191
 192 /* --- uplevel() data tokens and global storage ---------------------------- */
 193
 194 typedef struct {
 195  void *next;
 196
 197  I32  cxix;
 198  bool died;
 199
 200  CV  *target;
 201  I32  target_depth;
 202
 203  CV  *callback;
 204  CV  *renamed;
 205
 206  PERL_SI *si;
 207  PERL_SI *old_curstackinfo;
 208  AV      *old_mainstack;
 209
 210  COP *old_curcop;
 211
 212  runops_proc_t  old_runops;
 213  bool           old_catch;
 214  OP            *old_op;
 215 } su_uplevel_ud;
 216
 217 STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
 218 #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
 219  su_uplevel_ud *sud;
 220  PERL_SI       *si;
 221
 222  Newx(sud, 1, su_uplevel_ud);
 223  sud->next = NULL;
 224
 225  Newx(si, 1, PERL_SI);
 226  si->si_stack   = newAV();
 227  AvREAL_off(si->si_stack);
 228  si->si_cxstack = NULL;
 229  si->si_cxmax   = 0;
 230
 231  sud->si = si;
 232
 233  return sud;
 234 }
 235
 236 STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
 237 #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
 238  PERL_SI *si = sud->si;
 239
 240  Safefree(si->si_cxstack);
 241  SvREFCNT_dec(si->si_stack);
 242  Safefree(si);
 243  Safefree(sud);
 244
 245  return;
 246 }
 247
 248 typedef struct {
 249  su_uplevel_ud *top;
 250  su_uplevel_ud *root;
 251  I32            count;
 252 } su_uplevel_storage;
 253
 254 #ifndef SU_UPLEVEL_STORAGE_SIZE
 255 # define SU_UPLEVEL_STORAGE_SIZE 4
 256 #endif
 257
 258 /* --- Global data --------------------------------------------------------- */
 259
 260 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 261
 262 typedef struct {
 263  char               *stack_placeholder;
 264  su_unwind_storage   unwind_storage;
 265  su_uplevel_storage  uplevel_storage;
 266 } my_cxt_t;
 267
 268 START_MY_CXT
 269
 270 /* --- Stack manipulations ------------------------------------------------- */
 271
 272 #define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder)
 273
 274 #define SU_SAVE_DESTRUCTOR_SIZE  3
 275 #define SU_SAVE_PLACEHOLDER_SIZE 3
 276
 277 #define SU_SAVE_SCALAR_SIZE 3
 278
 279 #define SU_SAVE_ARY_SIZE      3
 280 #define SU_SAVE_AELEM_SIZE    4
 281 #ifdef SAVEADELETE
 282 # define SU_SAVE_ADELETE_SIZE 3
 283 #else
 284 # define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
 285 #endif
 286 #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
 287 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
 288 #else
 289 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
 290 #endif
 291
 292 #define SU_SAVE_HASH_SIZE    3
 293 #define SU_SAVE_HELEM_SIZE   4
 294 #define SU_SAVE_HDELETE_SIZE 4
 295 #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
 296 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
 297 #else
 298 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
 299 #endif
 300
 301 #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
 302
 303 #if !SU_HAS_PERL(5, 8, 9)
 304 # define SU_SAVE_GP_SIZE 6
 305 #elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0))
 306 # define SU_SAVE_GP_SIZE 3
 307 #elif !SU_HAS_PERL(5, 13, 8)
 308 # define SU_SAVE_GP_SIZE 4
 309 #else
 310 # define SU_SAVE_GP_SIZE 3
 311 #endif
 312
 313 #ifndef SvCANEXISTDELETE
 314 # define SvCANEXISTDELETE(sv) \
 315   (!SvRMAGICAL(sv)            \
 316    || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied))            \
 317        && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \
 318        && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)     \
 319        && gv_fetchmethod_autoload(stash, "DELETE", TRUE)     \
 320       )                       \
 321    )
 322 #endif
 323
 324 /* ... Saving array elements ............................................... */
 325
 326 STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
 327 #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K))
 328  I32 idx;
 329
 330  if (key >= 0)
 331   return key;
 332
 333 /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */
 334 #if SU_HAS_PERL(5, 8, 1)
 335  if (SvRMAGICAL(av)) {
 336   const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
 337   if (tied_magic) {
 338    SV * const * const negative_indices_glob =
 339                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
 340                              NEGATIVE_INDICES_VAR, 16, 0);
 341    if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 342     return key;
 343   }
 344  }
 345 #endif
 346
 347  idx = key + av_len(av) + 1;
 348  if (idx < 0)
 349   return key;
 350
 351  return idx;
 352 }
 353
 354 #ifndef SAVEADELETE
 355
 356 typedef struct {
 357  AV *av;
 358  I32 idx;
 359 } su_ud_adelete;
 360
 361 STATIC void su_adelete(pTHX_ void *ud_) {
 362  su_ud_adelete *ud = (su_ud_adelete *) ud_;
 363
 364  av_delete(ud->av, ud->idx, G_DISCARD);
 365  SvREFCNT_dec(ud->av);
 366
 367  Safefree(ud);
 368 }
 369
 370 STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) {
 371 #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K))
 372  su_ud_adelete *ud;
 373
 374  Newx(ud, 1, su_ud_adelete);
 375  ud->av  = av;
 376  ud->idx = idx;
 377  SvREFCNT_inc_simple_void(av);
 378
 379  SAVEDESTRUCTOR_X(su_adelete, ud);
 380 }
 381
 382 #define SAVEADELETE(A, K) su_save_adelete((A), (K))
 383
 384 #endif /* SAVEADELETE */
 385
 386 STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) {
 387 #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V))
 388  I32 idx;
 389  I32 preeminent = 1;
 390  SV **svp;
 391  HV *stash;
 392  MAGIC *mg;
 393
 394  idx = su_av_key2idx(av, SvIV(key));
 395
 396  if (SvCANEXISTDELETE(av))
 397   preeminent = av_exists(av, idx);
 398
 399  svp = av_fetch(av, idx, 1);
 400  if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
 401
 402  if (preeminent)
 403   save_aelem(av, idx, svp);
 404  else
 405   SAVEADELETE(av, idx);
 406
 407  if (val) { /* local $x[$idx] = $val; */
 408   SvSetMagicSV(*svp, val);
 409  } else {   /* local $x[$idx]; delete $x[$idx]; */
 410   av_delete(av, idx, G_DISCARD);
 411  }
 412 }
 413
 414 /* ... Saving hash elements ................................................ */
 415
 416 STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
 417 #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V))
 418  I32 preeminent = 1;
 419  HE *he;
 420  SV **svp;
 421  HV *stash;
 422  MAGIC *mg;
 423
 424  if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env))
 425   preeminent = hv_exists_ent(hv, keysv, 0);
 426
 427  he  = hv_fetch_ent(hv, keysv, 1, 0);
 428  svp = he ? &HeVAL(he) : NULL;
 429  if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
 430
 431  if (HvNAME_get(hv) && isGV(*svp)) {
 432   save_gp((GV *) *svp, 0);
 433   return;
 434  }
 435
 436  if (preeminent)
 437   save_helem(hv, keysv, svp);
 438  else {
 439   STRLEN keylen;
 440   const char * const key = SvPV_const(keysv, keylen);
 441   SAVEDELETE(hv, savepvn(key, keylen),
 442                  SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
 443  }
 444
 445  if (val) { /* local $x{$keysv} = $val; */
 446   SvSetMagicSV(*svp, val);
 447  } else {   /* local $x{$keysv}; delete $x{$keysv}; */
 448   (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
 449  }
 450 }
 451
 452 /* ... Saving code slots from a glob ....................................... */
 453
 454 #if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in)
 455 # define mro_method_changed_in(G) PL_sub_generation++
 456 #endif
 457
 458 typedef struct {
 459  GV *gv;
 460  CV *old_cv;
 461 } su_save_gvcv_ud;
 462
 463 STATIC void su_restore_gvcv(pTHX_ void *ud_) {
 464  su_save_gvcv_ud *ud = ud_;
 465  GV              *gv = ud->gv;
 466
 467  GvCV_set(gv, ud->old_cv);
 468  GvCVGEN(gv) = 0;
 469  mro_method_changed_in(GvSTASH(gv));
 470
 471  Safefree(ud);
 472 }
 473
 474 STATIC void su_save_gvcv(pTHX_ GV *gv) {
 475 #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G))
 476  su_save_gvcv_ud *ud;
 477
 478  Newx(ud, 1, su_save_gvcv_ud);
 479  ud->gv     = gv;
 480  ud->old_cv = GvCV(gv);
 481
 482  GvCV_set(gv, NULL);
 483  GvCVGEN(gv) = 0;
 484  mro_method_changed_in(GvSTASH(gv));
 485
 486  SAVEDESTRUCTOR_X(su_restore_gvcv, ud);
 487 }
 488
 489 /* --- Actions ------------------------------------------------------------- */
 490
 491 typedef struct {
 492  I32 depth;
 493  I32 pad;
 494  I32 *origin;
 495  void (*handler)(pTHX_ void *);
 496 } su_ud_common;
 497
 498 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
 499 #define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
 500 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
 501 #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
 502
 503 #define SU_UD_FREE(U) STMT_START { \
 504  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
 505  Safefree(U); \
 506 } STMT_END
 507
 508 /* ... Reap ................................................................ */
 509
 510 typedef struct {
 511  su_ud_common ci;
 512  SV *cb;
 513 } su_ud_reap;
 514
 515 STATIC void su_call(pTHX_ void *ud_) {
 516  su_ud_reap *ud = (su_ud_reap *) ud_;
 517 #if SU_HAS_PERL(5, 9, 5)
 518  PERL_CONTEXT saved_cx;
 519  I32 cxix;
 520 #endif
 521
 522  dSP;
 523
 524  SU_D({
 525   PerlIO_printf(Perl_debug_log,
 526                 "%p: @@@ call\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 527                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 528  });
 529
 530  ENTER;
 531  SAVETMPS;
 532
 533  PUSHMARK(SP);
 534  PUTBACK;
 535
 536  /* If the recently popped context isn't saved there, it will be overwritten by
 537   * the sub scope from call_sv, although it's still needed in our caller. */
 538
 539 #if SU_HAS_PERL(5, 9, 5)
 540  if (cxstack_ix < cxstack_max)
 541   cxix = cxstack_ix + 1;
 542  else
 543   cxix = Perl_cxinc(aTHX);
 544  saved_cx = cxstack[cxix];
 545 #endif
 546
 547  call_sv(ud->cb, G_VOID);
 548
 549 #if SU_HAS_PERL(5, 9, 5)
 550  cxstack[cxix] = saved_cx;
 551 #endif
 552
 553  PUTBACK;
 554
 555  FREETMPS;
 556  LEAVE;
 557
 558  SvREFCNT_dec(ud->cb);
 559  SU_UD_FREE(ud);
 560 }
 561
 562 STATIC void su_reap(pTHX_ void *ud) {
 563 #define su_reap(U) su_reap(aTHX_ (U))
 564  SU_D({
 565   PerlIO_printf(Perl_debug_log,
 566                 "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 567                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 568  });
 569
 570  SAVEDESTRUCTOR_X(su_call, ud);
 571 }
 572
 573 /* ... Localize & localize array/hash element .............................. */
 574
 575 typedef struct {
 576  su_ud_common ci;
 577  SV    *sv;
 578  SV    *val;
 579  SV    *elem;
 580  svtype type;
 581 } su_ud_localize;
 582
 583 #define SU_UD_LOCALIZE_FREE(U) STMT_START { \
 584  SvREFCNT_dec((U)->elem); \
 585  SvREFCNT_dec((U)->val);  \
 586  SvREFCNT_dec((U)->sv);   \
 587  SU_UD_FREE(U);           \
 588 } STMT_END
 589
 590 STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
 591 #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
 592  UV deref = 0;
 593  svtype t = SVt_NULL;
 594  I32 size;
 595
 596  SvREFCNT_inc_simple_void(sv);
 597
 598  if (SvTYPE(sv) >= SVt_PVGV) {
 599   if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
 600    t = SVt_PVGV;
 601   } else {                   /* local *x = \$val; */
 602    t = SvTYPE(SvRV(val));
 603    deref = 1;
 604   }
 605  } else if (SvROK(sv)) {
 606   croak("Invalid %s reference as the localization target",
 607                  sv_reftype(SvRV(sv), 0));
 608  } else {
 609   STRLEN len, l;
 610   const char *p = SvPV_const(sv, len), *s;
 611   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
 612   if (!l) {
 613    l = len;
 614    s = p;
 615   }
 616   switch (*s) {
 617    case '$': t = SVt_PV;   break;
 618    case '@': t = SVt_PVAV; break;
 619    case '%': t = SVt_PVHV; break;
 620    case '&': t = SVt_PVCV; break;
 621    case '*': t = SVt_PVGV; break;
 622   }
 623   if (t != SVt_NULL) {
 624    ++s;
 625    --l;
 626   } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
 627    if (SvROK(val) && !sv_isobject(val)) {
 628     t = SvTYPE(SvRV(val));
 629     deref = 1;
 630    } else {
 631     t = SvTYPE(val);
 632    }
 633   }
 634   SvREFCNT_dec(sv);
 635   sv = newSVpvn(s, l);
 636  }
 637
 638  switch (t) {
 639   case SVt_PVAV:
 640    size  = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
 641                 : SU_SAVE_ARY_SIZE;
 642    deref = 0;
 643    break;
 644   case SVt_PVHV:
 645    size  = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
 646                 : SU_SAVE_HASH_SIZE;
 647    deref = 0;
 648    break;
 649   case SVt_PVGV:
 650    size  = SU_SAVE_GP_SIZE;
 651    deref = 0;
 652    break;
 653   case SVt_PVCV:
 654    size  = SU_SAVE_GVCV_SIZE;
 655    deref = 0;
 656    break;
 657   default:
 658    size = SU_SAVE_SCALAR_SIZE;
 659    break;
 660  }
 661  /* When deref is set, val isn't NULL */
 662
 663  ud->sv   = sv;
 664  ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
 665  ud->elem = SvREFCNT_inc(elem);
 666  ud->type = t;
 667
 668  return size;
 669 }
 670
 671 STATIC void su_localize(pTHX_ void *ud_) {
 672 #define su_localize(U) su_localize(aTHX_ (U))
 673  su_ud_localize *ud = (su_ud_localize *) ud_;
 674  SV *sv   = ud->sv;
 675  SV *val  = ud->val;
 676  SV *elem = ud->elem;
 677  svtype t = ud->type;
 678  GV *gv;
 679
 680  if (SvTYPE(sv) >= SVt_PVGV) {
 681   gv = (GV *) sv;
 682  } else {
 683 #ifdef gv_fetchsv
 684   gv = gv_fetchsv(sv, GV_ADDMULTI, t);
 685 #else
 686   STRLEN len;
 687   const char *name = SvPV_const(sv, len);
 688   gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
 689 #endif
 690  }
 691
 692  SU_D({
 693   SV *z = newSV(0);
 694   SvUPGRADE(z, t);
 695   PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0));
 696   PerlIO_printf(Perl_debug_log,
 697                 "%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 698                  ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 699   SvREFCNT_dec(z);
 700  });
 701
 702  /* Inspired from Alias.pm */
 703  switch (t) {
 704   case SVt_PVAV:
 705    if (elem) {
 706     su_save_aelem(GvAV(gv), elem, val);
 707     goto done;
 708    } else
 709     save_ary(gv);
 710    break;
 711   case SVt_PVHV:
 712    if (elem) {
 713     su_save_helem(GvHV(gv), elem, val);
 714     goto done;
 715    } else
 716     save_hash(gv);
 717    break;
 718   case SVt_PVGV:
 719    save_gp(gv, 1); /* hide previous entry in symtab */
 720    break;
 721   case SVt_PVCV:
 722    su_save_gvcv(gv);
 723    break;
 724   default:
 725    gv = (GV *) save_scalar(gv);
 726    break;
 727  }
 728
 729  if (val)
 730   SvSetMagicSV((SV *) gv, val);
 731
 732 done:
 733  SU_UD_LOCALIZE_FREE(ud);
 734 }
 735
 736 /* --- Pop a context back -------------------------------------------------- */
 737
 738 #if SU_DEBUG
 739 # ifdef DEBUGGING
 740 #  define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
 741 # else
 742 #  define SU_CXNAME "XXX"
 743 # endif
 744 #endif
 745
 746 STATIC void su_pop(pTHX_ void *ud) {
 747 #define su_pop(U) su_pop(aTHX_ (U))
 748  I32 depth, base, mark, *origin;
 749  depth = SU_UD_DEPTH(ud);
 750
 751  SU_D(
 752   PerlIO_printf(Perl_debug_log,
 753    "%p: --- pop a %s\n"
 754    "%p: leave scope     at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n",
 755     ud, SU_CXNAME,
 756     ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix])
 757  );
 758
 759  origin = SU_UD_ORIGIN(ud);
 760  mark   = origin[depth];
 761  base   = origin[depth - 1];
 762
 763  SU_D(PerlIO_printf(Perl_debug_log,
 764                     "%p: original scope was %*c top=%2d     base=%2d\n",
 765                      ud,                24, ' ',    mark,        base));
 766
 767  if (base < mark) {
 768   SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
 769   PL_savestack_ix = mark;
 770   leave_scope(base);
 771  }
 772  PL_savestack_ix = base;
 773
 774  SU_UD_DEPTH(ud) = --depth;
 775
 776  if (depth > 0) {
 777   I32 pad;
 778
 779   if ((pad = SU_UD_PAD(ud))) {
 780    dMY_CXT;
 781    do {
 782     SU_D(PerlIO_printf(Perl_debug_log,
 783           "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n",
 784            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
 785     SU_SAVE_PLACEHOLDER();
 786    } while (--pad);
 787   }
 788
 789   SU_D(PerlIO_printf(Perl_debug_log,
 790           "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
 791            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
 792   SAVEDESTRUCTOR_X(su_pop, ud);
 793  } else {
 794   SU_UD_HANDLER(ud)(aTHX_ ud);
 795  }
 796
 797  SU_D(PerlIO_printf(Perl_debug_log,
 798                     "%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
 799                      ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
 800 }
 801
 802 /* --- Initialize the stack and the action userdata ------------------------ */
 803
 804 STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 805 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
 806  I32 i, depth = 1, pad, offset, *origin;
 807
 808  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
 809
 810  if (size <= SU_SAVE_DESTRUCTOR_SIZE)
 811   pad = 0;
 812  else {
 813   I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
 814   pad = extra / SU_SAVE_PLACEHOLDER_SIZE;
 815   if (extra % SU_SAVE_PLACEHOLDER_SIZE)
 816    ++pad;
 817  }
 818  offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad;
 819
 820  SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
 821                                      ud,    size,   pad,   offset));
 822
 823  for (i = cxstack_ix; i > cxix; --i) {
 824   PERL_CONTEXT *cx = cxstack + i;
 825   switch (CxTYPE(cx)) {
 826 #if SU_HAS_PERL(5, 10, 0)
 827    case CXt_BLOCK:
 828     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i));
 829     /* Given and when blocks are actually followed by a simple block, so skip
 830      * it if needed. */
 831     if (cxix > 0) { /* Implies i > 0 */
 832      PERL_CONTEXT *next = cx - 1;
 833      if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN)
 834       --cxix;
 835     }
 836     depth++;
 837     break;
 838 #endif
 839 #if SU_HAS_PERL(5, 11, 0)
 840    case CXt_LOOP_FOR:
 841    case CXt_LOOP_PLAIN:
 842    case CXt_LOOP_LAZYSV:
 843    case CXt_LOOP_LAZYIV:
 844 #else
 845    case CXt_LOOP:
 846 #endif
 847     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
 848     depth += 2;
 849     break;
 850    default:
 851     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
 852     depth++;
 853     break;
 854   }
 855  }
 856  SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
 857
 858  Newx(origin, depth + 1, I32);
 859  origin[0] = PL_scopestack[PL_scopestack_ix - depth];
 860  PL_scopestack[PL_scopestack_ix - depth] += size;
 861  for (i = depth - 1; i >= 1; --i) {
 862   I32 j = PL_scopestack_ix - i;
 863   origin[depth - i] = PL_scopestack[j];
 864   PL_scopestack[j] += offset;
 865  }
 866  origin[depth] = PL_savestack_ix;
 867
 868  SU_UD_ORIGIN(ud) = origin;
 869  SU_UD_DEPTH(ud)  = depth;
 870  SU_UD_PAD(ud)    = pad;
 871
 872  /* Make sure the first destructor fires by pushing enough fake slots on the
 873   * stack. */
 874  if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
 875                                        <= PL_scopestack[PL_scopestack_ix - 1]) {
 876   dMY_CXT;
 877   do {
 878    SU_D(PerlIO_printf(Perl_debug_log,
 879                   "%p: push a fake slot      at scope_ix=%2d  save_ix=%2d\n",
 880                    ud,                      PL_scopestack_ix, PL_savestack_ix));
 881    SU_SAVE_PLACEHOLDER();
 882   } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
 883                                         <= PL_scopestack[PL_scopestack_ix - 1]);
 884  }
 885  SU_D(PerlIO_printf(Perl_debug_log,
 886                   "%p: push first destructor at scope_ix=%2d  save_ix=%2d\n",
 887                    ud,                      PL_scopestack_ix, PL_savestack_ix));
 888  SAVEDESTRUCTOR_X(su_pop, ud);
 889
 890  SU_D({
 891   for (i = 0; i <= depth; ++i) {
 892    I32 j = PL_scopestack_ix  - i;
 893    PerlIO_printf(Perl_debug_log,
 894                  "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n",
 895                   ud,        i, j, origin[depth - i],
 896                                    i == 0 ? PL_savestack_ix : PL_scopestack[j]);
 897   }
 898  });
 899
 900  return depth;
 901 }
 902
 903 /* --- Unwind stack -------------------------------------------------------- */
 904
 905 STATIC void su_unwind(pTHX_ void *ud_) {
 906  dMY_CXT;
 907  I32 cxix    = MY_CXT.unwind_storage.cxix;
 908  I32 items   = MY_CXT.unwind_storage.items - 1;
 909  SV **savesp = MY_CXT.unwind_storage.savesp;
 910  I32 mark;
 911
 912  PERL_UNUSED_VAR(ud_);
 913
 914  if (savesp)
 915   PL_stack_sp = savesp;
 916
 917  if (cxstack_ix > cxix)
 918   dounwind(cxix);
 919
 920  /* Hide the level */
 921  if (items >= 0)
 922   PL_stack_sp--;
 923
 924  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
 925  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
 926
 927  SU_D({
 928   I32 gimme = GIMME_V;
 929   PerlIO_printf(Perl_debug_log,
 930                 "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
 931                 &MY_CXT, cxix,
 932                 gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
 933                 items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
 934  });
 935
 936  PL_op = (OP *) &(MY_CXT.unwind_storage.return_op);
 937  PL_op = PL_op->op_ppaddr(aTHX);
 938
 939  *PL_markstack_ptr = mark;
 940
 941  MY_CXT.unwind_storage.proxy_op.op_next = PL_op;
 942  PL_op = &(MY_CXT.unwind_storage.proxy_op);
 943 }
 944
 945 /* --- Uplevel ------------------------------------------------------------- */
 946
 947 #ifndef OP_GIMME_REVERSE
 948 STATIC U8 su_op_gimme_reverse(U8 gimme) {
 949  switch (gimme) {
 950   case G_VOID:
 951    return OPf_WANT_VOID;
 952   case G_ARRAY:
 953    return OPf_WANT_LIST;
 954   default:
 955    break;
 956  }
 957
 958  return OPf_WANT_SCALAR;
 959 }
 960 #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
 961 #endif
 962
 963 #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
 964 #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
 965
 966 STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) {
 967 #define su_uplevel_storage_new() su_uplevel_storage_new(aTHX)
 968  su_uplevel_ud *sud;
 969  dMY_CXT;
 970
 971  sud = MY_CXT.uplevel_storage.root;
 972  if (sud) {
 973   MY_CXT.uplevel_storage.root = sud->next;
 974   MY_CXT.uplevel_storage.count--;
 975  } else {
 976   sud = su_uplevel_ud_new();
 977  }
 978
 979  sud->next = MY_CXT.uplevel_storage.top;
 980  MY_CXT.uplevel_storage.top = sud;
 981
 982  return sud;
 983 }
 984
 985 STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
 986 #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
 987  dMY_CXT;
 988
 989  MY_CXT.uplevel_storage.top = sud->next;
 990
 991  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
 992   su_uplevel_ud_delete(sud);
 993  } else {
 994   sud->next = MY_CXT.uplevel_storage.root;
 995   MY_CXT.uplevel_storage.root = sud;
 996   MY_CXT.uplevel_storage.count++;
 997  }
 998 }
 999
1000 STATIC int su_uplevel_goto_static(const OP *o) {
1001  for (; o; o = o->op_sibling) {
1002   /* goto ops are unops with kids. */
1003   if (!(o->op_flags & OPf_KIDS))
1004    continue;
1005
1006   switch (o->op_type) {
1007    case OP_LEAVEEVAL:
1008    case OP_LEAVETRY:
1009     /* Don't care about gotos inside eval, as they are forbidden at run time. */
1010     break;
1011    case OP_GOTO:
1012     return 1;
1013    default:
1014     if (su_uplevel_goto_static(cUNOPo->op_first))
1015      return 1;
1016     break;
1017   }
1018  }
1019
1020  return 0;
1021 }
1022
1023 STATIC int su_uplevel_goto_runops(pTHX) {
1024 #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
1025  register OP *op;
1026  dVAR;
1027
1028  op = PL_op;
1029  do {
1030   if (op->op_type == OP_GOTO) {
1031    AV  *argarray = NULL;
1032    I32  cxix;
1033
1034    for (cxix = cxstack_ix; cxix >= 0; --cxix) {
1035     const PERL_CONTEXT *cx = cxstack + cxix;
1036
1037     switch (CxTYPE(cx)) {
1038      case CXt_SUB:
1039       if (CxHASARGS(cx)) {
1040        argarray = cx->blk_sub.argarray;
1041        goto done;
1042       }
1043       break;
1044      case CXt_EVAL:
1045      case CXt_FORMAT:
1046       goto done;
1047      default:
1048       break;
1049     }
1050    }
1051
1052 done:
1053    if (argarray) {
1054     dMY_CXT;
1055
1056     if (MY_CXT.uplevel_storage.top->cxix == cxix) {
1057      AV  *args  = GvAV(PL_defgv);
1058      I32  items = AvFILLp(args);
1059
1060      av_extend(argarray, items);
1061      Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
1062      AvFILLp(argarray) = items;
1063     }
1064    }
1065   }
1066
1067   PL_op = op = op->op_ppaddr(aTHX);
1068
1069 #if !SU_HAS_PERL(5, 13, 0)
1070   PERL_ASYNC_CHECK();
1071 #endif
1072  } while (op);
1073
1074  TAINT_NOT;
1075
1076  return 0;
1077 }
1078
1079 #define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
1080
1081 STATIC void su_uplevel_restore(pTHX_ void *sus_) {
1082  su_uplevel_ud *sud = sus_;
1083  PERL_SI *cur = sud->old_curstackinfo;
1084  PERL_SI *si  = sud->si;
1085
1086  if (PL_runops == su_uplevel_goto_runops)
1087   PL_runops = sud->old_runops;
1088
1089  if (sud->callback) {
1090   PERL_CONTEXT *cx = cxstack + sud->cxix;
1091   AV     *argarray = MUTABLE_AV(su_at_underscore(sud->callback));
1092
1093   /* We have to fix the pad entry for @_ in the original callback because it
1094    * may have been reified. */
1095   if (AvREAL(argarray)) {
1096    const I32 fill = AvFILLp(argarray);
1097    SvREFCNT_dec(argarray);
1098    argarray = newAV();
1099    AvREAL_off(argarray);
1100    AvREIFY_on(argarray);
1101    av_extend(argarray, fill);
1102    su_at_underscore(sud->callback) = MUTABLE_SV(argarray);
1103   } else {
1104    CLEAR_ARGARRAY(argarray);
1105   }
1106
1107   /* If the old cv member is our renamed CV, it means that this place has been
1108    * reached without a goto() happening, and the old argarray member is
1109    * actually our fake argarray. Destroy it properly in that case. */
1110   if (cx->blk_sub.cv == sud->renamed) {
1111    SvREFCNT_dec(cx->blk_sub.argarray);
1112    cx->blk_sub.argarray = argarray;
1113   }
1114
1115   CvDEPTH(sud->callback)--;
1116   SvREFCNT_dec(sud->callback);
1117  }
1118
1119  /* Free the renamed CV. We must do it ourselves so that we can force the
1120   * depth to be 0, or perl would complain about it being "still in use".
1121   * But we *know* that it cannot be so. */
1122  if (sud->renamed) {
1123   CvDEPTH(sud->renamed)   = 0;
1124   CvPADLIST(sud->renamed) = NULL;
1125   SvREFCNT_dec(sud->renamed);
1126  }
1127
1128  CATCH_SET(sud->old_catch);
1129
1130  SU_UPLEVEL_RESTORE(op);
1131
1132  /* stack_grow() wants PL_curstack so restore the old stack first */
1133  if (PL_curstackinfo == si) {
1134   PL_curstack = cur->si_stack;
1135   if (sud->old_mainstack)
1136    SU_UPLEVEL_RESTORE(mainstack);
1137   SU_UPLEVEL_RESTORE(curstackinfo);
1138
1139   if (sud->died) {
1140    CV *target = sud->target;
1141    I32 levels = 0, i;
1142
1143    /* When we die, the depth of the target CV is not updated because of the
1144     * stack switcheroo. So we have to look at all the frames between the
1145     * uplevel call and the catch block to count how many call frames to the
1146     * target CV were skipped. */
1147    for (i = cur->si_cxix; i > sud->cxix; i--) {
1148     register const PERL_CONTEXT *cx = cxstack + i;
1149
1150     if (CxTYPE(cx) == CXt_SUB) {
1151      if (cx->blk_sub.cv == target)
1152       ++levels;
1153     }
1154    }
1155
1156    /* If we died, the replacement stack was already unwinded to the first
1157     * eval frame, and all the contexts down there were popped. We don't have
1158     * to pop manually any context of the original stack, because they must
1159     * have been in the replacement stack as well (since the second was copied
1160     * from the first). Thus we only have to make sure the original stack index
1161     * points to the context just below the first eval scope under the target
1162     * frame. */
1163    for (; i >= 0; i--) {
1164     register const PERL_CONTEXT *cx = cxstack + i;
1165
1166     switch (CxTYPE(cx)) {
1167      case CXt_SUB:
1168       if (cx->blk_sub.cv == target)
1169        ++levels;
1170       break;
1171      case CXt_EVAL:
1172       goto found_it;
1173       break;
1174      default:
1175       break;
1176     }
1177    }
1178
1179 found_it:
1180    CvDEPTH(target) = sud->target_depth - levels;
1181    PL_curstackinfo->si_cxix = i - 1;
1182
1183 #if !SU_HAS_PERL(5, 13, 1)
1184    /* Since $@ was maybe localized between the target frame and the uplevel
1185     * call, we forcefully flush the save stack to get rid of it and then
1186     * reset $@ to its proper value. Note that the the call to
1187     * su_uplevel_restore() must happen before the "reset $@" item of the save
1188     * stack is processed, as uplevel was called after the localization.
1189     * Andrew's changes to how $@ was handled, which were mainly integrated
1190     * between perl 5.13.0 and 5.13.1, fixed this. */
1191    if (ERRSV && SvTRUE(ERRSV)) {
1192     register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1193     SV *errsv = SvREFCNT_inc(ERRSV);
1194     PL_scopestack_ix = cx->blk_oldscopesp;
1195     leave_scope(PL_scopestack[PL_scopestack_ix]);
1196     sv_setsv(ERRSV, errsv);
1197     SvREFCNT_dec(errsv);
1198    }
1199 #endif
1200   }
1201  }
1202
1203  SU_UPLEVEL_RESTORE(curcop);
1204
1205  SvREFCNT_dec(sud->target);
1206
1207  PL_stack_base = AvARRAY(cur->si_stack);
1208  PL_stack_sp   = PL_stack_base + AvFILLp(cur->si_stack);
1209  PL_stack_max  = PL_stack_base + AvMAX(cur->si_stack);
1210
1211  /* When an exception is thrown from the uplevel'd subroutine,
1212   * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed
1213   * die_where() in more recent perls), which has the sad habit of keeping a
1214   * pointer to the current context frame across this call. This means that we
1215   * can't free the temporary context stack we used for the uplevel call right
1216   * now, or that pointer upwards would point to garbage. */
1217 #if SU_HAS_PERL(5, 13, 7)
1218  /* This issue has been fixed in perl with commit 8f89e5a9, which was made
1219   * public in perl 5.13.7. */
1220  su_uplevel_storage_delete(sud);
1221 #else
1222  /* Otherwise, we just enqueue it back in the global storage list. */
1223  {
1224   dMY_CXT;
1225
1226   MY_CXT.uplevel_storage.top  = sud->next;
1227   sud->next = MY_CXT.uplevel_storage.root;
1228   MY_CXT.uplevel_storage.root = sud;
1229   MY_CXT.uplevel_storage.count++;
1230  }
1231 #endif
1232
1233  return;
1234 }
1235
1236 STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
1237 #define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
1238  dVAR;
1239  CV *cv;
1240
1241  cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1242
1243  CvFLAGS(cv)  = CvFLAGS(proto);
1244 #ifdef CVf_CVGV_RC
1245  CvFLAGS(cv) &= ~CVf_CVGV_RC;
1246 #endif
1247  CvDEPTH(cv)  = CvDEPTH(proto);
1248 #ifdef USE_ITHREADS
1249  CvFILE(cv)   = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto));
1250 #else
1251  CvFILE(cv)   = CvFILE(proto);
1252 #endif
1253
1254  CvGV_set(cv, gv);
1255  CvSTASH_set(cv, CvSTASH(proto));
1256  /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
1257   * stashes. CvSTASH_set() started to do it as well with commit c68d95645
1258   * (which was part of perl 5.13.7). */
1259 #if SU_HAS_PERL(5, 13, 3) && !SU_HAS_PERL(5, 13, 7)
1260  if (CvSTASH(proto))
1261   Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
1262 #endif
1263
1264  if (CvISXSUB(proto)) {
1265   CvXSUB(cv)       = CvXSUB(proto);
1266   CvXSUBANY(cv)    = CvXSUBANY(proto);
1267  } else {
1268   OP_REFCNT_LOCK;
1269   CvROOT(cv)       = OpREFCNT_inc(CvROOT(proto));
1270   OP_REFCNT_UNLOCK;
1271   CvSTART(cv)      = CvSTART(proto);
1272  }
1273  CvOUTSIDE(cv)     = CvOUTSIDE(proto);
1274 #ifdef CVf_WEAKOUTSIDE
1275  if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
1276 #endif
1277   SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
1278  CvPADLIST(cv)     = CvPADLIST(proto);
1279 #ifdef CvOUTSIDE_SEQ
1280  CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1281 #endif
1282
1283  if (SvPOK(proto))
1284   sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1285
1286 #ifdef CvCONST
1287  if (CvCONST(cv))
1288   CvCONST_off(cv);
1289 #endif
1290
1291  return cv;
1292 }
1293
1294 STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
1295 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1296  su_uplevel_ud *sud;
1297  const PERL_CONTEXT *cx = cxstack + cxix;
1298  PERL_SI *si;
1299  PERL_SI *cur = PL_curstackinfo;
1300  SV **old_stack_sp;
1301  CV  *target;
1302  CV  *renamed;
1303  UNOP sub_op;
1304  I32  gimme;
1305  I32  old_mark, new_mark;
1306  I32  ret;
1307  dSP;
1308
1309  ENTER;
1310
1311  gimme = GIMME_V;
1312  /* Make PL_stack_sp point just before the CV. */
1313  PL_stack_sp -= args + 1;
1314  old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1315  SPAGAIN;
1316
1317  sud = su_uplevel_storage_new();
1318
1319  sud->cxix     = cxix;
1320  sud->died     = 1;
1321  sud->callback = NULL;
1322  sud->renamed  = NULL;
1323  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1324
1325  si = sud->si;
1326
1327  si->si_type    = cur->si_type;
1328  si->si_next    = NULL;
1329  si->si_prev    = cur->si_prev;
1330 #ifdef DEBUGGING
1331  si->si_markoff = cx->blk_oldmarksp;
1332 #endif
1333
1334  /* Allocate enough space for all the elements of the original stack up to the
1335   * target context, plus the forthcoming arguments. */
1336  new_mark = cx->blk_oldsp;
1337  av_extend(si->si_stack, new_mark + 1 + args + 1);
1338  Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1339  AvFILLp(si->si_stack) = new_mark;
1340  SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1341
1342  /* Specialized SWITCHSTACK() */
1343  PL_stack_base = AvARRAY(si->si_stack);
1344  old_stack_sp  = PL_stack_sp;
1345  PL_stack_sp   = PL_stack_base + AvFILLp(si->si_stack);
1346  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
1347  SPAGAIN;
1348
1349  /* Copy the context stack up to the context just below the target. */
1350  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1351  if (si->si_cxmax < cxix) {
1352   /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1353   si->si_cxmax = (cxix < 4) ? 4 : cxix;
1354   Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1355  }
1356  Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1357  SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1358
1359  target            = cx->blk_sub.cv;
1360  sud->target       = (CV *) SvREFCNT_inc(target);
1361  sud->target_depth = CvDEPTH(target);
1362
1363  /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1364   * run-time implication, since PL_curcop will be overwritten as soon as we
1365   * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1366   * make it point to the blk_oldcop for the target frame, so that caller()
1367   * reports the right file name, line number and lexical hints. */
1368  SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1369  /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1370   * this point. Don't reset PL_curpm either, we want the most recent matches. */
1371
1372  SU_UPLEVEL_SAVE(curstackinfo, si);
1373  /* If those two are equal, we need to fool POPSTACK_TO() */
1374  if (PL_mainstack == PL_curstack)
1375   SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1376  else
1377   sud->old_mainstack = NULL;
1378  PL_curstack = si->si_stack;
1379
1380  renamed      = su_cv_clone(callback, CvGV(target));
1381  sud->renamed = renamed;
1382
1383  PUSHMARK(SP);
1384  /* Both SP and old_stack_sp point just before the CV. */
1385  Copy(old_stack_sp + 2, SP + 1, args, SV *);
1386  SP += args;
1387  PUSHs((SV *) renamed);
1388  PUTBACK;
1389
1390  Zero(&sub_op, 1, UNOP);
1391  sub_op.op_type  = OP_ENTERSUB;
1392  sub_op.op_next  = NULL;
1393  sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1394  if (PL_DBsub)
1395   sub_op.op_flags |= OPpENTERSUB_DB;
1396
1397  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1398
1399  sud->old_runops = PL_runops;
1400
1401  sud->old_catch = CATCH_GET;
1402  CATCH_SET(TRUE);
1403
1404  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
1405   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
1406
1407   /* If pp_entersub() returns a non-null OP, it means that the callback is not
1408    * an XSUB. */
1409
1410   sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
1411   CvDEPTH(callback)++;
1412
1413   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1414    /* The call to pp_entersub() has saved the current @_ (in XS terms,
1415     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1416     * with what we put on the stack. But we want to fake up the same arguments
1417     * as the ones in use at the context we uplevel to, so we replace the
1418     * argarray with an unreal copy of the original @_. */
1419    AV *av = newAV();
1420    AvREAL_off(av);
1421    AvREIFY_on(av);
1422    av_extend(av, AvMAX(cx->blk_sub.argarray));
1423    AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1424    Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1425    sub_cx->blk_sub.argarray = av;
1426   } else {
1427    SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
1428   }
1429
1430   if (su_uplevel_goto_static(CvROOT(renamed))) {
1431    if (PL_runops != Perl_runops_standard) {
1432     if (PL_runops == Perl_runops_debug) {
1433      if (PL_debug)
1434       croak("uplevel() can't execute code that calls goto when debugging flags are set");
1435     } else if (PL_runops != su_uplevel_goto_runops)
1436      croak("uplevel() can't execute code that calls goto with a custom runloop");
1437    }
1438
1439    PL_runops = su_uplevel_goto_runops;
1440   }
1441
1442   CALLRUNOPS(aTHX);
1443  }
1444
1445  sud->died = 0;
1446
1447  ret = PL_stack_sp - (PL_stack_base + new_mark);
1448  if (ret > 0) {
1449   AV *old_stack = sud->old_curstackinfo->si_stack;
1450
1451   if (old_mark + ret > AvMAX(old_stack)) {
1452    /* Specialized EXTEND(old_sp, ret) */
1453    av_extend(old_stack, old_mark + ret + 1);
1454    old_stack_sp = AvARRAY(old_stack) + old_mark;
1455   }
1456
1457   Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1458   PL_stack_sp        += ret;
1459   AvFILLp(old_stack) += ret;
1460  }
1461
1462  LEAVE;
1463
1464  return ret;
1465 }
1466
1467 /* --- Interpreter setup/teardown ------------------------------------------ */
1468
1469 STATIC void su_teardown(pTHX_ void *param) {
1470  su_uplevel_ud *cur;
1471  dMY_CXT;
1472
1473  cur = MY_CXT.uplevel_storage.root;
1474  if (cur) {
1475   su_uplevel_ud *prev;
1476   do {
1477    prev = cur;
1478    cur  = prev->next;
1479    su_uplevel_ud_delete(prev);
1480   } while (cur);
1481  }
1482
1483  return;
1484 }
1485
1486 STATIC void su_setup(pTHX) {
1487 #define su_setup() su_setup(aTHX)
1488  MY_CXT_INIT;
1489
1490  MY_CXT.stack_placeholder = NULL;
1491
1492  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
1493  Zero(&(MY_CXT.unwind_storage.return_op), 1, LISTOP);
1494  MY_CXT.unwind_storage.return_op.op_type   = OP_RETURN;
1495  MY_CXT.unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
1496
1497  Zero(&(MY_CXT.unwind_storage.proxy_op), 1, OP);
1498  MY_CXT.unwind_storage.proxy_op.op_type   = OP_STUB;
1499  MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL;
1500
1501  MY_CXT.uplevel_storage.top   = NULL;
1502  MY_CXT.uplevel_storage.root  = NULL;
1503  MY_CXT.uplevel_storage.count = 0;
1504
1505  call_atexit(su_teardown, NULL);
1506
1507  return;
1508 }
1509
1510 /* --- XS ------------------------------------------------------------------ */
1511
1512 #if SU_HAS_PERL(5, 8, 9)
1513 # define SU_SKIP_DB_MAX 2
1514 #else
1515 # define SU_SKIP_DB_MAX 3
1516 #endif
1517
1518 /* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
1519  * followed by a DB sub */
1520
1521 #define SU_SKIP_DB(C) \
1522  STMT_START {         \
1523   I32 skipped = 0;    \
1524   PERL_CONTEXT *base = cxstack;      \
1525   PERL_CONTEXT *cx   = base + (C);   \
1526   while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
1527    --cx, ++skipped;                  \
1528   if (cx >= base && (C) > skipped) { \
1529    switch (CxTYPE(cx)) {  \
1530     case CXt_SUB:         \
1531      if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
1532       (C) -= skipped + 1; \
1533       break;              \
1534     default:              \
1535      break;               \
1536    }                      \
1537   }                       \
1538  } STMT_END
1539
1540 #define SU_GET_CONTEXT(A, B)   \
1541  STMT_START {                  \
1542   if (items > A) {             \
1543    SV *csv = ST(B);            \
1544    if (!SvOK(csv))             \
1545     goto default_cx;           \
1546    cxix = SvIV(csv);           \
1547    if (cxix < 0)               \
1548     cxix = 0;                  \
1549    else if (cxix > cxstack_ix) \
1550     cxix = cxstack_ix;         \
1551   } else {                     \
1552 default_cx:                    \
1553    cxix = cxstack_ix;          \
1554    if (PL_DBsub)               \
1555     SU_SKIP_DB(cxix);          \
1556   }                            \
1557  } STMT_END
1558
1559 #define SU_GET_LEVEL(A, B) \
1560  STMT_START {              \
1561   level = 0;               \
1562   if (items > 0) {         \
1563    SV *lsv = ST(B);        \
1564    if (SvOK(lsv)) {        \
1565     level = SvIV(lsv);     \
1566     if (level < 0)         \
1567      level = 0;            \
1568    }                       \
1569   }                        \
1570  } STMT_END
1571
1572 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
1573
1574 XS(XS_Scope__Upper_unwind) {
1575 #ifdef dVAR
1576  dVAR; dXSARGS;
1577 #else
1578  dXSARGS;
1579 #endif
1580  dMY_CXT;
1581  I32 cxix;
1582
1583  PERL_UNUSED_VAR(cv); /* -W */
1584  PERL_UNUSED_VAR(ax); /* -Wall */
1585
1586  SU_GET_CONTEXT(0, items - 1);
1587  do {
1588   PERL_CONTEXT *cx = cxstack + cxix;
1589   switch (CxTYPE(cx)) {
1590    case CXt_SUB:
1591     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1592      continue;
1593    case CXt_EVAL:
1594    case CXt_FORMAT:
1595     MY_CXT.unwind_storage.cxix  = cxix;
1596     MY_CXT.unwind_storage.items = items;
1597     /* pp_entersub will want to sanitize the stack after returning from there
1598      * Screw that, we're insane */
1599     if (GIMME_V == G_SCALAR) {
1600      MY_CXT.unwind_storage.savesp = PL_stack_sp;
1601      /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
1602      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
1603     } else {
1604      MY_CXT.unwind_storage.savesp = NULL;
1605     }
1606     SAVEDESTRUCTOR_X(su_unwind, NULL);
1607     return;
1608    default:
1609     break;
1610   }
1611  } while (--cxix >= 0);
1612  croak("Can't return outside a subroutine");
1613 }
1614
1615 MODULE = Scope::Upper            PACKAGE = Scope::Upper
1616
1617 PROTOTYPES: ENABLE
1618
1619 BOOT:
1620 {
1621  HV *stash;
1622
1623  stash = gv_stashpv(__PACKAGE__, 1);
1624  newCONSTSUB(stash, "TOP",           newSViv(0));
1625  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
1626
1627  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
1628
1629  su_setup();
1630 }
1631
1632 #if SU_THREADSAFE
1633
1634 void
1635 CLONE(...)
1636 PROTOTYPE: DISABLE
1637 PPCODE:
1638  {
1639   MY_CXT_CLONE;
1640   MY_CXT.uplevel_storage.top   = NULL;
1641   MY_CXT.uplevel_storage.root  = NULL;
1642   MY_CXT.uplevel_storage.count = 0;
1643  }
1644  XSRETURN(0);
1645
1646 #endif /* SU_THREADSAFE */
1647
1648 void
1649 HERE()
1650 PROTOTYPE:
1651 PREINIT:
1652  I32 cxix = cxstack_ix;
1653 PPCODE:
1654  if (PL_DBsub)
1655   SU_SKIP_DB(cxix);
1656  EXTEND(SP, 1);
1657  mPUSHi(cxix);
1658  XSRETURN(1);
1659
1660 void
1661 UP(...)
1662 PROTOTYPE: ;$
1663 PREINIT:
1664  I32 cxix;
1665 PPCODE:
1666  SU_GET_CONTEXT(0, 0);
1667  if (--cxix < 0)
1668   cxix = 0;
1669  if (PL_DBsub)
1670   SU_SKIP_DB(cxix);
1671  EXTEND(SP, 1);
1672  mPUSHi(cxix);
1673  XSRETURN(1);
1674
1675 void
1676 SUB(...)
1677 PROTOTYPE: ;$
1678 PREINIT:
1679  I32 cxix;
1680 PPCODE:
1681  SU_GET_CONTEXT(0, 0);
1682  EXTEND(SP, 1);
1683  for (; cxix >= 0; --cxix) {
1684   PERL_CONTEXT *cx = cxstack + cxix;
1685   switch (CxTYPE(cx)) {
1686    default:
1687     continue;
1688    case CXt_SUB:
1689     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1690      continue;
1691     mPUSHi(cxix);
1692     XSRETURN(1);
1693   }
1694  }
1695  XSRETURN_UNDEF;
1696
1697 void
1698 EVAL(...)
1699 PROTOTYPE: ;$
1700 PREINIT:
1701  I32 cxix;
1702 PPCODE:
1703  SU_GET_CONTEXT(0, 0);
1704  EXTEND(SP, 1);
1705  for (; cxix >= 0; --cxix) {
1706   PERL_CONTEXT *cx = cxstack + cxix;
1707   switch (CxTYPE(cx)) {
1708    default:
1709     continue;
1710    case CXt_EVAL:
1711     mPUSHi(cxix);
1712     XSRETURN(1);
1713   }
1714  }
1715  XSRETURN_UNDEF;
1716
1717 void
1718 SCOPE(...)
1719 PROTOTYPE: ;$
1720 PREINIT:
1721  I32 cxix, level;
1722 PPCODE:
1723  SU_GET_LEVEL(0, 0);
1724  cxix = cxstack_ix;
1725  if (PL_DBsub) {
1726   SU_SKIP_DB(cxix);
1727   while (cxix > 0) {
1728    if (--level < 0)
1729     break;
1730    --cxix;
1731    SU_SKIP_DB(cxix);
1732   }
1733  } else {
1734   cxix -= level;
1735   if (cxix < 0)
1736    cxix = 0;
1737  }
1738  EXTEND(SP, 1);
1739  mPUSHi(cxix);
1740  XSRETURN(1);
1741
1742 void
1743 CALLER(...)
1744 PROTOTYPE: ;$
1745 PREINIT:
1746  I32 cxix, level;
1747 PPCODE:
1748  SU_GET_LEVEL(0, 0);
1749  for (cxix = cxstack_ix; cxix > 0; --cxix) {
1750   PERL_CONTEXT *cx = cxstack + cxix;
1751   switch (CxTYPE(cx)) {
1752    case CXt_SUB:
1753     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1754      continue;
1755    case CXt_EVAL:
1756    case CXt_FORMAT:
1757     if (--level < 0)
1758      goto done;
1759     break;
1760   }
1761  }
1762 done:
1763  EXTEND(SP, 1);
1764  mPUSHi(cxix);
1765  XSRETURN(1);
1766
1767 void
1768 want_at(...)
1769 PROTOTYPE: ;$
1770 PREINIT:
1771  I32 cxix;
1772 PPCODE:
1773  SU_GET_CONTEXT(0, 0);
1774  EXTEND(SP, 1);
1775  while (cxix > 0) {
1776   PERL_CONTEXT *cx = cxstack + cxix--;
1777   switch (CxTYPE(cx)) {
1778    case CXt_SUB:
1779    case CXt_EVAL:
1780    case CXt_FORMAT: {
1781     I32 gimme = cx->blk_gimme;
1782     switch (gimme) {
1783      case G_VOID:   XSRETURN_UNDEF; break;
1784      case G_SCALAR: XSRETURN_NO;    break;
1785      case G_ARRAY:  XSRETURN_YES;   break;
1786     }
1787     break;
1788    }
1789   }
1790  }
1791  XSRETURN_UNDEF;
1792
1793 void
1794 reap(SV *hook, ...)
1795 PROTOTYPE: &;$
1796 PREINIT:
1797  I32 cxix;
1798  su_ud_reap *ud;
1799 CODE:
1800  SU_GET_CONTEXT(1, 1);
1801  Newx(ud, 1, su_ud_reap);
1802  SU_UD_ORIGIN(ud)  = NULL;
1803  SU_UD_HANDLER(ud) = su_reap;
1804  ud->cb = newSVsv(hook);
1805  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1806
1807 void
1808 localize(SV *sv, SV *val, ...)
1809 PROTOTYPE: $$;$
1810 PREINIT:
1811  I32 cxix;
1812  I32 size;
1813  su_ud_localize *ud;
1814 CODE:
1815  SU_GET_CONTEXT(2, 2);
1816  Newx(ud, 1, su_ud_localize);
1817  SU_UD_ORIGIN(ud)  = NULL;
1818  SU_UD_HANDLER(ud) = su_localize;
1819  size = su_ud_localize_init(ud, sv, val, NULL);
1820  su_init(ud, cxix, size);
1821
1822 void
1823 localize_elem(SV *sv, SV *elem, SV *val, ...)
1824 PROTOTYPE: $$$;$
1825 PREINIT:
1826  I32 cxix;
1827  I32 size;
1828  su_ud_localize *ud;
1829 CODE:
1830  if (SvTYPE(sv) >= SVt_PVGV)
1831   croak("Can't infer the element localization type from a glob and the value");
1832  SU_GET_CONTEXT(3, 3);
1833  Newx(ud, 1, su_ud_localize);
1834  SU_UD_ORIGIN(ud)  = NULL;
1835  SU_UD_HANDLER(ud) = su_localize;
1836  size = su_ud_localize_init(ud, sv, val, elem);
1837  if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
1838   SU_UD_LOCALIZE_FREE(ud);
1839   croak("Can't localize an element of something that isn't an array or a hash");
1840  }
1841  su_init(ud, cxix, size);
1842
1843 void
1844 localize_delete(SV *sv, SV *elem, ...)
1845 PROTOTYPE: $$;$
1846 PREINIT:
1847  I32 cxix;
1848  I32 size;
1849  su_ud_localize *ud;
1850 CODE:
1851  SU_GET_CONTEXT(2, 2);
1852  Newx(ud, 1, su_ud_localize);
1853  SU_UD_ORIGIN(ud)  = NULL;
1854  SU_UD_HANDLER(ud) = su_localize;
1855  size = su_ud_localize_init(ud, sv, NULL, elem);
1856  su_init(ud, cxix, size);
1857
1858 void
1859 uplevel(SV *code, ...)
1860 PROTOTYPE: &@
1861 PREINIT:
1862  I32 cxix, ret, args = 0;
1863 PPCODE:
1864  if (SvROK(code))
1865   code = SvRV(code);
1866  if (SvTYPE(code) < SVt_PVCV)
1867   croak("First argument to uplevel must be a code reference");
1868  SU_GET_CONTEXT(1, items - 1);
1869  do {
1870   PERL_CONTEXT *cx = cxstack + cxix;
1871   switch (CxTYPE(cx)) {
1872    case CXt_EVAL:
1873     croak("Can't uplevel to an eval frame");
1874    case CXt_FORMAT:
1875     croak("Can't uplevel to a format frame");
1876    case CXt_SUB:
1877     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1878      continue;
1879     if (items > 1) {
1880      PL_stack_sp--;
1881      args = items - 2;
1882     }
1883     /* su_uplevel() takes care of extending the stack if needed. */
1884     ret = su_uplevel((CV *) code, cxix, args);
1885     XSRETURN(ret);
1886    default:
1887     break;
1888   }
1889  } while (--cxix >= 0);
1890  croak("Can't uplevel outside a subroutine");