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