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 su_uplevel_ud *su_uplevel_storage_new(pTHX) {
 921 #define su_uplevel_storage_new() su_uplevel_storage_new(aTHX)
 922  su_uplevel_ud *sud;
 923  dMY_CXT;
 924
 925  sud = MY_CXT.uplevel_storage.root;
 926  if (sud) {
 927   MY_CXT.uplevel_storage.root = sud->next;
 928   MY_CXT.uplevel_storage.count--;
 929  } else {
 930   sud = su_uplevel_ud_new();
 931  }
 932
 933  return sud;
 934 }
 935
 936 STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
 937 #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
 938  dMY_CXT;
 939
 940  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
 941   su_uplevel_ud_delete(sud);
 942  } else {
 943   sud->next = MY_CXT.uplevel_storage.root;
 944   MY_CXT.uplevel_storage.root = sud;
 945   MY_CXT.uplevel_storage.count++;
 946  }
 947 }
 948
 949 #define SU_HAS_EXT_MAGIC SU_HAS_PERL(5, 8, 0)
 950
 951 #if SU_HAS_EXT_MAGIC
 952
 953 STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
 954  su_uplevel_storage_delete((su_uplevel_ud *) mg->mg_ptr);
 955
 956  return 0;
 957 }
 958
 959 STATIC MGVTBL su_uplevel_restore_vtbl = {
 960  0,
 961  0,
 962  0,
 963  0,
 964  su_uplevel_restore_free
 965 };
 966
 967 #endif /* SU_HAS_EXT_MAGIC */
 968
 969 STATIC void su_uplevel_restore(pTHX_ void *sus_) {
 970  su_uplevel_ud *sud = sus_;
 971  PERL_SI *cur = sud->old_curstackinfo;
 972  PERL_SI *si  = sud->si;
 973
 974  /* When we reach this place, POPSUB has already been called (with our fake
 975   * argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
 976   * before uplevel). argarray is either the fake AV we created in su_uplevel()
 977   * or some empty replacement POPSUB creates when @_ is reified. In both cases
 978   * we have to destroy it before the context stack is swapped back to its
 979   * original state. */
 980  SvREFCNT_dec(cxstack[sud->cxix].blk_sub.argarray);
 981
 982  CATCH_SET(sud->old_catch);
 983
 984  SvREFCNT_dec(sud->cloned_cv);
 985
 986  SU_UPLEVEL_RESTORE(op);
 987
 988  /* stack_grow() wants PL_curstack so restore the old stack first */
 989  if (PL_curstackinfo == si) {
 990   PL_curstack = cur->si_stack;
 991   if (sud->old_mainstack)
 992    SU_UPLEVEL_RESTORE(mainstack);
 993   SU_UPLEVEL_RESTORE(curstackinfo);
 994
 995   if (sud->died) {
 996    CV *target_cv = sud->target;
 997    I32 levels = 0, i;
 998
 999    /* When we die, the depth of the target CV is not updated because of the
1000     * stack switcheroo. So we have to look at all the frames between the
1001     * uplevel call and the catch block to count how many call frames to the
1002     * target CV were skipped. */
1003    for (i = cur->si_cxix; i > sud->cxix; i--) {
1004     register const PERL_CONTEXT *cx = cxstack + i;
1005
1006     if (CxTYPE(cx) == CXt_SUB) {
1007      if (cx->blk_sub.cv == target_cv)
1008       ++levels;
1009     }
1010    }
1011
1012    /* If we died, the replacement stack was already unwinded to the first
1013     * eval frame, and all the contexts down there were popped. We don't have
1014     * to pop manually any context of the original stack, because they must
1015     * have been in the replacement stack as well (since the second was copied
1016     * from the first). Thus we only have to make sure the original stack index
1017     * points to the context just below the first eval scope under the target
1018     * frame. */
1019    for (; i >= 0; i--) {
1020     register const PERL_CONTEXT *cx = cxstack + i;
1021
1022     switch (CxTYPE(cx)) {
1023      case CXt_SUB:
1024       if (cx->blk_sub.cv == target_cv)
1025        ++levels;
1026       break;
1027      case CXt_EVAL:
1028       goto found_it;
1029       break;
1030      default:
1031       break;
1032     }
1033    }
1034
1035 found_it:
1036    CvDEPTH(target_cv) = sud->old_depth - levels;
1037    PL_curstackinfo->si_cxix = i - 1;
1038
1039 #if !SU_HAS_PERL(5, 13, 1)
1040    /* Since $@ was maybe localized between the target frame and the uplevel
1041     * call, we forcefully flush the save stack to get rid of it and then
1042     * reset $@ to its proper value. Note that the the call to
1043     * su_uplevel_restore() must happen before the "reset $@" item of the save
1044     * stack is processed, as uplevel was called after the localization.
1045     * Andrew's changes to how $@ was handled, which were mainly integrated
1046     * between perl 5.13.0 and 5.13.1, fixed this. */
1047    if (ERRSV && SvTRUE(ERRSV)) {
1048     register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1049     SV *errsv = SvREFCNT_inc(ERRSV);
1050     PL_scopestack_ix = cx->blk_oldscopesp;
1051     leave_scope(PL_scopestack[PL_scopestack_ix]);
1052     sv_setsv(ERRSV, errsv);
1053     SvREFCNT_dec(errsv);
1054    }
1055 #endif
1056   }
1057  }
1058
1059  SU_UPLEVEL_RESTORE(curcop);
1060
1061  SvREFCNT_dec(sud->target);
1062
1063  PL_stack_base = AvARRAY(cur->si_stack);
1064  PL_stack_sp   = PL_stack_base + AvFILLp(cur->si_stack);
1065  PL_stack_max  = PL_stack_base + AvMAX(cur->si_stack);
1066
1067  /* When an exception is thrown from the uplevel'd subroutine,
1068   * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed
1069   * die_where() in more recent perls), which has the sad habit of keeping a
1070   * pointer to the current context frame across this call. This means that we
1071   * can't free the temporary context stack we used for the uplevel call right
1072   * now, or that pointer upwards would point to garbage. */
1073 #if SU_HAS_PERL(5, 13, 7)
1074  /* This issue has been fixed in perl with commit 8f89e5a9, which was made
1075   * public in perl 5.13.7. */
1076  su_uplevel_storage_delete(sud);
1077 #elif SU_HAS_EXT_MAGIC
1078  /* If 'ext' magic is available, we work around this by attaching the state
1079   * data to a scalar that will be freed "soon". */
1080  {
1081   SV *sv = sv_newmortal();
1082
1083   sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
1084                         (const char *) sud, 0);
1085  }
1086 #else
1087  /* Otherwise, we just enqueue it back in the global storage list. */
1088  {
1089   dMY_CXT;
1090
1091   sud->next = MY_CXT.uplevel_storage.root;
1092   MY_CXT.uplevel_storage.root = sud;
1093   MY_CXT.uplevel_storage.count++;
1094  }
1095 #endif
1096
1097  return;
1098 }
1099
1100 STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
1101 #define su_cv_clone(C) su_cv_clone(aTHX_ (C))
1102  CV *new_cv;
1103
1104  /* Starting from commit b5c19bd7 (first made public with perl 5.9.0),
1105   * cv_clone() has an assert that checks whether CvDEPTH(CvOUTSIDE(proto)) > 0.
1106   * If this perl has DEBUGGING enabled, we have to fool cv_clone() with a
1107   * little dance. */
1108 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1109  I32 old_depth;
1110  CV *outside = CvOUTSIDE(old_cv);
1111
1112  if (outside && CvCLONE(outside) && !CvCLONED(outside))
1113   outside = find_runcv(NULL);
1114  old_depth = CvDEPTH(outside);
1115  if (!old_depth)
1116   CvDEPTH(outside) = 1;
1117 #endif
1118
1119  new_cv = cv_clone(old_cv);
1120
1121 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1122  CvDEPTH(outside) = old_depth;
1123 #endif
1124
1125  /* Still from commit b5c19bd7, cv_clone() is no longer able to clone named
1126   * subs propery. With this commit, pad_findlex() stores the parent index of a
1127   * fake pad entry in the NV slot of the corresponding pad name SV, but only
1128   * for anonymous subs (since named subs aren't supposed to be cloned in pure
1129   * Perl land). To fix this, we just manually relink the new fake pad entries
1130   * to the new ones.
1131   * For some reason perl 5.8 crashes too without this, supposedly because of
1132   * other closure bugs. Hence we enable it everywhere. */
1133  if (!CvCLONE(old_cv)) {
1134   const AV  *old_padname = (const AV *)  AvARRAY(CvPADLIST(old_cv))[0];
1135   AV        *old_pad     = (AV *)        AvARRAY(CvPADLIST(old_cv))[1];
1136   AV        *new_pad     = (AV *)        AvARRAY(CvPADLIST(new_cv))[1];
1137   const SV **old_aryname = (const SV **) AvARRAY(old_padname);
1138   SV       **old_ary     = AvARRAY(old_pad);
1139   SV       **new_ary     = AvARRAY(new_pad);
1140   I32 fname = AvFILLp(old_padname);
1141   I32 fpad  = AvFILLp(old_pad);
1142   I32 ix;
1143
1144   for (ix = fpad; ix > 0; ix--) {
1145    const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
1146
1147    if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
1148     SvREFCNT_dec(new_ary[ix]);
1149     new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
1150    }
1151   }
1152  }
1153
1154  return new_cv;
1155 }
1156
1157 STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
1158 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1159  su_uplevel_ud *sud;
1160  const PERL_CONTEXT *cx = cxstack + cxix;
1161  PERL_SI *si;
1162  PERL_SI *cur = PL_curstackinfo;
1163  SV **old_stack_sp;
1164  CV  *target_cv;
1165  UNOP sub_op;
1166  I32  marksize;
1167  I32  gimme;
1168  I32  old_mark, new_mark;
1169  I32  ret;
1170  dSP;
1171
1172  ENTER;
1173
1174  gimme = GIMME_V;
1175  /* Make PL_stack_sp point just before the CV. */
1176  PL_stack_sp -= args + 1;
1177  old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1178  SPAGAIN;
1179
1180  sud = su_uplevel_storage_new();
1181  si  = sud->si;
1182
1183  sud->cxix = cxix;
1184  sud->died = 1;
1185  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1186
1187  si->si_type = cur->si_type;
1188  si->si_next = NULL;
1189  si->si_prev = cur->si_prev;
1190
1191  /* Allocate enough space for all the elements of the original stack up to the
1192   * target context, plus the forthcoming arguments. */
1193  new_mark = cx->blk_oldsp;
1194  av_extend(si->si_stack, new_mark + 1 + args + 1);
1195  Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1196  AvFILLp(si->si_stack) = new_mark;
1197  SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1198
1199  /* Specialized SWITCHSTACK() */
1200  PL_stack_base = AvARRAY(si->si_stack);
1201  old_stack_sp  = PL_stack_sp;
1202  PL_stack_sp   = PL_stack_base + AvFILLp(si->si_stack);
1203  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
1204  SPAGAIN;
1205
1206 #ifdef DEBUGGING
1207  si->si_markoff = cx->blk_oldmarksp;
1208 #endif
1209
1210  /* Copy the context stack up to the context just below the target. */
1211  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1212  if (si->si_cxmax < cxix) {
1213   /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1214   si->si_cxmax = (cxix < 4) ? 4 : cxix;
1215   Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1216  }
1217  Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1218  SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1219
1220  target_cv      = cx->blk_sub.cv;
1221  sud->target    = (CV *) SvREFCNT_inc(target_cv);
1222  sud->old_depth = CvDEPTH(target_cv);
1223
1224  /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1225   * run-time implication, since PL_curcop will be overwritten as soon as we
1226   * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1227   * make it point to the blk_oldcop for the target frame, so that caller()
1228   * reports the right file name, line number and lexical hints. */
1229  SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1230  /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1231   * this point. Don't reset PL_curpm either, we want the most recent matches. */
1232
1233  SU_UPLEVEL_SAVE(curstackinfo, si);
1234  /* If those two are equal, we need to fool POPSTACK_TO() */
1235  if (PL_mainstack == PL_curstack)
1236   SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1237  else
1238   sud->old_mainstack = NULL;
1239  PL_curstack = si->si_stack;
1240
1241  cv = su_cv_clone(cv);
1242  sud->cloned_cv = cv;
1243  CvGV_set(cv, CvGV(target_cv));
1244
1245  PUSHMARK(SP);
1246  /* Both SP and old_stack_sp point just before the CV. */
1247  Copy(old_stack_sp + 2, SP + 1, args, SV *);
1248  SP += args;
1249  PUSHs((SV *) cv);
1250  PUTBACK;
1251
1252  Zero(&sub_op, 1, UNOP);
1253  sub_op.op_type  = OP_ENTERSUB;
1254  sub_op.op_next  = NULL;
1255  sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1256  if (PL_DBsub)
1257   sub_op.op_flags |= OPpENTERSUB_DB;
1258
1259  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1260
1261  sud->old_catch = CATCH_GET;
1262  CATCH_SET(TRUE);
1263
1264  if (PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)) {
1265   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1266    /* The call to pp_entersub() has saved the current @_ (in XS terms,
1267     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1268     * with what we put on the stack. But we want to fake up the same arguments
1269     * as the ones in use at the context we uplevel to, so we replace the
1270     * argarray with an unreal copy of the original @_. */
1271    AV *av = newAV();
1272    AvREAL_off(av);
1273    av_extend(av, AvMAX(cx->blk_sub.argarray));
1274    AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1275    Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1276    cxstack[cxix].blk_sub.argarray = av;
1277   } else {
1278    SvREFCNT_inc(cxstack[cxix].blk_sub.argarray);
1279   }
1280
1281   CALLRUNOPS(aTHX);
1282
1283   ret = PL_stack_sp - (PL_stack_base + new_mark);
1284  }
1285
1286  sud->died = 0;
1287
1288  SPAGAIN;
1289
1290  if (ret > 0) {
1291   AV *old_stack = sud->old_curstackinfo->si_stack;
1292
1293   if (old_mark + ret > AvMAX(old_stack)) {
1294    /* Specialized EXTEND(old_sp, ret) */
1295    av_extend(old_stack, old_mark + ret + 1);
1296    old_stack_sp = AvARRAY(old_stack) + old_mark;
1297   }
1298
1299   Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1300   PL_stack_sp        += ret;
1301   AvFILLp(old_stack) += ret;
1302  }
1303
1304  PUTBACK;
1305
1306  LEAVE;
1307
1308  return ret;
1309 }
1310
1311 /* --- Interpreter setup/teardown ------------------------------------------ */
1312
1313 STATIC void su_teardown(pTHX_ void *param) {
1314  su_uplevel_ud *cur, *prev;
1315  dMY_CXT;
1316
1317  cur = MY_CXT.uplevel_storage.root;
1318  if (cur) {
1319   su_uplevel_ud *prev;
1320   do {
1321    prev = cur;
1322    cur  = prev->next;
1323    su_uplevel_ud_delete(prev);
1324   } while (cur);
1325  }
1326
1327  return;
1328 }
1329
1330 STATIC void su_setup(pTHX) {
1331 #define su_setup() su_setup(aTHX)
1332  MY_CXT_INIT;
1333
1334  MY_CXT.stack_placeholder = NULL;
1335
1336  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
1337  Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
1338  MY_CXT.return_op.op_type   = OP_RETURN;
1339  MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
1340
1341  Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
1342  MY_CXT.proxy_op.op_type   = OP_STUB;
1343  MY_CXT.proxy_op.op_ppaddr = NULL;
1344
1345  MY_CXT.uplevel_storage.root  = NULL;
1346  MY_CXT.uplevel_storage.count = 0;
1347
1348  call_atexit(su_teardown, NULL);
1349
1350  return;
1351 }
1352
1353 /* --- XS ------------------------------------------------------------------ */
1354
1355 #if SU_HAS_PERL(5, 8, 9)
1356 # define SU_SKIP_DB_MAX 2
1357 #else
1358 # define SU_SKIP_DB_MAX 3
1359 #endif
1360
1361 /* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
1362  * followed by a DB sub */
1363
1364 #define SU_SKIP_DB(C) \
1365  STMT_START {         \
1366   I32 skipped = 0;    \
1367   PERL_CONTEXT *base = cxstack;      \
1368   PERL_CONTEXT *cx   = base + (C);   \
1369   while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
1370    --cx, ++skipped;                  \
1371   if (cx >= base && (C) > skipped) { \
1372    switch (CxTYPE(cx)) {  \
1373     case CXt_SUB:         \
1374      if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
1375       (C) -= skipped + 1; \
1376       break;              \
1377     default:              \
1378      break;               \
1379    }                      \
1380   }                       \
1381  } STMT_END
1382
1383 #define SU_GET_CONTEXT(A, B)   \
1384  STMT_START {                  \
1385   if (items > A) {             \
1386    SV *csv = ST(B);            \
1387    if (!SvOK(csv))             \
1388     goto default_cx;           \
1389    cxix = SvIV(csv);           \
1390    if (cxix < 0)               \
1391     cxix = 0;                  \
1392    else if (cxix > cxstack_ix) \
1393     cxix = cxstack_ix;         \
1394   } else {                     \
1395 default_cx:                    \
1396    cxix = cxstack_ix;          \
1397    if (PL_DBsub)               \
1398     SU_SKIP_DB(cxix);          \
1399   }                            \
1400  } STMT_END
1401
1402 #define SU_GET_LEVEL(A, B) \
1403  STMT_START {              \
1404   level = 0;               \
1405   if (items > 0) {         \
1406    SV *lsv = ST(B);        \
1407    if (SvOK(lsv)) {        \
1408     level = SvIV(lsv);     \
1409     if (level < 0)         \
1410      level = 0;            \
1411    }                       \
1412   }                        \
1413  } STMT_END
1414
1415 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
1416
1417 XS(XS_Scope__Upper_unwind) {
1418 #ifdef dVAR
1419  dVAR; dXSARGS;
1420 #else
1421  dXSARGS;
1422 #endif
1423  dMY_CXT;
1424  I32 cxix;
1425
1426  PERL_UNUSED_VAR(cv); /* -W */
1427  PERL_UNUSED_VAR(ax); /* -Wall */
1428
1429  SU_GET_CONTEXT(0, items - 1);
1430  do {
1431   PERL_CONTEXT *cx = cxstack + cxix;
1432   switch (CxTYPE(cx)) {
1433    case CXt_SUB:
1434     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1435      continue;
1436    case CXt_EVAL:
1437    case CXt_FORMAT:
1438     MY_CXT.cxix  = cxix;
1439     MY_CXT.items = items;
1440     /* pp_entersub will want to sanitize the stack after returning from there
1441      * Screw that, we're insane */
1442     if (GIMME_V == G_SCALAR) {
1443      MY_CXT.savesp = PL_stack_sp;
1444      /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
1445      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
1446     } else {
1447      MY_CXT.savesp = NULL;
1448     }
1449     SAVEDESTRUCTOR_X(su_unwind, NULL);
1450     return;
1451    default:
1452     break;
1453   }
1454  } while (--cxix >= 0);
1455  croak("Can't return outside a subroutine");
1456 }
1457
1458 MODULE = Scope::Upper            PACKAGE = Scope::Upper
1459
1460 PROTOTYPES: ENABLE
1461
1462 BOOT:
1463 {
1464  HV *stash;
1465
1466  stash = gv_stashpv(__PACKAGE__, 1);
1467  newCONSTSUB(stash, "TOP",           newSViv(0));
1468  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
1469
1470  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
1471
1472  su_setup();
1473 }
1474
1475 #if SU_THREADSAFE
1476
1477 void
1478 CLONE(...)
1479 PROTOTYPE: DISABLE
1480 PPCODE:
1481  {
1482   MY_CXT_CLONE;
1483   MY_CXT.uplevel_storage.root  = NULL;
1484   MY_CXT.uplevel_storage.count = 0;
1485  }
1486  XSRETURN(0);
1487
1488 #endif /* SU_THREADSAFE */
1489
1490 SV *
1491 HERE()
1492 PROTOTYPE:
1493 PREINIT:
1494  I32 cxix = cxstack_ix;
1495 CODE:
1496  if (PL_DBsub)
1497   SU_SKIP_DB(cxix);
1498  RETVAL = newSViv(cxix);
1499 OUTPUT:
1500  RETVAL
1501
1502 SV *
1503 UP(...)
1504 PROTOTYPE: ;$
1505 PREINIT:
1506  I32 cxix;
1507 CODE:
1508  SU_GET_CONTEXT(0, 0);
1509  if (--cxix < 0)
1510   cxix = 0;
1511  if (PL_DBsub)
1512   SU_SKIP_DB(cxix);
1513  RETVAL = newSViv(cxix);
1514 OUTPUT:
1515  RETVAL
1516
1517 void
1518 SUB(...)
1519 PROTOTYPE: ;$
1520 PREINIT:
1521  I32 cxix;
1522 PPCODE:
1523  SU_GET_CONTEXT(0, 0);
1524  for (; cxix >= 0; --cxix) {
1525   PERL_CONTEXT *cx = cxstack + cxix;
1526   switch (CxTYPE(cx)) {
1527    default:
1528     continue;
1529    case CXt_SUB:
1530     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1531      continue;
1532     ST(0) = sv_2mortal(newSViv(cxix));
1533     XSRETURN(1);
1534   }
1535  }
1536  XSRETURN_UNDEF;
1537
1538 void
1539 EVAL(...)
1540 PROTOTYPE: ;$
1541 PREINIT:
1542  I32 cxix;
1543 PPCODE:
1544  SU_GET_CONTEXT(0, 0);
1545  for (; cxix >= 0; --cxix) {
1546   PERL_CONTEXT *cx = cxstack + cxix;
1547   switch (CxTYPE(cx)) {
1548    default:
1549     continue;
1550    case CXt_EVAL:
1551     ST(0) = sv_2mortal(newSViv(cxix));
1552     XSRETURN(1);
1553   }
1554  }
1555  XSRETURN_UNDEF;
1556
1557 void
1558 SCOPE(...)
1559 PROTOTYPE: ;$
1560 PREINIT:
1561  I32 cxix, level;
1562 PPCODE:
1563  SU_GET_LEVEL(0, 0);
1564  cxix = cxstack_ix;
1565  if (PL_DBsub) {
1566   SU_SKIP_DB(cxix);
1567   while (cxix > 0) {
1568    if (--level < 0)
1569     break;
1570    --cxix;
1571    SU_SKIP_DB(cxix);
1572   }
1573  } else {
1574   cxix -= level;
1575   if (cxix < 0)
1576    cxix = 0;
1577  }
1578  ST(0) = sv_2mortal(newSViv(cxix));
1579  XSRETURN(1);
1580
1581 void
1582 CALLER(...)
1583 PROTOTYPE: ;$
1584 PREINIT:
1585  I32 cxix, level;
1586 PPCODE:
1587  SU_GET_LEVEL(0, 0);
1588  for (cxix = cxstack_ix; cxix > 0; --cxix) {
1589   PERL_CONTEXT *cx = cxstack + cxix;
1590   switch (CxTYPE(cx)) {
1591    case CXt_SUB:
1592     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1593      continue;
1594    case CXt_EVAL:
1595    case CXt_FORMAT:
1596     if (--level < 0)
1597      goto done;
1598     break;
1599   }
1600  }
1601 done:
1602  ST(0) = sv_2mortal(newSViv(cxix));
1603  XSRETURN(1);
1604
1605 void
1606 want_at(...)
1607 PROTOTYPE: ;$
1608 PREINIT:
1609  I32 cxix;
1610 PPCODE:
1611  SU_GET_CONTEXT(0, 0);
1612  while (cxix > 0) {
1613   PERL_CONTEXT *cx = cxstack + cxix--;
1614   switch (CxTYPE(cx)) {
1615    case CXt_SUB:
1616    case CXt_EVAL:
1617    case CXt_FORMAT: {
1618     I32 gimme = cx->blk_gimme;
1619     switch (gimme) {
1620      case G_VOID:   XSRETURN_UNDEF; break;
1621      case G_SCALAR: XSRETURN_NO;    break;
1622      case G_ARRAY:  XSRETURN_YES;   break;
1623     }
1624     break;
1625    }
1626   }
1627  }
1628  XSRETURN_UNDEF;
1629
1630 void
1631 reap(SV *hook, ...)
1632 PROTOTYPE: &;$
1633 PREINIT:
1634  I32 cxix;
1635  su_ud_reap *ud;
1636 CODE:
1637  SU_GET_CONTEXT(1, 1);
1638  Newx(ud, 1, su_ud_reap);
1639  SU_UD_ORIGIN(ud)  = NULL;
1640  SU_UD_HANDLER(ud) = su_reap;
1641  ud->cb = newSVsv(hook);
1642  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1643
1644 void
1645 localize(SV *sv, SV *val, ...)
1646 PROTOTYPE: $$;$
1647 PREINIT:
1648  I32 cxix;
1649  I32 size;
1650  su_ud_localize *ud;
1651 CODE:
1652  SU_GET_CONTEXT(2, 2);
1653  Newx(ud, 1, su_ud_localize);
1654  SU_UD_ORIGIN(ud)  = NULL;
1655  SU_UD_HANDLER(ud) = su_localize;
1656  size = su_ud_localize_init(ud, sv, val, NULL);
1657  su_init(ud, cxix, size);
1658
1659 void
1660 localize_elem(SV *sv, SV *elem, SV *val, ...)
1661 PROTOTYPE: $$$;$
1662 PREINIT:
1663  I32 cxix;
1664  I32 size;
1665  su_ud_localize *ud;
1666 CODE:
1667  if (SvTYPE(sv) >= SVt_PVGV)
1668   croak("Can't infer the element localization type from a glob and the value");
1669  SU_GET_CONTEXT(3, 3);
1670  Newx(ud, 1, su_ud_localize);
1671  SU_UD_ORIGIN(ud)  = NULL;
1672  SU_UD_HANDLER(ud) = su_localize;
1673  size = su_ud_localize_init(ud, sv, val, elem);
1674  if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
1675   SU_UD_LOCALIZE_FREE(ud);
1676   croak("Can't localize an element of something that isn't an array or a hash");
1677  }
1678  su_init(ud, cxix, size);
1679
1680 void
1681 localize_delete(SV *sv, SV *elem, ...)
1682 PROTOTYPE: $$;$
1683 PREINIT:
1684  I32 cxix;
1685  I32 size;
1686  su_ud_localize *ud;
1687 CODE:
1688  SU_GET_CONTEXT(2, 2);
1689  Newx(ud, 1, su_ud_localize);
1690  SU_UD_ORIGIN(ud)  = NULL;
1691  SU_UD_HANDLER(ud) = su_localize;
1692  size = su_ud_localize_init(ud, sv, NULL, elem);
1693  su_init(ud, cxix, size);
1694
1695 void
1696 uplevel(SV *code, ...)
1697 PROTOTYPE: &@
1698 PREINIT:
1699  I32 cxix, ret, args = 0;
1700 PPCODE:
1701  if (SvROK(code))
1702   code = SvRV(code);
1703  if (SvTYPE(code) < SVt_PVCV)
1704   croak("First argument to uplevel must be a code reference");
1705  SU_GET_CONTEXT(1, items - 1);
1706  do {
1707   PERL_CONTEXT *cx = cxstack + cxix;
1708   switch (CxTYPE(cx)) {
1709    case CXt_EVAL:
1710     croak("Can't uplevel to an eval frame");
1711    case CXt_FORMAT:
1712     croak("Can't uplevel to a format frame");
1713    case CXt_SUB:
1714     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1715      continue;
1716     if (items > 1) {
1717      PL_stack_sp--;
1718      args = items - 2;
1719     }
1720     ret = su_uplevel((CV *) code, cxix, args);
1721     XSRETURN(ret);
1722    default:
1723     break;
1724   }
1725  } while (--cxix >= 0);
1726  croak("Can't uplevel outside a subroutine");