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 PERL_UNUSED_VAR
  18 # define PERL_UNUSED_VAR(V)
  19 #endif
  20
  21 #ifndef STMT_START
  22 # define STMT_START do
  23 #endif
  24
  25 #ifndef STMT_END
  26 # define STMT_END while (0)
  27 #endif
  28
  29 #if SU_DEBUG
  30 # define SU_D(X) STMT_START X STMT_END
  31 #else
  32 # define SU_D(X)
  33 #endif
  34
  35 #ifndef Newx
  36 # define Newx(v, n, c) New(0, v, n, c)
  37 #endif
  38
  39 #ifndef SvPV_const
  40 # define SvPV_const(S, L) SvPV(S, L)
  41 #endif
  42
  43 #ifndef SvPV_nolen_const
  44 # define SvPV_nolen_const(S) SvPV_nolen(S)
  45 #endif
  46
  47 #ifndef SvREFCNT_inc_simple_void
  48 # define SvREFCNT_inc_simple_void(sv) SvREFCNT_inc(sv)
  49 #endif
  50
  51 #ifndef GvCV_set
  52 # define GvCV_set(G, C) (GvCV(G) = (C))
  53 #endif
  54
  55 #ifndef HvNAME_get
  56 # define HvNAME_get(H) HvNAME(H)
  57 #endif
  58
  59 #ifndef gv_fetchpvn_flags
  60 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
  61 #endif
  62
  63 #ifndef PERL_MAGIC_tied
  64 # define PERL_MAGIC_tied 'P'
  65 #endif
  66
  67 #ifndef PERL_MAGIC_env
  68 # define PERL_MAGIC_env 'E'
  69 #endif
  70
  71 #ifndef NEGATIVE_INDICES_VAR
  72 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
  73 #endif
  74
  75 #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  76 #define SU_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S)))
  77
  78 /* --- Threads and multiplicity -------------------------------------------- */
  79
  80 #ifndef NOOP
  81 # define NOOP
  82 #endif
  83
  84 #ifndef dNOOP
  85 # define dNOOP
  86 #endif
  87
  88 #ifndef SU_MULTIPLICITY
  89 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  90 #  define SU_MULTIPLICITY 1
  91 # else
  92 #  define SU_MULTIPLICITY 0
  93 # endif
  94 #endif
  95 #if SU_MULTIPLICITY && !defined(tTHX)
  96 # define tTHX PerlInterpreter*
  97 #endif
  98
  99 #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))
 100 # define SU_THREADSAFE 1
 101 # ifndef MY_CXT_CLONE
 102 #  define MY_CXT_CLONE \
 103     dMY_CXT_SV;                                                      \
 104     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
 105     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
 106     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 107 # endif
 108 #else
 109 # define SU_THREADSAFE 0
 110 # undef  dMY_CXT
 111 # define dMY_CXT      dNOOP
 112 # undef  MY_CXT
 113 # define MY_CXT       su_globaldata
 114 # undef  START_MY_CXT
 115 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
 116 # undef  MY_CXT_INIT
 117 # define MY_CXT_INIT  NOOP
 118 # undef  MY_CXT_CLONE
 119 # define MY_CXT_CLONE NOOP
 120 #endif
 121
 122 /* --- Global data --------------------------------------------------------- */
 123
 124 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 125
 126 typedef struct {
 127  char    *stack_placeholder;
 128  I32      cxix;
 129  I32      items;
 130  SV     **savesp;
 131  LISTOP   return_op;
 132  OP       proxy_op;
 133 } my_cxt_t;
 134
 135 START_MY_CXT
 136
 137 /* --- Stack manipulations ------------------------------------------------- */
 138
 139 #define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder)
 140
 141 #define SU_SAVE_DESTRUCTOR_SIZE  3
 142 #define SU_SAVE_PLACEHOLDER_SIZE 3
 143
 144 #define SU_SAVE_SCALAR_SIZE 3
 145
 146 #define SU_SAVE_ARY_SIZE      3
 147 #define SU_SAVE_AELEM_SIZE    4
 148 #ifdef SAVEADELETE
 149 # define SU_SAVE_ADELETE_SIZE 3
 150 #else
 151 # define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
 152 #endif
 153 #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
 154 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
 155 #else
 156 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
 157 #endif
 158
 159 #define SU_SAVE_HASH_SIZE    3
 160 #define SU_SAVE_HELEM_SIZE   4
 161 #define SU_SAVE_HDELETE_SIZE 4
 162 #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
 163 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
 164 #else
 165 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
 166 #endif
 167
 168 #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
 169
 170 #if !SU_HAS_PERL(5, 8, 9)
 171 # define SU_SAVE_GP_SIZE 6
 172 #elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0))
 173 # define SU_SAVE_GP_SIZE 3
 174 #elif !SU_HAS_PERL(5, 13, 8)
 175 # define SU_SAVE_GP_SIZE 4
 176 #else
 177 # define SU_SAVE_GP_SIZE 3
 178 #endif
 179
 180 #ifndef SvCANEXISTDELETE
 181 # define SvCANEXISTDELETE(sv) \
 182   (!SvRMAGICAL(sv)            \
 183    || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied))            \
 184        && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \
 185        && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)     \
 186        && gv_fetchmethod_autoload(stash, "DELETE", TRUE)     \
 187       )                       \
 188    )
 189 #endif
 190
 191 /* ... Saving array elements ............................................... */
 192
 193 STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
 194 #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K))
 195  I32 idx;
 196
 197  if (key >= 0)
 198   return key;
 199
 200 /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */
 201 #if SU_HAS_PERL(5, 8, 1)
 202  if (SvRMAGICAL(av)) {
 203   const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
 204   if (tied_magic) {
 205    SV * const * const negative_indices_glob =
 206                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
 207                              NEGATIVE_INDICES_VAR, 16, 0);
 208    if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 209     return key;
 210   }
 211  }
 212 #endif
 213
 214  idx = key + av_len(av) + 1;
 215  if (idx < 0)
 216   return key;
 217
 218  return idx;
 219 }
 220
 221 #ifndef SAVEADELETE
 222
 223 typedef struct {
 224  AV *av;
 225  I32 idx;
 226 } su_ud_adelete;
 227
 228 STATIC void su_adelete(pTHX_ void *ud_) {
 229  su_ud_adelete *ud = (su_ud_adelete *) ud_;
 230
 231  av_delete(ud->av, ud->idx, G_DISCARD);
 232  SvREFCNT_dec(ud->av);
 233
 234  Safefree(ud);
 235 }
 236
 237 STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) {
 238 #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K))
 239  su_ud_adelete *ud;
 240
 241  Newx(ud, 1, su_ud_adelete);
 242  ud->av  = av;
 243  ud->idx = idx;
 244  SvREFCNT_inc_simple_void(av);
 245
 246  SAVEDESTRUCTOR_X(su_adelete, ud);
 247 }
 248
 249 #define SAVEADELETE(A, K) su_save_adelete((A), (K))
 250
 251 #endif /* SAVEADELETE */
 252
 253 STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) {
 254 #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V))
 255  I32 idx;
 256  I32 preeminent = 1;
 257  SV **svp;
 258  HV *stash;
 259  MAGIC *mg;
 260
 261  idx = su_av_key2idx(av, SvIV(key));
 262
 263  if (SvCANEXISTDELETE(av))
 264   preeminent = av_exists(av, idx);
 265
 266  svp = av_fetch(av, idx, 1);
 267  if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
 268
 269  if (preeminent)
 270   save_aelem(av, idx, svp);
 271  else
 272   SAVEADELETE(av, idx);
 273
 274  if (val) { /* local $x[$idx] = $val; */
 275   SvSetMagicSV(*svp, val);
 276  } else {   /* local $x[$idx]; delete $x[$idx]; */
 277   av_delete(av, idx, G_DISCARD);
 278  }
 279 }
 280
 281 /* ... Saving hash elements ................................................ */
 282
 283 STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
 284 #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V))
 285  I32 preeminent = 1;
 286  HE *he;
 287  SV **svp;
 288  HV *stash;
 289  MAGIC *mg;
 290
 291  if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env))
 292   preeminent = hv_exists_ent(hv, keysv, 0);
 293
 294  he  = hv_fetch_ent(hv, keysv, 1, 0);
 295  svp = he ? &HeVAL(he) : NULL;
 296  if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
 297
 298  if (HvNAME_get(hv) && isGV(*svp)) {
 299   save_gp((GV *) *svp, 0);
 300   return;
 301  }
 302
 303  if (preeminent)
 304   save_helem(hv, keysv, svp);
 305  else {
 306   STRLEN keylen;
 307   const char * const key = SvPV_const(keysv, keylen);
 308   SAVEDELETE(hv, savepvn(key, keylen),
 309                  SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
 310  }
 311
 312  if (val) { /* local $x{$keysv} = $val; */
 313   SvSetMagicSV(*svp, val);
 314  } else {   /* local $x{$keysv}; delete $x{$keysv}; */
 315   (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
 316  }
 317 }
 318
 319 /* ... Saving code slots from a glob ....................................... */
 320
 321 #if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in)
 322 # define mro_method_changed_in(G) PL_sub_generation++
 323 #endif
 324
 325 typedef struct {
 326  GV *gv;
 327  CV *old_cv;
 328 } su_save_gvcv_ud;
 329
 330 STATIC void su_restore_gvcv(pTHX_ void *ud_) {
 331  su_save_gvcv_ud *ud = ud_;
 332  GV              *gv = ud->gv;
 333
 334  GvCV_set(gv, ud->old_cv);
 335  GvCVGEN(gv) = 0;
 336  mro_method_changed_in(GvSTASH(gv));
 337
 338  Safefree(ud);
 339 }
 340
 341 STATIC void su_save_gvcv(pTHX_ GV *gv) {
 342 #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G))
 343  su_save_gvcv_ud *ud;
 344
 345  Newx(ud, 1, su_save_gvcv_ud);
 346  ud->gv     = gv;
 347  ud->old_cv = GvCV(gv);
 348
 349  GvCV_set(gv, NULL);
 350  GvCVGEN(gv) = 0;
 351  mro_method_changed_in(GvSTASH(gv));
 352
 353  SAVEDESTRUCTOR_X(su_restore_gvcv, ud);
 354 }
 355
 356 /* --- Actions ------------------------------------------------------------- */
 357
 358 typedef struct {
 359  I32 depth;
 360  I32 pad;
 361  I32 *origin;
 362  void (*handler)(pTHX_ void *);
 363 } su_ud_common;
 364
 365 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
 366 #define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
 367 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
 368 #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
 369
 370 #define SU_UD_FREE(U) STMT_START { \
 371  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
 372  Safefree(U); \
 373 } STMT_END
 374
 375 /* ... Reap ................................................................ */
 376
 377 typedef struct {
 378  su_ud_common ci;
 379  SV *cb;
 380 } su_ud_reap;
 381
 382 STATIC void su_call(pTHX_ void *ud_) {
 383  su_ud_reap *ud = (su_ud_reap *) ud_;
 384 #if SU_HAS_PERL(5, 9, 5)
 385  PERL_CONTEXT saved_cx;
 386  I32 cxix;
 387 #endif
 388
 389  dSP;
 390
 391  SU_D({
 392   PerlIO_printf(Perl_debug_log,
 393                 "%p: @@@ call\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 394                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 395  });
 396
 397  ENTER;
 398  SAVETMPS;
 399
 400  PUSHMARK(SP);
 401  PUTBACK;
 402
 403  /* If the recently popped context isn't saved there, it will be overwritten by
 404   * the sub scope from call_sv, although it's still needed in our caller. */
 405
 406 #if SU_HAS_PERL(5, 9, 5)
 407  if (cxstack_ix < cxstack_max)
 408   cxix = cxstack_ix + 1;
 409  else
 410   cxix = Perl_cxinc(aTHX);
 411  saved_cx = cxstack[cxix];
 412 #endif
 413
 414  call_sv(ud->cb, G_VOID);
 415
 416 #if SU_HAS_PERL(5, 9, 5)
 417  cxstack[cxix] = saved_cx;
 418 #endif
 419
 420  PUTBACK;
 421
 422  FREETMPS;
 423  LEAVE;
 424
 425  SvREFCNT_dec(ud->cb);
 426  SU_UD_FREE(ud);
 427 }
 428
 429 STATIC void su_reap(pTHX_ void *ud) {
 430 #define su_reap(U) su_reap(aTHX_ (U))
 431  SU_D({
 432   PerlIO_printf(Perl_debug_log,
 433                 "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 434                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 435  });
 436
 437  SAVEDESTRUCTOR_X(su_call, ud);
 438 }
 439
 440 /* ... Localize & localize array/hash element .............................. */
 441
 442 typedef struct {
 443  su_ud_common ci;
 444  SV    *sv;
 445  SV    *val;
 446  SV    *elem;
 447  svtype type;
 448 } su_ud_localize;
 449
 450 #define SU_UD_LOCALIZE_FREE(U) STMT_START { \
 451  SvREFCNT_dec((U)->elem); \
 452  SvREFCNT_dec((U)->val);  \
 453  SvREFCNT_dec((U)->sv);   \
 454  SU_UD_FREE(U);           \
 455 } STMT_END
 456
 457 STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
 458 #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
 459  UV deref = 0;
 460  svtype t = SVt_NULL;
 461  I32 size;
 462
 463  SvREFCNT_inc_simple_void(sv);
 464
 465  if (SvTYPE(sv) >= SVt_PVGV) {
 466   if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
 467    t = SVt_PVGV;
 468   } else {                   /* local *x = \$val; */
 469    t = SvTYPE(SvRV(val));
 470    deref = 1;
 471   }
 472  } else if (SvROK(sv)) {
 473   croak("Invalid %s reference as the localization target",
 474                  sv_reftype(SvRV(sv), 0));
 475  } else {
 476   STRLEN len, l;
 477   const char *p = SvPV_const(sv, len), *s;
 478   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
 479   if (!l) {
 480    l = len;
 481    s = p;
 482   }
 483   switch (*s) {
 484    case '$': t = SVt_PV;   break;
 485    case '@': t = SVt_PVAV; break;
 486    case '%': t = SVt_PVHV; break;
 487    case '&': t = SVt_PVCV; break;
 488    case '*': t = SVt_PVGV; break;
 489   }
 490   if (t != SVt_NULL) {
 491    ++s;
 492    --l;
 493   } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
 494    if (SvROK(val) && !sv_isobject(val)) {
 495     t = SvTYPE(SvRV(val));
 496     deref = 1;
 497    } else {
 498     t = SvTYPE(val);
 499    }
 500   }
 501   SvREFCNT_dec(sv);
 502   sv = newSVpvn(s, l);
 503  }
 504
 505  switch (t) {
 506   case SVt_PVAV:
 507    size  = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
 508                 : SU_SAVE_ARY_SIZE;
 509    deref = 0;
 510    break;
 511   case SVt_PVHV:
 512    size  = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
 513                 : SU_SAVE_HASH_SIZE;
 514    deref = 0;
 515    break;
 516   case SVt_PVGV:
 517    size  = SU_SAVE_GP_SIZE;
 518    deref = 0;
 519    break;
 520   case SVt_PVCV:
 521    size  = SU_SAVE_GVCV_SIZE;
 522    deref = 0;
 523    break;
 524   default:
 525    size = SU_SAVE_SCALAR_SIZE;
 526    break;
 527  }
 528  /* When deref is set, val isn't NULL */
 529
 530  ud->sv   = sv;
 531  ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
 532  ud->elem = SvREFCNT_inc(elem);
 533  ud->type = t;
 534
 535  return size;
 536 }
 537
 538 STATIC void su_localize(pTHX_ void *ud_) {
 539 #define su_localize(U) su_localize(aTHX_ (U))
 540  su_ud_localize *ud = (su_ud_localize *) ud_;
 541  SV *sv   = ud->sv;
 542  SV *val  = ud->val;
 543  SV *elem = ud->elem;
 544  svtype t = ud->type;
 545  GV *gv;
 546
 547  if (SvTYPE(sv) >= SVt_PVGV) {
 548   gv = (GV *) sv;
 549  } else {
 550 #ifdef gv_fetchsv
 551   gv = gv_fetchsv(sv, GV_ADDMULTI, t);
 552 #else
 553   STRLEN len;
 554   const char *name = SvPV_const(sv, len);
 555   gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
 556 #endif
 557  }
 558
 559  SU_D({
 560   SV *z = newSV(0);
 561   SvUPGRADE(z, t);
 562   PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0));
 563   PerlIO_printf(Perl_debug_log,
 564                 "%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 565                  ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 566   SvREFCNT_dec(z);
 567  });
 568
 569  /* Inspired from Alias.pm */
 570  switch (t) {
 571   case SVt_PVAV:
 572    if (elem) {
 573     su_save_aelem(GvAV(gv), elem, val);
 574     goto done;
 575    } else
 576     save_ary(gv);
 577    break;
 578   case SVt_PVHV:
 579    if (elem) {
 580     su_save_helem(GvHV(gv), elem, val);
 581     goto done;
 582    } else
 583     save_hash(gv);
 584    break;
 585   case SVt_PVGV:
 586    save_gp(gv, 1); /* hide previous entry in symtab */
 587    break;
 588   case SVt_PVCV:
 589    su_save_gvcv(gv);
 590    break;
 591   default:
 592    gv = (GV *) save_scalar(gv);
 593    break;
 594  }
 595
 596  if (val)
 597   SvSetMagicSV((SV *) gv, val);
 598
 599 done:
 600  SU_UD_LOCALIZE_FREE(ud);
 601 }
 602
 603 /* --- Pop a context back -------------------------------------------------- */
 604
 605 #if SU_DEBUG
 606 # ifdef DEBUGGING
 607 #  define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
 608 # else
 609 #  define SU_CXNAME "XXX"
 610 # endif
 611 #endif
 612
 613 STATIC void su_pop(pTHX_ void *ud) {
 614 #define su_pop(U) su_pop(aTHX_ (U))
 615  I32 depth, base, mark, *origin;
 616  depth = SU_UD_DEPTH(ud);
 617
 618  SU_D(
 619   PerlIO_printf(Perl_debug_log,
 620    "%p: --- pop a %s\n"
 621    "%p: leave scope     at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n",
 622     ud, SU_CXNAME,
 623     ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix])
 624  );
 625
 626  origin = SU_UD_ORIGIN(ud);
 627  mark   = origin[depth];
 628  base   = origin[depth - 1];
 629
 630  SU_D(PerlIO_printf(Perl_debug_log,
 631                     "%p: original scope was %*c top=%2d     base=%2d\n",
 632                      ud,                24, ' ',    mark,        base));
 633
 634  if (base < mark) {
 635   SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
 636   PL_savestack_ix = mark;
 637   leave_scope(base);
 638  }
 639  PL_savestack_ix = base;
 640
 641  SU_UD_DEPTH(ud) = --depth;
 642
 643  if (depth > 0) {
 644   I32 pad;
 645
 646   if ((pad = SU_UD_PAD(ud))) {
 647    dMY_CXT;
 648    do {
 649     SU_D(PerlIO_printf(Perl_debug_log,
 650           "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n",
 651            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
 652     SU_SAVE_PLACEHOLDER();
 653    } while (--pad);
 654   }
 655
 656   SU_D(PerlIO_printf(Perl_debug_log,
 657           "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
 658            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
 659   SAVEDESTRUCTOR_X(su_pop, ud);
 660  } else {
 661   SU_UD_HANDLER(ud)(aTHX_ ud);
 662  }
 663
 664  SU_D(PerlIO_printf(Perl_debug_log,
 665                     "%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
 666                      ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
 667 }
 668
 669 /* --- Initialize the stack and the action userdata ------------------------ */
 670
 671 STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 672 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
 673  I32 i, depth = 1, pad, offset, *origin;
 674
 675  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
 676
 677  if (size <= SU_SAVE_DESTRUCTOR_SIZE)
 678   pad = 0;
 679  else {
 680   I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
 681   pad = extra / SU_SAVE_PLACEHOLDER_SIZE;
 682   if (extra % SU_SAVE_PLACEHOLDER_SIZE)
 683    ++pad;
 684  }
 685  offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad;
 686
 687  SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
 688                                      ud,    size,   pad,   offset));
 689
 690  for (i = cxstack_ix; i > cxix; --i) {
 691   PERL_CONTEXT *cx = cxstack + i;
 692   switch (CxTYPE(cx)) {
 693 #if SU_HAS_PERL(5, 10, 0)
 694    case CXt_BLOCK:
 695     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i));
 696     /* Given and when blocks are actually followed by a simple block, so skip
 697      * it if needed. */
 698     if (cxix > 0) { /* Implies i > 0 */
 699      PERL_CONTEXT *next = cx - 1;
 700      if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN)
 701       --cxix;
 702     }
 703     depth++;
 704     break;
 705 #endif
 706 #if SU_HAS_PERL(5, 11, 0)
 707    case CXt_LOOP_FOR:
 708    case CXt_LOOP_PLAIN:
 709    case CXt_LOOP_LAZYSV:
 710    case CXt_LOOP_LAZYIV:
 711 #else
 712    case CXt_LOOP:
 713 #endif
 714     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
 715     depth += 2;
 716     break;
 717    default:
 718     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
 719     depth++;
 720     break;
 721   }
 722  }
 723  SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
 724
 725  Newx(origin, depth + 1, I32);
 726  origin[0] = PL_scopestack[PL_scopestack_ix - depth];
 727  PL_scopestack[PL_scopestack_ix - depth] += size;
 728  for (i = depth - 1; i >= 1; --i) {
 729   I32 j = PL_scopestack_ix - i;
 730   origin[depth - i] = PL_scopestack[j];
 731   PL_scopestack[j] += offset;
 732  }
 733  origin[depth] = PL_savestack_ix;
 734
 735  SU_UD_ORIGIN(ud) = origin;
 736  SU_UD_DEPTH(ud)  = depth;
 737  SU_UD_PAD(ud)    = pad;
 738
 739  /* Make sure the first destructor fires by pushing enough fake slots on the
 740   * stack. */
 741  if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
 742                                        <= PL_scopestack[PL_scopestack_ix - 1]) {
 743   dMY_CXT;
 744   do {
 745    SU_D(PerlIO_printf(Perl_debug_log,
 746                   "%p: push a fake slot      at scope_ix=%2d  save_ix=%2d\n",
 747                    ud,                      PL_scopestack_ix, PL_savestack_ix));
 748    SU_SAVE_PLACEHOLDER();
 749   } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
 750                                         <= PL_scopestack[PL_scopestack_ix - 1]);
 751  }
 752  SU_D(PerlIO_printf(Perl_debug_log,
 753                   "%p: push first destructor at scope_ix=%2d  save_ix=%2d\n",
 754                    ud,                      PL_scopestack_ix, PL_savestack_ix));
 755  SAVEDESTRUCTOR_X(su_pop, ud);
 756
 757  SU_D({
 758   for (i = 0; i <= depth; ++i) {
 759    I32 j = PL_scopestack_ix  - i;
 760    PerlIO_printf(Perl_debug_log,
 761                  "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n",
 762                   ud,        i, j, origin[depth - i],
 763                                    i == 0 ? PL_savestack_ix : PL_scopestack[j]);
 764   }
 765  });
 766
 767  return depth;
 768 }
 769
 770 /* --- Unwind stack -------------------------------------------------------- */
 771
 772 STATIC void su_unwind(pTHX_ void *ud_) {
 773  dMY_CXT;
 774  I32 cxix    = MY_CXT.cxix;
 775  I32 items   = MY_CXT.items - 1;
 776  SV **savesp = MY_CXT.savesp;
 777  I32 mark;
 778
 779  PERL_UNUSED_VAR(ud_);
 780
 781  if (savesp)
 782   PL_stack_sp = savesp;
 783
 784  if (cxstack_ix > cxix)
 785   dounwind(cxix);
 786
 787  /* Hide the level */
 788  if (items >= 0)
 789   PL_stack_sp--;
 790
 791  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
 792  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
 793
 794  SU_D({
 795   I32 gimme = GIMME_V;
 796   PerlIO_printf(Perl_debug_log,
 797                 "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
 798                 &MY_CXT, cxix,
 799                 gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
 800                 items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
 801  });
 802
 803  PL_op = (OP *) &(MY_CXT.return_op);
 804  PL_op = PL_op->op_ppaddr(aTHX);
 805
 806  *PL_markstack_ptr = mark;
 807
 808  MY_CXT.proxy_op.op_next = PL_op;
 809  PL_op = &(MY_CXT.proxy_op);
 810 }
 811
 812 /* --- XS ------------------------------------------------------------------ */
 813
 814 #if SU_HAS_PERL(5, 8, 9)
 815 # define SU_SKIP_DB_MAX 2
 816 #else
 817 # define SU_SKIP_DB_MAX 3
 818 #endif
 819
 820 /* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
 821  * followed by a DB sub */
 822
 823 #define SU_SKIP_DB(C) \
 824  STMT_START {         \
 825   I32 skipped = 0;    \
 826   PERL_CONTEXT *base = cxstack;      \
 827   PERL_CONTEXT *cx   = base + (C);   \
 828   while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
 829    --cx, ++skipped;                  \
 830   if (cx >= base && (C) > skipped) { \
 831    switch (CxTYPE(cx)) {  \
 832     case CXt_SUB:         \
 833      if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
 834       (C) -= skipped + 1; \
 835       break;              \
 836     default:              \
 837      break;               \
 838    }                      \
 839   }                       \
 840  } STMT_END
 841
 842 #define SU_GET_CONTEXT(A, B)   \
 843  STMT_START {                  \
 844   if (items > A) {             \
 845    SV *csv = ST(B);            \
 846    if (!SvOK(csv))             \
 847     goto default_cx;           \
 848    cxix = SvIV(csv);           \
 849    if (cxix < 0)               \
 850     cxix = 0;                  \
 851    else if (cxix > cxstack_ix) \
 852     cxix = cxstack_ix;         \
 853   } else {                     \
 854 default_cx:                    \
 855    cxix = cxstack_ix;          \
 856    if (PL_DBsub)               \
 857     SU_SKIP_DB(cxix);          \
 858   }                            \
 859  } STMT_END
 860
 861 #define SU_GET_LEVEL(A, B) \
 862  STMT_START {              \
 863   level = 0;               \
 864   if (items > 0) {         \
 865    SV *lsv = ST(B);        \
 866    if (SvOK(lsv)) {        \
 867     level = SvIV(lsv);     \
 868     if (level < 0)         \
 869      level = 0;            \
 870    }                       \
 871   }                        \
 872  } STMT_END
 873
 874 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
 875
 876 XS(XS_Scope__Upper_unwind) {
 877 #ifdef dVAR
 878  dVAR; dXSARGS;
 879 #else
 880  dXSARGS;
 881 #endif
 882  dMY_CXT;
 883  I32 cxix;
 884
 885  PERL_UNUSED_VAR(cv); /* -W */
 886  PERL_UNUSED_VAR(ax); /* -Wall */
 887
 888  SU_GET_CONTEXT(0, items - 1);
 889  do {
 890   PERL_CONTEXT *cx = cxstack + cxix;
 891   switch (CxTYPE(cx)) {
 892    case CXt_SUB:
 893     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
 894      continue;
 895    case CXt_EVAL:
 896    case CXt_FORMAT:
 897     MY_CXT.cxix  = cxix;
 898     MY_CXT.items = items;
 899     /* pp_entersub will want to sanitize the stack after returning from there
 900      * Screw that, we're insane */
 901     if (GIMME_V == G_SCALAR) {
 902      MY_CXT.savesp = PL_stack_sp;
 903      /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
 904      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
 905     } else {
 906      MY_CXT.savesp = NULL;
 907     }
 908     SAVEDESTRUCTOR_X(su_unwind, NULL);
 909     return;
 910    default:
 911     break;
 912   }
 913  } while (--cxix >= 0);
 914  croak("Can't return outside a subroutine");
 915 }
 916
 917 MODULE = Scope::Upper            PACKAGE = Scope::Upper
 918
 919 PROTOTYPES: ENABLE
 920
 921 BOOT:
 922 {
 923  HV *stash;
 924
 925  MY_CXT_INIT;
 926
 927  MY_CXT.stack_placeholder = NULL;
 928
 929  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
 930  Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
 931  MY_CXT.return_op.op_type   = OP_RETURN;
 932  MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
 933
 934  Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
 935  MY_CXT.proxy_op.op_type   = OP_STUB;
 936  MY_CXT.proxy_op.op_ppaddr = NULL;
 937
 938  stash = gv_stashpv(__PACKAGE__, 1);
 939  newCONSTSUB(stash, "TOP",           newSViv(0));
 940  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
 941
 942  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
 943 }
 944
 945 #if SU_THREADSAFE
 946
 947 void
 948 CLONE(...)
 949 PROTOTYPE: DISABLE
 950 PPCODE:
 951  {
 952   MY_CXT_CLONE;
 953  }
 954  XSRETURN(0);
 955
 956 #endif /* SU_THREADSAFE */
 957
 958 SV *
 959 HERE()
 960 PROTOTYPE:
 961 PREINIT:
 962  I32 cxix = cxstack_ix;
 963 CODE:
 964  if (PL_DBsub)
 965   SU_SKIP_DB(cxix);
 966  RETVAL = newSViv(cxix);
 967 OUTPUT:
 968  RETVAL
 969
 970 SV *
 971 UP(...)
 972 PROTOTYPE: ;$
 973 PREINIT:
 974  I32 cxix;
 975 CODE:
 976  SU_GET_CONTEXT(0, 0);
 977  if (--cxix < 0)
 978   cxix = 0;
 979  if (PL_DBsub)
 980   SU_SKIP_DB(cxix);
 981  RETVAL = newSViv(cxix);
 982 OUTPUT:
 983  RETVAL
 984
 985 void
 986 SUB(...)
 987 PROTOTYPE: ;$
 988 PREINIT:
 989  I32 cxix;
 990 PPCODE:
 991  SU_GET_CONTEXT(0, 0);
 992  for (; cxix >= 0; --cxix) {
 993   PERL_CONTEXT *cx = cxstack + cxix;
 994   switch (CxTYPE(cx)) {
 995    default:
 996     continue;
 997    case CXt_SUB:
 998     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
 999      continue;
1000     ST(0) = sv_2mortal(newSViv(cxix));
1001     XSRETURN(1);
1002   }
1003  }
1004  XSRETURN_UNDEF;
1005
1006 void
1007 EVAL(...)
1008 PROTOTYPE: ;$
1009 PREINIT:
1010  I32 cxix;
1011 PPCODE:
1012  SU_GET_CONTEXT(0, 0);
1013  for (; cxix >= 0; --cxix) {
1014   PERL_CONTEXT *cx = cxstack + cxix;
1015   switch (CxTYPE(cx)) {
1016    default:
1017     continue;
1018    case CXt_EVAL:
1019     ST(0) = sv_2mortal(newSViv(cxix));
1020     XSRETURN(1);
1021   }
1022  }
1023  XSRETURN_UNDEF;
1024
1025 void
1026 SCOPE(...)
1027 PROTOTYPE: ;$
1028 PREINIT:
1029  I32 cxix, level;
1030 PPCODE:
1031  SU_GET_LEVEL(0, 0);
1032  cxix = cxstack_ix;
1033  if (PL_DBsub) {
1034   SU_SKIP_DB(cxix);
1035   while (cxix > 0) {
1036    if (--level < 0)
1037     break;
1038    --cxix;
1039    SU_SKIP_DB(cxix);
1040   }
1041  } else {
1042   cxix -= level;
1043   if (cxix < 0)
1044    cxix = 0;
1045  }
1046  ST(0) = sv_2mortal(newSViv(cxix));
1047  XSRETURN(1);
1048
1049 void
1050 CALLER(...)
1051 PROTOTYPE: ;$
1052 PREINIT:
1053  I32 cxix, level;
1054 PPCODE:
1055  SU_GET_LEVEL(0, 0);
1056  for (cxix = cxstack_ix; cxix > 0; --cxix) {
1057   PERL_CONTEXT *cx = cxstack + cxix;
1058   switch (CxTYPE(cx)) {
1059    case CXt_SUB:
1060     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1061      continue;
1062    case CXt_EVAL:
1063    case CXt_FORMAT:
1064     if (--level < 0)
1065      goto done;
1066     break;
1067   }
1068  }
1069 done:
1070  ST(0) = sv_2mortal(newSViv(cxix));
1071  XSRETURN(1);
1072
1073 void
1074 want_at(...)
1075 PROTOTYPE: ;$
1076 PREINIT:
1077  I32 cxix;
1078 PPCODE:
1079  SU_GET_CONTEXT(0, 0);
1080  while (cxix > 0) {
1081   PERL_CONTEXT *cx = cxstack + cxix--;
1082   switch (CxTYPE(cx)) {
1083    case CXt_SUB:
1084    case CXt_EVAL:
1085    case CXt_FORMAT: {
1086     I32 gimme = cx->blk_gimme;
1087     switch (gimme) {
1088      case G_VOID:   XSRETURN_UNDEF; break;
1089      case G_SCALAR: XSRETURN_NO;    break;
1090      case G_ARRAY:  XSRETURN_YES;   break;
1091     }
1092     break;
1093    }
1094   }
1095  }
1096  XSRETURN_UNDEF;
1097
1098 void
1099 reap(SV *hook, ...)
1100 PROTOTYPE: &;$
1101 PREINIT:
1102  I32 cxix;
1103  su_ud_reap *ud;
1104 CODE:
1105  SU_GET_CONTEXT(1, 1);
1106  Newx(ud, 1, su_ud_reap);
1107  SU_UD_ORIGIN(ud)  = NULL;
1108  SU_UD_HANDLER(ud) = su_reap;
1109  ud->cb = newSVsv(hook);
1110  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1111
1112 void
1113 localize(SV *sv, SV *val, ...)
1114 PROTOTYPE: $$;$
1115 PREINIT:
1116  I32 cxix;
1117  I32 size;
1118  su_ud_localize *ud;
1119 CODE:
1120  SU_GET_CONTEXT(2, 2);
1121  Newx(ud, 1, su_ud_localize);
1122  SU_UD_ORIGIN(ud)  = NULL;
1123  SU_UD_HANDLER(ud) = su_localize;
1124  size = su_ud_localize_init(ud, sv, val, NULL);
1125  su_init(ud, cxix, size);
1126
1127 void
1128 localize_elem(SV *sv, SV *elem, SV *val, ...)
1129 PROTOTYPE: $$$;$
1130 PREINIT:
1131  I32 cxix;
1132  I32 size;
1133  su_ud_localize *ud;
1134 CODE:
1135  if (SvTYPE(sv) >= SVt_PVGV)
1136   croak("Can't infer the element localization type from a glob and the value");
1137  SU_GET_CONTEXT(3, 3);
1138  Newx(ud, 1, su_ud_localize);
1139  SU_UD_ORIGIN(ud)  = NULL;
1140  SU_UD_HANDLER(ud) = su_localize;
1141  size = su_ud_localize_init(ud, sv, val, elem);
1142  if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
1143   SU_UD_LOCALIZE_FREE(ud);
1144   croak("Can't localize an element of something that isn't an array or a hash");
1145  }
1146  su_init(ud, cxix, size);
1147
1148 void
1149 localize_delete(SV *sv, SV *elem, ...)
1150 PROTOTYPE: $$;$
1151 PREINIT:
1152  I32 cxix;
1153  I32 size;
1154  su_ud_localize *ud;
1155 CODE:
1156  SU_GET_CONTEXT(2, 2);
1157  Newx(ud, 1, su_ud_localize);
1158  SU_UD_ORIGIN(ud)  = NULL;
1159  SU_UD_HANDLER(ud) = su_localize;
1160  size = su_ud_localize_init(ud, sv, NULL, elem);
1161  su_init(ud, cxix, size);