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