Upper.xs

   1 /* This file is part of the Scope::Upper Perl module.
   2  * See http://search.cpan.org/dist/Scope-Upper/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__ "Scope::Upper"
  10
  11 #ifndef SU_DEBUG
  12 # define SU_DEBUG 0
  13 #endif
  14
  15 /* --- Compatibility ------------------------------------------------------- */
  16
  17 #ifndef NOOP
  18 # define NOOP
  19 #endif
  20
  21 #ifndef dNOOP
  22 # define dNOOP
  23 #endif
  24
  25 #ifndef dVAR
  26 # define dVAR dNOOP
  27 #endif
  28
  29 #ifndef MUTABLE_SV
  30 # define MUTABLE_SV(S) ((SV *) (S))
  31 #endif
  32
  33 #ifndef MUTABLE_AV
  34 # define MUTABLE_AV(A) ((AV *) (A))
  35 #endif
  36
  37 #ifndef MUTABLE_CV
  38 # define MUTABLE_CV(C) ((CV *) (C))
  39 #endif
  40
  41 #ifndef PERL_UNUSED_VAR
  42 # define PERL_UNUSED_VAR(V)
  43 #endif
  44
  45 #ifndef STMT_START
  46 # define STMT_START do
  47 #endif
  48
  49 #ifndef STMT_END
  50 # define STMT_END while (0)
  51 #endif
  52
  53 #if SU_DEBUG
  54 # define SU_D(X) STMT_START X STMT_END
  55 #else
  56 # define SU_D(X)
  57 #endif
  58
  59 #ifndef Newx
  60 # define Newx(v, n, c) New(0, v, n, c)
  61 #endif
  62
  63 #ifdef DEBUGGING
  64 # ifdef PoisonNew
  65 #  define SU_POISON(D, N, T) PoisonNew((D), (N), T)
  66 # elif defined(Poison)
  67 #  define SU_POISON(D, N, T) Poison((D), (N), T)
  68 # endif
  69 #endif
  70 #ifndef SU_POISON
  71 # define SU_POISON(D, N, T) NOOP
  72 #endif
  73
  74 #ifndef newSV_type
  75 static SV *su_newSV_type(pTHX_ svtype t) {
  76  SV *sv = newSV(0);
  77  SvUPGRADE(sv, t);
  78  return sv;
  79 }
  80 # define newSV_type(T) su_newSV_type(aTHX_ (T))
  81 #endif
  82
  83 #ifdef newSVpvn_flags
  84 # define su_newmortal_pvn(S, L) newSVpvn_flags((S), (L), SVs_TEMP)
  85 #else
  86 # define su_newmortal_pvn(S, L) sv_2mortal(newSVpvn((S), (L)))
  87 #endif
  88 #define su_newmortal_pvs(S) su_newmortal_pvn((S), sizeof(S)-1)
  89
  90 #ifndef SvPV_const
  91 # define SvPV_const(S, L) SvPV(S, L)
  92 #endif
  93
  94 #ifndef SvPVX_const
  95 # define SvPVX_const(S) SvPVX(S)
  96 #endif
  97
  98 #ifndef SvPV_nolen_const
  99 # define SvPV_nolen_const(S) SvPV_nolen(S)
 100 #endif
 101
 102 #ifndef SvREFCNT_inc_simple_void
 103 # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv))
 104 #endif
 105
 106 #ifndef mPUSHi
 107 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
 108 #endif
 109
 110 #ifndef GvCV_set
 111 # define GvCV_set(G, C) (GvCV(G) = (C))
 112 #endif
 113
 114 #ifndef CvGV_set
 115 # define CvGV_set(C, G) (CvGV(C) = (G))
 116 #endif
 117
 118 #ifndef CvSTASH_set
 119 # define CvSTASH_set(C, S) (CvSTASH(C) = (S))
 120 #endif
 121
 122 #ifndef CvISXSUB
 123 # define CvISXSUB(C) CvXSUB(C)
 124 #endif
 125
 126 #ifndef PadlistARRAY
 127 # define PadlistARRAY(P) AvARRAY(P)
 128 # define PadARRAY(P)     AvARRAY(P)
 129 #endif
 130
 131 #ifndef CxHASARGS
 132 # define CxHASARGS(C) ((C)->blk_sub.hasargs)
 133 #endif
 134
 135 #ifndef CxGIMME
 136 # ifdef G_WANT
 137 #  define CxGIMME(C) ((C)->blk_gimme & G_WANT)
 138 # else
 139 #  define CxGIMME(C) ((C)->blk_gimme)
 140 # endif
 141 #endif
 142
 143 #ifndef CxOLD_OP_TYPE
 144 # define CxOLD_OP_TYPE(C) (C)->blk_eval.old_op_type
 145 #endif
 146
 147 #ifndef OutCopFILE
 148 # define OutCopFILE(C) CopFILE(C)
 149 #endif
 150
 151 #ifndef OutCopFILE_len
 152 # define OutCopFILE_len(C) strlen(OutCopFILE(C))
 153 #endif
 154
 155 #ifndef CopHINTS_get
 156 # define CopHINTS_get(C) ((I32) (C)->op_private & HINT_PRIVATE_MASK)
 157 #endif
 158
 159 #ifndef CopHINTHASH_get
 160 # define CopHINTHASH_get(C) (C)->cop_hints_hash
 161 #endif
 162
 163 #ifndef cophh_2hv
 164 # define COPHH           struct refcounted_he
 165 # define cophh_2hv(H, F) Perl_refcounted_he_chain_2hv(aTHX_ (H))
 166 #endif
 167
 168 #ifndef HvNAME_get
 169 # define HvNAME_get(H) HvNAME(H)
 170 #endif
 171
 172 #ifndef HvNAMELEN
 173 # define HvNAMELEN(H) strlen(HvNAME(H))
 174 #endif
 175
 176 #ifndef gv_fetchpvn_flags
 177 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 178 #endif
 179
 180 #ifndef hv_fetchs
 181 # define hv_fetchs(H, K, L) hv_fetch((H), (K), sizeof(K)-1, (L))
 182 #endif
 183
 184 #ifndef OP_GIMME_REVERSE
 185 static U8 su_op_gimme_reverse(U8 gimme) {
 186  switch (gimme) {
 187   case G_VOID:
 188    return OPf_WANT_VOID;
 189   case G_ARRAY:
 190    return OPf_WANT_LIST;
 191   default:
 192    break;
 193  }
 194
 195  return OPf_WANT_SCALAR;
 196 }
 197 #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
 198 #endif
 199
 200 #ifndef OpSIBLING
 201 # ifdef OP_SIBLING
 202 #  define OpSIBLING(O) OP_SIBLING(O)
 203 # else
 204 #  define OpSIBLING(O) ((O)->op_sibling)
 205 # endif
 206 #endif
 207
 208 #ifndef PERL_MAGIC_tied
 209 # define PERL_MAGIC_tied 'P'
 210 #endif
 211
 212 #ifndef PERL_MAGIC_env
 213 # define PERL_MAGIC_env 'E'
 214 #endif
 215
 216 #ifndef NEGATIVE_INDICES_VAR
 217 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
 218 #endif
 219
 220 #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
 221 #define SU_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S)))
 222
 223 /* --- Threads and multiplicity -------------------------------------------- */
 224
 225 #ifndef SU_MULTIPLICITY
 226 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
 227 #  define SU_MULTIPLICITY 1
 228 # else
 229 #  define SU_MULTIPLICITY 0
 230 # endif
 231 #endif
 232 #if SU_MULTIPLICITY && !defined(tTHX)
 233 # define tTHX PerlInterpreter*
 234 #endif
 235
 236 #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))
 237 # define SU_THREADSAFE 1
 238 # ifndef MY_CXT_CLONE
 239 #  define MY_CXT_CLONE \
 240     dMY_CXT_SV;                                                      \
 241     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
 242     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
 243     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 244 # endif
 245 #else
 246 # define SU_THREADSAFE 0
 247 # undef  dMY_CXT
 248 # define dMY_CXT      dNOOP
 249 # undef  MY_CXT
 250 # define MY_CXT       su_globaldata
 251 # undef  START_MY_CXT
 252 # define START_MY_CXT static my_cxt_t MY_CXT;
 253 # undef  MY_CXT_INIT
 254 # define MY_CXT_INIT  NOOP
 255 # undef  MY_CXT_CLONE
 256 # define MY_CXT_CLONE NOOP
 257 #endif
 258
 259 /* --- Error messages ------------------------------------------------------ */
 260
 261 static const char su_stack_smash[]    = "Cannot target a scope outside of the current stack";
 262 static const char su_no_such_target[] = "No targetable %s scope in the current stack";
 263
 264 /* --- Unique context ID global storage ------------------------------------ */
 265
 266 /* ... Sequence ID counter ................................................. */
 267
 268 typedef struct {
 269  UV     *seqs;
 270  STRLEN  size;
 271 } su_uv_array;
 272
 273 static su_uv_array su_uid_seq_counter;
 274
 275 #ifdef USE_ITHREADS
 276
 277 static perl_mutex su_uid_seq_counter_mutex;
 278
 279 #define SU_LOCK(M)   MUTEX_LOCK(M)
 280 #define SU_UNLOCK(M) MUTEX_UNLOCK(M)
 281
 282 #else /* USE_ITHREADS */
 283
 284 #define SU_LOCK(M)
 285 #define SU_UNLOCK(M)
 286
 287 #endif /* !USE_ITHREADS */
 288
 289 static UV su_uid_seq_next(pTHX_ UV depth) {
 290 #define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D))
 291  UV seq;
 292  UV *seqs;
 293
 294  SU_LOCK(&su_uid_seq_counter_mutex);
 295
 296  seqs = su_uid_seq_counter.seqs;
 297
 298  if (depth >= su_uid_seq_counter.size) {
 299   UV i;
 300
 301   seqs = PerlMemShared_realloc(seqs, (depth + 1) * sizeof(UV));
 302   for (i = su_uid_seq_counter.size; i <= depth; ++i)
 303    seqs[i] = 0;
 304
 305   su_uid_seq_counter.seqs = seqs;
 306   su_uid_seq_counter.size = depth + 1;
 307  }
 308
 309  seq = ++seqs[depth];
 310
 311  SU_UNLOCK(&su_uid_seq_counter_mutex);
 312
 313  return seq;
 314 }
 315
 316 /* ... UID storage ......................................................... */
 317
 318 typedef struct {
 319  UV  seq;
 320  U32 flags;
 321 } su_uid;
 322
 323 #define SU_UID_ACTIVE 1
 324
 325 static UV su_uid_depth(pTHX_ I32 cxix) {
 326 #define su_uid_depth(I) su_uid_depth(aTHX_ (I))
 327  const PERL_SI *si;
 328  UV depth;
 329
 330  depth = cxix;
 331  for (si = PL_curstackinfo->si_prev; si; si = si->si_prev)
 332   depth += si->si_cxix + 1;
 333
 334  return depth;
 335 }
 336
 337 typedef struct {
 338  su_uid *map;
 339  STRLEN  used;
 340  STRLEN  alloc;
 341 } su_uid_storage;
 342
 343 static void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) {
 344 #define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D))
 345  su_uid *old_map = old_cxt->map;
 346
 347  if (old_map) {
 348   su_uid *new_map  = new_cxt->map;
 349   STRLEN  old_used = old_cxt->used;
 350   STRLEN  new_used, new_alloc;
 351   STRLEN  i;
 352
 353   new_used      = max_depth < old_used ? max_depth : old_used;
 354   new_cxt->used = new_used;
 355
 356   if (new_used <= new_cxt->alloc) {
 357    new_alloc      = new_cxt->alloc;
 358   } else {
 359    new_alloc      = new_used;
 360    Renew(new_map, new_alloc, su_uid);
 361    new_cxt->map   = new_map;
 362    new_cxt->alloc = new_alloc;
 363   }
 364
 365   for (i = 0; i < new_alloc; ++i) {
 366    su_uid *new_uid = new_map + i;
 367
 368    if (i < new_used) { /* => i < max_depth && i < old_used */
 369     su_uid *old_uid = old_map + i;
 370
 371     if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) {
 372      *new_uid = *old_uid;
 373      continue;
 374     }
 375    }
 376
 377    new_uid->seq   = 0;
 378    new_uid->flags = 0;
 379   }
 380  }
 381
 382  return;
 383 }
 384
 385 /* --- unwind() global storage --------------------------------------------- */
 386
 387 typedef struct {
 388  I32      cxix;
 389  I32      items;
 390  SV     **savesp;
 391  LISTOP   return_op;
 392  OP       proxy_op;
 393 } su_unwind_storage;
 394
 395 /* --- yield() global storage ---------------------------------------------- */
 396
 397 typedef struct {
 398  I32      cxix;
 399  I32      items;
 400  SV     **savesp;
 401  UNOP     leave_op;
 402  OP       proxy_op;
 403 } su_yield_storage;
 404
 405 /* --- uplevel() data tokens and global storage ---------------------------- */
 406
 407 #define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0)
 408
 409 typedef struct {
 410  void          *next;
 411
 412  su_uid_storage tmp_uid_storage;
 413  su_uid_storage old_uid_storage;
 414
 415  I32            cxix;
 416
 417  I32            target_depth;
 418  CV            *target;
 419
 420  CV            *callback;
 421  CV            *renamed;
 422
 423  PERL_SI       *si;
 424  PERL_SI       *old_curstackinfo;
 425  AV            *old_mainstack;
 426
 427  COP           *old_curcop;
 428
 429  OP            *old_op;
 430 #if SU_UPLEVEL_HIJACKS_RUNOPS
 431  runops_proc_t  old_runops;
 432 #endif
 433  bool           old_catch;
 434
 435  bool           died;
 436 } su_uplevel_ud;
 437
 438 static su_uplevel_ud *su_uplevel_ud_new(pTHX) {
 439 #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
 440  su_uplevel_ud *sud;
 441  PERL_SI       *si;
 442
 443  Newx(sud, 1, su_uplevel_ud);
 444  sud->next = NULL;
 445
 446  sud->tmp_uid_storage.map   = NULL;
 447  sud->tmp_uid_storage.used  = 0;
 448  sud->tmp_uid_storage.alloc = 0;
 449
 450  Newx(si, 1, PERL_SI);
 451  si->si_stack   = newAV();
 452  AvREAL_off(si->si_stack);
 453  si->si_cxstack = NULL;
 454  si->si_cxmax   = 0;
 455
 456  sud->si = si;
 457
 458  return sud;
 459 }
 460
 461 static void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
 462 #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
 463  PERL_SI *si = sud->si;
 464
 465  Safefree(si->si_cxstack);
 466  SvREFCNT_dec(si->si_stack);
 467  Safefree(si);
 468
 469  Safefree(sud->tmp_uid_storage.map);
 470
 471  Safefree(sud);
 472
 473  return;
 474 }
 475
 476 typedef struct {
 477  su_uplevel_ud *top;
 478  su_uplevel_ud *root;
 479  I32            count;
 480 } su_uplevel_storage;
 481
 482 #ifndef SU_UPLEVEL_STORAGE_SIZE
 483 # define SU_UPLEVEL_STORAGE_SIZE 4
 484 #endif
 485
 486 /* --- Global data --------------------------------------------------------- */
 487
 488 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 489
 490 typedef struct {
 491  char               *stack_placeholder;
 492  su_unwind_storage   unwind_storage;
 493  su_yield_storage    yield_storage;
 494  su_uplevel_storage  uplevel_storage;
 495  su_uid_storage      uid_storage;
 496 } my_cxt_t;
 497
 498 START_MY_CXT
 499
 500 /* --- Stack manipulations ------------------------------------------------- */
 501
 502 #define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder)
 503
 504 #define SU_SAVE_DESTRUCTOR_SIZE  3
 505 #define SU_SAVE_PLACEHOLDER_SIZE 3
 506
 507 #define SU_SAVE_SCALAR_SIZE 3
 508
 509 #define SU_SAVE_ARY_SIZE      3
 510 #define SU_SAVE_AELEM_SIZE    4
 511 #ifdef SAVEADELETE
 512 # define SU_SAVE_ADELETE_SIZE 3
 513 #else
 514 # define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
 515 #endif
 516 #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
 517 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
 518 #else
 519 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
 520 #endif
 521
 522 #define SU_SAVE_HASH_SIZE    3
 523 #define SU_SAVE_HELEM_SIZE   4
 524 #define SU_SAVE_HDELETE_SIZE 4
 525 #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
 526 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
 527 #else
 528 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
 529 #endif
 530
 531 #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
 532
 533 #if !SU_HAS_PERL(5, 8, 9)
 534 # define SU_SAVE_GP_SIZE 6
 535 #elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0))
 536 # define SU_SAVE_GP_SIZE 3
 537 #elif !SU_HAS_PERL(5, 13, 8)
 538 # define SU_SAVE_GP_SIZE 4
 539 #else
 540 # define SU_SAVE_GP_SIZE 3
 541 #endif
 542
 543 #ifndef SvCANEXISTDELETE
 544 # define SvCANEXISTDELETE(sv) \
 545   (!SvRMAGICAL(sv)            \
 546    || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied))            \
 547        && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \
 548        && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)     \
 549        && gv_fetchmethod_autoload(stash, "DELETE", TRUE)     \
 550       )                       \
 551    )
 552 #endif
 553
 554 /* ... Saving array elements ............................................... */
 555
 556 static I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
 557 #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K))
 558  I32 idx;
 559
 560  if (key >= 0)
 561   return key;
 562
 563 /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */
 564 #if SU_HAS_PERL(5, 8, 1)
 565  if (SvRMAGICAL(av)) {
 566   const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
 567   if (tied_magic) {
 568    SV * const * const negative_indices_glob =
 569                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
 570                              NEGATIVE_INDICES_VAR, 16, 0);
 571    if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 572     return key;
 573   }
 574  }
 575 #endif
 576
 577  idx = key + av_len(av) + 1;
 578  if (idx < 0)
 579   return key;
 580
 581  return idx;
 582 }
 583
 584 #ifndef SAVEADELETE
 585
 586 typedef struct {
 587  AV *av;
 588  I32 idx;
 589 } su_ud_adelete;
 590
 591 static void su_adelete(pTHX_ void *ud_) {
 592  su_ud_adelete *ud = (su_ud_adelete *) ud_;
 593
 594  av_delete(ud->av, ud->idx, G_DISCARD);
 595  SvREFCNT_dec(ud->av);
 596
 597  Safefree(ud);
 598 }
 599
 600 static void su_save_adelete(pTHX_ AV *av, I32 idx) {
 601 #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K))
 602  su_ud_adelete *ud;
 603
 604  Newx(ud, 1, su_ud_adelete);
 605  ud->av  = av;
 606  ud->idx = idx;
 607  SvREFCNT_inc_simple_void(av);
 608
 609  SAVEDESTRUCTOR_X(su_adelete, ud);
 610 }
 611
 612 #define SAVEADELETE(A, K) su_save_adelete((A), (K))
 613
 614 #endif /* SAVEADELETE */
 615
 616 static void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) {
 617 #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V))
 618  I32 idx;
 619  I32 preeminent = 1;
 620  SV **svp;
 621  HV *stash;
 622  MAGIC *mg;
 623
 624  idx = su_av_key2idx(av, SvIV(key));
 625
 626  if (SvCANEXISTDELETE(av))
 627   preeminent = av_exists(av, idx);
 628
 629  svp = av_fetch(av, idx, 1);
 630  if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
 631
 632  if (preeminent)
 633   save_aelem(av, idx, svp);
 634  else
 635   SAVEADELETE(av, idx);
 636
 637  if (val) { /* local $x[$idx] = $val; */
 638   SvSetMagicSV(*svp, val);
 639  } else {   /* local $x[$idx]; delete $x[$idx]; */
 640   av_delete(av, idx, G_DISCARD);
 641  }
 642 }
 643
 644 /* ... Saving hash elements ................................................ */
 645
 646 static void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
 647 #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V))
 648  I32 preeminent = 1;
 649  HE *he;
 650  SV **svp;
 651  HV *stash;
 652  MAGIC *mg;
 653
 654  if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env))
 655   preeminent = hv_exists_ent(hv, keysv, 0);
 656
 657  he  = hv_fetch_ent(hv, keysv, 1, 0);
 658  svp = he ? &HeVAL(he) : NULL;
 659  if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
 660
 661  if (HvNAME_get(hv) && isGV(*svp)) {
 662   save_gp((GV *) *svp, 0);
 663   return;
 664  }
 665
 666  if (preeminent)
 667   save_helem(hv, keysv, svp);
 668  else {
 669   STRLEN keylen;
 670   const char * const key = SvPV_const(keysv, keylen);
 671   SAVEDELETE(hv, savepvn(key, keylen),
 672                  SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
 673  }
 674
 675  if (val) { /* local $x{$keysv} = $val; */
 676   SvSetMagicSV(*svp, val);
 677  } else {   /* local $x{$keysv}; delete $x{$keysv}; */
 678   (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
 679  }
 680 }
 681
 682 /* ... Saving code slots from a glob ....................................... */
 683
 684 #if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in)
 685 # define mro_method_changed_in(G) PL_sub_generation++
 686 #endif
 687
 688 typedef struct {
 689  GV *gv;
 690  CV *old_cv;
 691 } su_save_gvcv_ud;
 692
 693 static void su_restore_gvcv(pTHX_ void *ud_) {
 694  su_save_gvcv_ud *ud = ud_;
 695  GV              *gv = ud->gv;
 696
 697  GvCV_set(gv, ud->old_cv);
 698  GvCVGEN(gv) = 0;
 699  mro_method_changed_in(GvSTASH(gv));
 700
 701  Safefree(ud);
 702 }
 703
 704 static void su_save_gvcv(pTHX_ GV *gv) {
 705 #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G))
 706  su_save_gvcv_ud *ud;
 707
 708  Newx(ud, 1, su_save_gvcv_ud);
 709  ud->gv     = gv;
 710  ud->old_cv = GvCV(gv);
 711
 712  GvCV_set(gv, NULL);
 713  GvCVGEN(gv) = 0;
 714  mro_method_changed_in(GvSTASH(gv));
 715
 716  SAVEDESTRUCTOR_X(su_restore_gvcv, ud);
 717 }
 718
 719 /* --- Actions ------------------------------------------------------------- */
 720
 721 typedef struct {
 722  U8   type;
 723  U8   private;
 724  U8   pad;
 725  /* spare */
 726  I32  depth;
 727  I32 *origin;
 728 } su_ud_common;
 729
 730 #define SU_UD_TYPE(U)    (((su_ud_common *) (U))->type)
 731 #define SU_UD_PRIVATE(U) (((su_ud_common *) (U))->private)
 732 #define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
 733 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
 734 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
 735
 736 #define SU_UD_TYPE_REAP     0
 737 #define SU_UD_TYPE_LOCALIZE 1
 738 #define SU_UD_TYPE_UID      2
 739
 740 #define SU_UD_FREE(U) STMT_START { \
 741  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
 742  Safefree(U); \
 743 } STMT_END
 744
 745 /* ... Reap ................................................................ */
 746
 747 #define SU_SAVE_LAST_CX (!SU_HAS_PERL(5, 8, 4) || (SU_HAS_PERL(5, 9, 5) && !SU_HAS_PERL(5, 14, 0)) || SU_HAS_PERL(5, 15, 0))
 748
 749 typedef struct {
 750  su_ud_common ci;
 751  SV          *cb;
 752 } su_ud_reap;
 753
 754 #define SU_UD_REAP_CB(U) (((su_ud_reap *) (U))->cb)
 755
 756 static void su_call(pTHX_ SV *cb) {
 757 #if SU_SAVE_LAST_CX
 758  I32 cxix;
 759  PERL_CONTEXT saved_cx;
 760 #endif /* SU_SAVE_LAST_CX */
 761
 762  dSP;
 763
 764  SU_D({
 765   PerlIO_printf(Perl_debug_log,
 766                 "@@@ call scope_ix=%2d save_ix=%2d\n",
 767                 PL_scopestack_ix, PL_savestack_ix);
 768  });
 769
 770  ENTER;
 771  SAVETMPS;
 772
 773  PUSHMARK(SP);
 774  PUTBACK;
 775
 776 #if SU_SAVE_LAST_CX
 777  /* If the recently popped context isn't saved there, it will be overwritten by
 778   * the sub scope from call_sv, although it's still needed in our caller. */
 779  cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
 780  saved_cx = cxstack[cxix];
 781 #endif /* SU_SAVE_LAST_CX */
 782
 783  call_sv(cb, G_VOID);
 784
 785 #if SU_SAVE_LAST_CX
 786  cxstack[cxix] = saved_cx;
 787 #endif /* SU_SAVE_LAST_CX */
 788
 789  PUTBACK;
 790
 791  FREETMPS;
 792  LEAVE;
 793
 794  SvREFCNT_dec(cb);
 795
 796  return;
 797 }
 798
 799 /* ... Localize & localize array/hash element .............................. */
 800
 801 typedef struct {
 802  su_ud_common ci;
 803  SV          *sv;
 804  SV          *val;
 805  SV          *elem;
 806 } su_ud_localize;
 807
 808 #define SU_UD_LOCALIZE_SV(U)   (((su_ud_localize *) (U))->sv)
 809 #define SU_UD_LOCALIZE_VAL(U)  (((su_ud_localize *) (U))->val)
 810 #define SU_UD_LOCALIZE_ELEM(U) (((su_ud_localize *) (U))->elem)
 811
 812 #define SU_UD_LOCALIZE_FREE(U) STMT_START { \
 813  SvREFCNT_dec(SU_UD_LOCALIZE_ELEM(U)); \
 814  SvREFCNT_dec(SU_UD_LOCALIZE_VAL(U)); \
 815  SvREFCNT_dec(SU_UD_LOCALIZE_SV(U)); \
 816  SU_UD_FREE(U); \
 817 } STMT_END
 818
 819 static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
 820 #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
 821  UV deref = 0;
 822  svtype t = SVt_NULL;
 823  I32 size;
 824
 825  SvREFCNT_inc_simple_void(sv);
 826
 827  if (SvTYPE(sv) >= SVt_PVGV) {
 828   if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
 829    t = SVt_PVGV;
 830   } else {                   /* local *x = \$val; */
 831    t = SvTYPE(SvRV(val));
 832    deref = 1;
 833   }
 834  } else if (SvROK(sv)) {
 835   croak("Invalid %s reference as the localization target",
 836                  sv_reftype(SvRV(sv), 0));
 837  } else {
 838   STRLEN len, l;
 839   const char *p = SvPV_const(sv, len), *s;
 840   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
 841   if (!l) {
 842    l = len;
 843    s = p;
 844   }
 845   switch (*s) {
 846    case '$': t = SVt_PV;   break;
 847    case '@': t = SVt_PVAV; break;
 848    case '%': t = SVt_PVHV; break;
 849    case '&': t = SVt_PVCV; break;
 850    case '*': t = SVt_PVGV; break;
 851   }
 852   if (t != SVt_NULL) {
 853    ++s;
 854    --l;
 855   } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
 856    if (SvROK(val) && !sv_isobject(val)) {
 857     t = SvTYPE(SvRV(val));
 858     deref = 1;
 859    } else {
 860     t = SvTYPE(val);
 861    }
 862   }
 863   SvREFCNT_dec(sv);
 864   sv = newSVpvn(s, l);
 865  }
 866
 867  switch (t) {
 868   case SVt_PVAV:
 869    size  = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
 870                 : SU_SAVE_ARY_SIZE;
 871    deref = 0;
 872    break;
 873   case SVt_PVHV:
 874    size  = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
 875                 : SU_SAVE_HASH_SIZE;
 876    deref = 0;
 877    break;
 878   case SVt_PVGV:
 879    size  = SU_SAVE_GP_SIZE;
 880    deref = 0;
 881    break;
 882   case SVt_PVCV:
 883    size  = SU_SAVE_GVCV_SIZE;
 884    deref = 0;
 885    break;
 886   default:
 887    size = SU_SAVE_SCALAR_SIZE;
 888    break;
 889  }
 890  /* When deref is set, val isn't NULL */
 891
 892  SU_UD_PRIVATE(ud) = t;
 893
 894  ud->sv   = sv;
 895  ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
 896  ud->elem = SvREFCNT_inc(elem);
 897
 898  return size;
 899 }
 900
 901 static void su_localize(pTHX_ void *ud_) {
 902 #define su_localize(U) su_localize(aTHX_ (U))
 903  su_ud_localize *ud = (su_ud_localize *) ud_;
 904  SV *sv   = ud->sv;
 905  SV *val  = ud->val;
 906  SV *elem = ud->elem;
 907  svtype t = SU_UD_PRIVATE(ud);
 908  GV *gv;
 909
 910  if (SvTYPE(sv) >= SVt_PVGV) {
 911   gv = (GV *) sv;
 912  } else {
 913 #ifdef gv_fetchsv
 914   gv = gv_fetchsv(sv, GV_ADDMULTI, t);
 915 #else
 916   STRLEN len;
 917   const char *name = SvPV_const(sv, len);
 918   gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
 919 #endif
 920  }
 921
 922  SU_D({
 923   SV *z = newSV(0);
 924   SvUPGRADE(z, t);
 925   PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0));
 926   PerlIO_printf(Perl_debug_log,
 927                 "%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
 928                  ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
 929   SvREFCNT_dec(z);
 930  });
 931
 932  /* Inspired from Alias.pm */
 933  switch (t) {
 934   case SVt_PVAV:
 935    if (elem) {
 936     su_save_aelem(GvAV(gv), elem, val);
 937     return;
 938    } else
 939     save_ary(gv);
 940    break;
 941   case SVt_PVHV:
 942    if (elem) {
 943     su_save_helem(GvHV(gv), elem, val);
 944     return;
 945    } else
 946     save_hash(gv);
 947    break;
 948   case SVt_PVGV:
 949    save_gp(gv, 1); /* hide previous entry in symtab */
 950    break;
 951   case SVt_PVCV:
 952    su_save_gvcv(gv);
 953    break;
 954   default:
 955    gv = (GV *) save_scalar(gv);
 956    break;
 957  }
 958
 959  if (val)
 960   SvSetMagicSV((SV *) gv, val);
 961
 962  return;
 963 }
 964
 965 /* ... Unique context ID ................................................... */
 966
 967 /* We must pass the index because MY_CXT.uid_storage might be reallocated
 968  * between the UID fetch and the invalidation at the end of scope. */
 969
 970 typedef struct {
 971  su_ud_common ci;
 972  I32          idx;
 973 } su_ud_uid;
 974
 975 static void su_uid_drop(pTHX_ void *ud_) {
 976  su_ud_uid *ud = ud_;
 977  dMY_CXT;
 978
 979  MY_CXT.uid_storage.map[ud->idx].flags &= ~SU_UID_ACTIVE;
 980
 981  SU_UD_FREE(ud);
 982
 983  return;
 984 }
 985
 986 /* --- Pop a context back -------------------------------------------------- */
 987
 988 #ifdef DEBUGGING
 989 # define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
 990 #else
 991 # if SU_HAS_PERL(5, 11, 0)
 992 static const char *su_block_type[] = {
 993  "NULL",
 994  "WHEN",
 995  "BLOCK",
 996  "GIVEN",
 997  "LOOP_FOR",
 998  "LOOP_PLAIN",
 999  "LOOP_LAZYSV",
1000  "LOOP_LAZYIV",
1001  "SUB",
1002  "FORMAT",
1003  "EVAL",
1004  "SUBST"
1005 };
1006 # elif SU_HAS_PERL(5, 9, 3)
1007 static const char *su_block_type[] = {
1008  "NULL",
1009  "SUB",
1010  "EVAL",
1011  "WHEN",
1012  "SUBST",
1013  "BLOCK",
1014  "FORMAT",
1015  "GIVEN",
1016  "LOOP_FOR",
1017  "LOOP_PLAIN",
1018  "LOOP_LAZYSV",
1019  "LOOP_LAZYIV"
1020 };
1021 # else
1022 static const char *su_block_type[] = {
1023  "NULL",
1024  "SUB",
1025  "EVAL",
1026  "LOOP",
1027  "SUBST",
1028  "BLOCK"
1029 };
1030 # endif
1031 # define SU_CXNAME(C) su_block_type[CxTYPE(C)]
1032 #endif
1033
1034 static void su_pop(pTHX_ void *ud) {
1035 #define su_pop(U) su_pop(aTHX_ (U))
1036  I32 depth, base, mark, *origin;
1037  depth = SU_UD_DEPTH(ud);
1038
1039  SU_D(
1040   PerlIO_printf(Perl_debug_log,
1041    "%p: --- pop a %s\n"
1042    "%p: leave scope     at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n",
1043     ud, SU_CXNAME(cxstack + cxstack_ix),
1044     ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix])
1045  );
1046
1047  origin = SU_UD_ORIGIN(ud);
1048  mark   = origin[depth];
1049  base   = origin[depth - 1];
1050
1051  SU_D(PerlIO_printf(Perl_debug_log,
1052                     "%p: original scope was %*c top=%2d     base=%2d\n",
1053                      ud,                24, ' ',    mark,        base));
1054
1055  if (base < mark) {
1056 #if SU_HAS_PERL(5, 19, 4)
1057   I32 save = -1;
1058   PERL_CONTEXT *cx;
1059 #endif
1060
1061   SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
1062
1063 #if SU_HAS_PERL(5, 19, 4)
1064   cx = cxstack + cxstack_ix;
1065   if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1066    save = PL_scopestack[cx->blk_oldscopesp - 1];
1067 #endif
1068
1069   PL_savestack_ix = mark;
1070   leave_scope(base);
1071
1072 #if SU_HAS_PERL(5, 19, 4)
1073   if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1074    PL_scopestack[cx->blk_oldscopesp - 1] = save;
1075 #endif
1076  }
1077  PL_savestack_ix = base;
1078
1079  SU_UD_DEPTH(ud) = --depth;
1080
1081  if (depth > 0) {
1082   U8 pad;
1083
1084   if ((pad = SU_UD_PAD(ud)) > 0) {
1085    dMY_CXT;
1086    do {
1087     SU_D(PerlIO_printf(Perl_debug_log,
1088           "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n",
1089            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
1090     SU_SAVE_PLACEHOLDER();
1091    } while (--pad);
1092   }
1093
1094   SU_D(PerlIO_printf(Perl_debug_log,
1095           "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
1096            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
1097   SAVEDESTRUCTOR_X(su_pop, ud);
1098  } else {
1099   switch (SU_UD_TYPE(ud)) {
1100    case SU_UD_TYPE_REAP: {
1101     SU_D({
1102      PerlIO_printf(Perl_debug_log,
1103                 "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
1104                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
1105     });
1106     SAVEDESTRUCTOR_X(su_call, SU_UD_REAP_CB(ud));
1107     SU_UD_FREE(ud);
1108     break;
1109    }
1110    case SU_UD_TYPE_LOCALIZE:
1111     su_localize(ud);
1112     SU_UD_LOCALIZE_FREE(ud);
1113     break;
1114    case SU_UD_TYPE_UID:
1115     SAVEDESTRUCTOR_X(su_uid_drop, ud);
1116     break;
1117   }
1118  }
1119
1120  SU_D(PerlIO_printf(Perl_debug_log,
1121                     "%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
1122                      ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
1123 }
1124
1125 /* --- Initialize the stack and the action userdata ------------------------ */
1126
1127 static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
1128 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
1129  I32 i, depth, offset, base, *origin;
1130  U8 pad;
1131
1132  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
1133
1134  /* su_pop() is going to be called from leave_scope(), so before pushing the
1135   * next callback, we'll want to flush the current scope stack slice first.
1136   * However, if we want the next callback not to be processed immediately by
1137   * the current leave_scope(), we'll need to hide it by artificially
1138   * incrementing the scope stack marker before. For the intermediate bumps,
1139   * we will only need a bump of SU_SAVE_DESTRUCTOR_SIZE items, but for the
1140   * last one we will need a bump of size items. However, in order to preserve
1141   * the natural ordering between scope stack markers, we cannot bump lower
1142   * markers more than higher ones. This is why we bump the intermediate markers
1143   * by the smallest multiple of SU_SAVE_PLACEHOLDER_SIZE greater or equal to
1144   * max(SU_SAVE_DESTRUCTOR_SIZE, size). */
1145
1146  if (size <= SU_SAVE_DESTRUCTOR_SIZE)
1147   pad = 0;
1148  else {
1149   I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
1150   pad = extra / SU_SAVE_PLACEHOLDER_SIZE;
1151   if (extra % SU_SAVE_PLACEHOLDER_SIZE)
1152    ++pad;
1153  }
1154  offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad;
1155
1156  SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
1157                                      ud,    size,   pad,   offset));
1158
1159  depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp;
1160  SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
1161
1162  /* We need to bump all the intermediary stack markers just in case an
1163   * exception is thrown before the target scope is reached. Indeed, in this
1164   * case there might be arbitrary many scope frames flushed at the same time,
1165   * and since we cannot know in advance whether this will happen or not, we
1166   * have to make sure the final frame is protected for the actual action. But
1167   * of course, in order to do that, we also need to bump all the previous stack
1168   * markers. If not for this, it should have been possible to just bump the two
1169   * next frames in su_pop(). */
1170
1171  Newx(origin, depth + 1, I32);
1172  base = PL_scopestack_ix - depth;
1173  origin[0] = PL_scopestack[base];
1174  PL_scopestack[base] += size;
1175  for (i = 1; i < depth; ++i) {
1176   I32 j = i + base;
1177   origin[i] = PL_scopestack[j];
1178   PL_scopestack[j] += offset;
1179  }
1180  origin[depth] = PL_savestack_ix;
1181
1182  SU_UD_PAD(ud)    = pad;
1183  SU_UD_DEPTH(ud)  = depth;
1184  SU_UD_ORIGIN(ud) = origin;
1185
1186  /* Make sure the first destructor fires by pushing enough fake slots on the
1187   * stack. */
1188  if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
1189                                        <= PL_scopestack[PL_scopestack_ix - 1]) {
1190   dMY_CXT;
1191   do {
1192    SU_D(PerlIO_printf(Perl_debug_log,
1193                   "%p: push a fake slot      at scope_ix=%2d  save_ix=%2d\n",
1194                    ud,                      PL_scopestack_ix, PL_savestack_ix));
1195    SU_SAVE_PLACEHOLDER();
1196   } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
1197                                         <= PL_scopestack[PL_scopestack_ix - 1]);
1198  }
1199  SU_D(PerlIO_printf(Perl_debug_log,
1200                   "%p: push first destructor at scope_ix=%2d  save_ix=%2d\n",
1201                    ud,                      PL_scopestack_ix, PL_savestack_ix));
1202  SAVEDESTRUCTOR_X(su_pop, ud);
1203
1204  SU_D({
1205   for (i = 0; i <= depth; ++i) {
1206    I32 j = PL_scopestack_ix  - i;
1207    PerlIO_printf(Perl_debug_log,
1208                  "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n",
1209                   ud,        i, j, origin[depth - i],
1210                                    i == 0 ? PL_savestack_ix : PL_scopestack[j]);
1211   }
1212  });
1213
1214  return depth;
1215 }
1216
1217 /* --- Unwind stack -------------------------------------------------------- */
1218
1219 static void su_unwind(pTHX_ void *ud_) {
1220  dMY_CXT;
1221  I32 cxix  = MY_CXT.unwind_storage.cxix;
1222  I32 items = MY_CXT.unwind_storage.items;
1223  I32 mark;
1224
1225  PERL_UNUSED_VAR(ud_);
1226
1227  PL_stack_sp = MY_CXT.unwind_storage.savesp;
1228 #if SU_HAS_PERL(5, 19, 4)
1229  {
1230   I32 i;
1231   SV **sp = PL_stack_sp;
1232   for (i = -items + 1; i <= 0; ++i)
1233    if (!SvTEMP(sp[i]))
1234     sv_2mortal(SvREFCNT_inc(sp[i]));
1235  }
1236 #endif
1237
1238  if (cxstack_ix > cxix)
1239   dounwind(cxix);
1240
1241  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
1242  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
1243
1244  SU_D({
1245   I32 gimme = GIMME_V;
1246   PerlIO_printf(Perl_debug_log,
1247                 "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
1248                 &MY_CXT, cxix,
1249                 gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
1250                 items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
1251  });
1252
1253  PL_op = (OP *) &(MY_CXT.unwind_storage.return_op);
1254  PL_op = PL_op->op_ppaddr(aTHX);
1255
1256  *PL_markstack_ptr = mark;
1257
1258  MY_CXT.unwind_storage.proxy_op.op_next = PL_op;
1259  PL_op = &(MY_CXT.unwind_storage.proxy_op);
1260 }
1261
1262 /* --- Yield --------------------------------------------------------------- */
1263
1264 #if SU_HAS_PERL(5, 10, 0)
1265 # define SU_RETOP_SUB(C)   ((C)->blk_sub.retop)
1266 # define SU_RETOP_EVAL(C)  ((C)->blk_eval.retop)
1267 # define SU_RETOP_LOOP(C)  ((C)->blk_loop.my_op->op_lastop->op_next)
1268 # define SU_RETOP_GIVEN(C) ((C)->blk_givwhen.leave_op->op_next)
1269 #else
1270 # define SU_RETOP_SUB(C)  ((C)->blk_oldretsp > 0 ? PL_retstack[(C)->blk_oldretsp - 1] : NULL)
1271 # define SU_RETOP_EVAL(C) SU_RETOP_SUB(C)
1272 # define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next)
1273 #endif
1274
1275 static void su_yield(pTHX_ void *ud_) {
1276  dMY_CXT;
1277  PERL_CONTEXT *cx;
1278  const char   *which = ud_;
1279  I32 cxix      = MY_CXT.yield_storage.cxix;
1280  I32 items     = MY_CXT.yield_storage.items;
1281  opcode  type  = OP_NULL;
1282  U8      flags = 0;
1283  OP     *next;
1284
1285  PERL_UNUSED_VAR(ud_);
1286
1287  cx = cxstack + cxix;
1288  switch (CxTYPE(cx)) {
1289   case CXt_BLOCK: {
1290    I32 i, cur = cxstack_ix, n = 1;
1291    OP *o = NULL;
1292    /* Is this actually a given/when block? This may occur only when yield was
1293     * called with HERE (or nothing) as the context. */
1294 #if SU_HAS_PERL(5, 10, 0)
1295    if (cxix > 0) {
1296     PERL_CONTEXT *prev = cx - 1;
1297     U8       prev_type = CxTYPE(prev);
1298     if ((prev_type == CXt_GIVEN || prev_type == CXt_WHEN)
1299         && (prev->blk_oldcop == cx->blk_oldcop)) {
1300      cxix--;
1301      cx = prev;
1302      if (prev_type == CXt_GIVEN)
1303       goto cxt_given;
1304      else
1305       goto cxt_when;
1306     }
1307    }
1308 #endif
1309    type  = OP_LEAVE;
1310    next  = NULL;
1311    /* Bare blocks (that appear as do { ... } blocks, map { ... } blocks or
1312     * constant folded blcoks) don't need to save the op to return to anywhere
1313     * since 'last' isn't supposed to work inside them. So we climb higher in
1314     * the context stack until we reach a context that has a return op (i.e. a
1315     * sub, an eval, a format or a real loop), recording how many blocks we
1316     * crossed. Then we follow the op_next chain until we get to the leave op
1317     * that closes the original block, which we are assured to reach since
1318     * everything is static (the blocks we have crossed cannot be evals or
1319     * subroutine calls). */
1320    for (i = cxix + 1; i <= cur; ++i) {
1321     PERL_CONTEXT *cx2 = cxstack + i;
1322     switch (CxTYPE(cx2)) {
1323      case CXt_BLOCK:
1324       ++n;
1325       break;
1326      case CXt_SUB:
1327      case CXt_FORMAT:
1328       o = SU_RETOP_SUB(cx2);
1329       break;
1330      case CXt_EVAL:
1331       o = SU_RETOP_EVAL(cx2);
1332       break;
1333 #if SU_HAS_PERL(5, 11, 0)
1334      case CXt_LOOP_FOR:
1335      case CXt_LOOP_PLAIN:
1336      case CXt_LOOP_LAZYSV:
1337      case CXt_LOOP_LAZYIV:
1338 #else
1339      case CXt_LOOP:
1340 #endif
1341       o = SU_RETOP_LOOP(cx2);
1342       break;
1343     }
1344     if (o)
1345      break;
1346    }
1347    if (!o)
1348     o = PL_op;
1349    while (n && o) {
1350     /* We may find other enter/leave blocks on our way to the matching leave.
1351      * Make sure the depth is incremented/decremented appropriately. */
1352     if (o->op_type == OP_ENTER) {
1353      ++n;
1354     } else if (o->op_type == OP_LEAVE) {
1355      --n;
1356      if (!n) {
1357       next = o->op_next;
1358       break;
1359      }
1360     }
1361     o = o->op_next;
1362    }
1363    break;
1364   }
1365   case CXt_SUB:
1366   case CXt_FORMAT:
1367    type = OP_LEAVESUB;
1368    next = SU_RETOP_SUB(cx);
1369    break;
1370   case CXt_EVAL:
1371    type = CxTRYBLOCK(cx) ? OP_LEAVETRY : OP_LEAVEEVAL;
1372    next = SU_RETOP_EVAL(cx);
1373    break;
1374 #if SU_HAS_PERL(5, 11, 0)
1375   case CXt_LOOP_FOR:
1376   case CXt_LOOP_PLAIN:
1377   case CXt_LOOP_LAZYSV:
1378   case CXt_LOOP_LAZYIV:
1379 #else
1380   case CXt_LOOP:
1381 #endif
1382    type = OP_LEAVELOOP;
1383    next = SU_RETOP_LOOP(cx);
1384    break;
1385 #if SU_HAS_PERL(5, 10, 0)
1386   case CXt_GIVEN:
1387 cxt_given:
1388    type = OP_LEAVEGIVEN;
1389    next = SU_RETOP_GIVEN(cx);
1390    break;
1391   case CXt_WHEN:
1392 cxt_when:
1393 #if SU_HAS_PERL(5, 15, 1)
1394    type   = OP_LEAVEWHEN;
1395 #else
1396    type   = OP_BREAK;
1397    flags |= OPf_SPECIAL;
1398 #endif
1399    next   = NULL;
1400    break;
1401 #endif
1402   case CXt_SUBST:
1403    croak("%s() can't target a substitution context", which);
1404    break;
1405   default:
1406    croak("%s() doesn't know how to leave a %s context",
1407           which,                         SU_CXNAME(cxstack + cxix));
1408    break;
1409  }
1410
1411  PL_stack_sp = MY_CXT.yield_storage.savesp;
1412 #if SU_HAS_PERL(5, 19, 4)
1413  {
1414   I32 i;
1415   SV **sp = PL_stack_sp;
1416   for (i = -items + 1; i <= 0; ++i)
1417    if (!SvTEMP(sp[i]))
1418     sv_2mortal(SvREFCNT_inc(sp[i]));
1419  }
1420 #endif
1421
1422  if (cxstack_ix > cxix)
1423   dounwind(cxix);
1424
1425  /* Copy the arguments passed to yield() where the leave op expects to find
1426   * them. */
1427  if (items)
1428   Move(PL_stack_sp - items + 1, PL_stack_base + cx->blk_oldsp + 1, items, SV *);
1429  PL_stack_sp = PL_stack_base + cx->blk_oldsp + items;
1430
1431  flags |= OP_GIMME_REVERSE(cx->blk_gimme);
1432
1433  MY_CXT.yield_storage.leave_op.op_type   = type;
1434  MY_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type];
1435  MY_CXT.yield_storage.leave_op.op_flags  = flags;
1436  MY_CXT.yield_storage.leave_op.op_next   = next;
1437
1438  PL_op = (OP *) &(MY_CXT.yield_storage.leave_op);
1439  PL_op = PL_op->op_ppaddr(aTHX);
1440
1441  MY_CXT.yield_storage.proxy_op.op_next = PL_op;
1442  PL_op = &(MY_CXT.yield_storage.proxy_op);
1443 }
1444
1445 /* --- Uplevel ------------------------------------------------------------- */
1446
1447 #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
1448 #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
1449
1450 static su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) {
1451 #define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I))
1452  su_uplevel_ud *sud;
1453  UV depth;
1454  dMY_CXT;
1455
1456  sud = MY_CXT.uplevel_storage.root;
1457  if (sud) {
1458   MY_CXT.uplevel_storage.root = sud->next;
1459   MY_CXT.uplevel_storage.count--;
1460  } else {
1461   sud = su_uplevel_ud_new();
1462  }
1463
1464  sud->next = MY_CXT.uplevel_storage.top;
1465  MY_CXT.uplevel_storage.top = sud;
1466
1467  depth = su_uid_depth(cxix);
1468  su_uid_storage_dup(&sud->tmp_uid_storage, &MY_CXT.uid_storage, depth);
1469  sud->old_uid_storage = MY_CXT.uid_storage;
1470  MY_CXT.uid_storage   = sud->tmp_uid_storage;
1471
1472  return sud;
1473 }
1474
1475 #if SU_HAS_PERL(5, 13, 7)
1476
1477 static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
1478 #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
1479  dMY_CXT;
1480
1481  sud->tmp_uid_storage = MY_CXT.uid_storage;
1482  MY_CXT.uid_storage   = sud->old_uid_storage;
1483  {
1484   su_uid *map;
1485   STRLEN  i, alloc;
1486   map   = sud->tmp_uid_storage.map;
1487   alloc = sud->tmp_uid_storage.alloc;
1488   for (i = 0; i < alloc; ++i)
1489    map[i].flags &= ~SU_UID_ACTIVE;
1490  }
1491  MY_CXT.uplevel_storage.top = sud->next;
1492
1493  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
1494   su_uplevel_ud_delete(sud);
1495  } else {
1496   sud->next = MY_CXT.uplevel_storage.root;
1497   MY_CXT.uplevel_storage.root = sud;
1498   MY_CXT.uplevel_storage.count++;
1499  }
1500 }
1501
1502 #endif
1503
1504 static int su_uplevel_goto_static(const OP *o) {
1505  for (; o; o = OpSIBLING(o)) {
1506   /* goto ops are unops with kids. */
1507   if (!(o->op_flags & OPf_KIDS))
1508    continue;
1509
1510   switch (o->op_type) {
1511    case OP_LEAVEEVAL:
1512    case OP_LEAVETRY:
1513     /* Don't care about gotos inside eval, as they are forbidden at run time. */
1514     break;
1515    case OP_GOTO:
1516     return 1;
1517    default:
1518     if (su_uplevel_goto_static(((const UNOP *) o)->op_first))
1519      return 1;
1520     break;
1521   }
1522  }
1523
1524  return 0;
1525 }
1526
1527 #if SU_UPLEVEL_HIJACKS_RUNOPS
1528
1529 static int su_uplevel_goto_runops(pTHX) {
1530 #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
1531  register OP *op;
1532  dVAR;
1533
1534  op = PL_op;
1535  do {
1536   if (op->op_type == OP_GOTO) {
1537    AV  *argarray = NULL;
1538    I32  cxix;
1539
1540    for (cxix = cxstack_ix; cxix >= 0; --cxix) {
1541     const PERL_CONTEXT *cx = cxstack + cxix;
1542
1543     switch (CxTYPE(cx)) {
1544      case CXt_SUB:
1545       if (CxHASARGS(cx)) {
1546        argarray = cx->blk_sub.argarray;
1547        goto done;
1548       }
1549       break;
1550      case CXt_EVAL:
1551      case CXt_FORMAT:
1552       goto done;
1553      default:
1554       break;
1555     }
1556    }
1557
1558 done:
1559    if (argarray) {
1560     dMY_CXT;
1561
1562     if (MY_CXT.uplevel_storage.top->cxix == cxix) {
1563      AV  *args  = GvAV(PL_defgv);
1564      I32  items = AvFILLp(args);
1565
1566      av_extend(argarray, items);
1567      Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
1568      AvFILLp(argarray) = items;
1569     }
1570    }
1571   }
1572
1573   PL_op = op = op->op_ppaddr(aTHX);
1574
1575 #if !SU_HAS_PERL(5, 13, 0)
1576   PERL_ASYNC_CHECK();
1577 #endif
1578  } while (op);
1579
1580  TAINT_NOT;
1581
1582  return 0;
1583 }
1584
1585 #endif /* SU_UPLEVEL_HIJACKS_RUNOPS */
1586
1587 #define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
1588
1589 static void su_uplevel_restore(pTHX_ void *sus_) {
1590  su_uplevel_ud *sud = sus_;
1591  PERL_SI *cur = sud->old_curstackinfo;
1592  PERL_SI *si  = sud->si;
1593
1594 #if SU_UPLEVEL_HIJACKS_RUNOPS
1595  if (PL_runops == su_uplevel_goto_runops)
1596   PL_runops = sud->old_runops;
1597 #endif
1598
1599  if (sud->callback) {
1600   PERL_CONTEXT *cx = cxstack + sud->cxix;
1601   AV     *argarray = MUTABLE_AV(su_at_underscore(sud->callback));
1602
1603   /* We have to fix the pad entry for @_ in the original callback because it
1604    * may have been reified. */
1605   if (AvREAL(argarray)) {
1606    const I32 fill = AvFILLp(argarray);
1607    SvREFCNT_dec(argarray);
1608    argarray = newAV();
1609    AvREAL_off(argarray);
1610    AvREIFY_on(argarray);
1611    av_extend(argarray, fill);
1612    su_at_underscore(sud->callback) = MUTABLE_SV(argarray);
1613   } else {
1614    CLEAR_ARGARRAY(argarray);
1615   }
1616
1617   /* If the old cv member is our renamed CV, it means that this place has been
1618    * reached without a goto() happening, and the old argarray member is
1619    * actually our fake argarray. Destroy it properly in that case. */
1620   if (cx->blk_sub.cv == sud->renamed) {
1621    SvREFCNT_dec(cx->blk_sub.argarray);
1622    cx->blk_sub.argarray = argarray;
1623   }
1624
1625   CvDEPTH(sud->callback)--;
1626   SvREFCNT_dec(sud->callback);
1627  }
1628
1629  /* Free the renamed CV. We must do it ourselves so that we can force the
1630   * depth to be 0, or perl would complain about it being "still in use".
1631   * But we *know* that it cannot be so. */
1632  if (sud->renamed) {
1633   if (!CvISXSUB(sud->renamed)) {
1634    CvDEPTH(sud->renamed)   = 0;
1635    CvPADLIST(sud->renamed) = NULL;
1636   }
1637   SvREFCNT_dec(sud->renamed);
1638  }
1639
1640  CATCH_SET(sud->old_catch);
1641
1642  SU_UPLEVEL_RESTORE(op);
1643
1644  /* stack_grow() wants PL_curstack so restore the old stack first */
1645  if (PL_curstackinfo == si) {
1646   PL_curstack = cur->si_stack;
1647   if (sud->old_mainstack)
1648    SU_UPLEVEL_RESTORE(mainstack);
1649   SU_UPLEVEL_RESTORE(curstackinfo);
1650
1651   if (sud->died) {
1652    CV *target = sud->target;
1653    I32 levels = 0, i;
1654
1655    /* When we die, the depth of the target CV is not updated because of the
1656     * stack switcheroo. So we have to look at all the frames between the
1657     * uplevel call and the catch block to count how many call frames to the
1658     * target CV were skipped. */
1659    for (i = cur->si_cxix; i > sud->cxix; i--) {
1660     register const PERL_CONTEXT *cx = cxstack + i;
1661
1662     if (CxTYPE(cx) == CXt_SUB) {
1663      if (cx->blk_sub.cv == target)
1664       ++levels;
1665     }
1666    }
1667
1668    /* If we died, the replacement stack was already unwinded to the first
1669     * eval frame, and all the contexts down there were popped. We don't have
1670     * to pop manually any context of the original stack, because they must
1671     * have been in the replacement stack as well (since the second was copied
1672     * from the first). Thus we only have to make sure the original stack index
1673     * points to the context just below the first eval scope under the target
1674     * frame. */
1675    for (; i >= 0; i--) {
1676     register const PERL_CONTEXT *cx = cxstack + i;
1677
1678     switch (CxTYPE(cx)) {
1679      case CXt_SUB:
1680       if (cx->blk_sub.cv == target)
1681        ++levels;
1682       break;
1683      case CXt_EVAL:
1684       goto found_it;
1685       break;
1686      default:
1687       break;
1688     }
1689    }
1690
1691 found_it:
1692    CvDEPTH(target) = sud->target_depth - levels;
1693    PL_curstackinfo->si_cxix = i - 1;
1694
1695 #if !SU_HAS_PERL(5, 13, 1)
1696    /* Since $@ was maybe localized between the target frame and the uplevel
1697     * call, we forcefully flush the save stack to get rid of it and then
1698     * reset $@ to its proper value. Note that the the call to
1699     * su_uplevel_restore() must happen before the "reset $@" item of the save
1700     * stack is processed, as uplevel was called after the localization.
1701     * Andrew's changes to how $@ was handled, which were mainly integrated
1702     * between perl 5.13.0 and 5.13.1, fixed this. */
1703    if (ERRSV && SvTRUE(ERRSV)) {
1704     register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1705     SV *errsv = SvREFCNT_inc(ERRSV);
1706     PL_scopestack_ix = cx->blk_oldscopesp;
1707     leave_scope(PL_scopestack[PL_scopestack_ix]);
1708     sv_setsv(ERRSV, errsv);
1709     SvREFCNT_dec(errsv);
1710    }
1711 #endif
1712   }
1713  }
1714
1715  SU_UPLEVEL_RESTORE(curcop);
1716
1717  SvREFCNT_dec(sud->target);
1718
1719  PL_stack_base = AvARRAY(cur->si_stack);
1720  PL_stack_sp   = PL_stack_base + AvFILLp(cur->si_stack);
1721  PL_stack_max  = PL_stack_base + AvMAX(cur->si_stack);
1722
1723  /* When an exception is thrown from the uplevel'd subroutine,
1724   * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed
1725   * die_where() in more recent perls), which has the sad habit of keeping a
1726   * pointer to the current context frame across this call. This means that we
1727   * can't free the temporary context stack we used for the uplevel call right
1728   * now, or that pointer upwards would point to garbage. */
1729 #if SU_HAS_PERL(5, 13, 7)
1730  /* This issue has been fixed in perl with commit 8f89e5a9, which was made
1731   * public in perl 5.13.7. */
1732  su_uplevel_storage_delete(sud);
1733 #else
1734  /* Otherwise, we just enqueue it back in the global storage list. */
1735  {
1736   dMY_CXT;
1737
1738   sud->tmp_uid_storage = MY_CXT.uid_storage;
1739   MY_CXT.uid_storage   = sud->old_uid_storage;
1740
1741   MY_CXT.uplevel_storage.top  = sud->next;
1742   sud->next = MY_CXT.uplevel_storage.root;
1743   MY_CXT.uplevel_storage.root = sud;
1744   MY_CXT.uplevel_storage.count++;
1745  }
1746 #endif
1747
1748  return;
1749 }
1750
1751 static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
1752 #define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
1753  dVAR;
1754  CV *cv;
1755
1756  cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1757
1758  CvFLAGS(cv)  = CvFLAGS(proto);
1759 #ifdef CVf_CVGV_RC
1760  CvFLAGS(cv) &= ~CVf_CVGV_RC;
1761 #endif
1762  CvDEPTH(cv)  = CvDEPTH(proto);
1763 #ifdef USE_ITHREADS
1764  CvFILE(cv)   = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto));
1765 #else
1766  CvFILE(cv)   = CvFILE(proto);
1767 #endif
1768
1769  CvGV_set(cv, gv);
1770 #if SU_RELEASE && SU_HAS_PERL_EXACT(5, 21, 4)
1771  CvNAMED_off(cv);
1772 #endif
1773  CvSTASH_set(cv, CvSTASH(proto));
1774  /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
1775   * stashes. CvSTASH_set() started to do it as well with commit c68d95645
1776   * (which was part of perl 5.13.7). */
1777 #if SU_HAS_PERL(5, 13, 3) && !SU_HAS_PERL(5, 13, 7)
1778  if (CvSTASH(proto))
1779   Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
1780 #endif
1781
1782  if (CvISXSUB(proto)) {
1783   CvXSUB(cv)       = CvXSUB(proto);
1784   CvXSUBANY(cv)    = CvXSUBANY(proto);
1785  } else {
1786   OP_REFCNT_LOCK;
1787   CvROOT(cv)       = OpREFCNT_inc(CvROOT(proto));
1788   OP_REFCNT_UNLOCK;
1789   CvSTART(cv)      = CvSTART(proto);
1790   CvPADLIST(cv)    = CvPADLIST(proto);
1791  }
1792  CvOUTSIDE(cv)     = CvOUTSIDE(proto);
1793 #ifdef CVf_WEAKOUTSIDE
1794  if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
1795 #endif
1796   SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
1797 #ifdef CvOUTSIDE_SEQ
1798  CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1799 #endif
1800
1801  if (SvPOK(proto))
1802   sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1803
1804 #ifdef CvCONST
1805  if (CvCONST(cv))
1806   CvCONST_off(cv);
1807 #endif
1808
1809  return cv;
1810 }
1811
1812 static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
1813 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1814  su_uplevel_ud *sud;
1815  const PERL_CONTEXT *cx = cxstack + cxix;
1816  PERL_SI *si;
1817  PERL_SI *cur = PL_curstackinfo;
1818  SV **old_stack_sp;
1819  CV  *target;
1820  CV  *renamed;
1821  UNOP sub_op;
1822  I32  gimme;
1823  I32  old_mark, new_mark;
1824  I32  ret;
1825  dSP;
1826
1827  ENTER;
1828
1829  gimme = GIMME_V;
1830  /* Make PL_stack_sp point just before the CV. */
1831  PL_stack_sp -= args + 1;
1832  old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1833  SPAGAIN;
1834
1835  sud = su_uplevel_storage_new(cxix);
1836
1837  sud->cxix     = cxix;
1838  sud->died     = 1;
1839  sud->callback = NULL;
1840  sud->renamed  = NULL;
1841  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1842
1843  si = sud->si;
1844
1845  si->si_type    = cur->si_type;
1846  si->si_next    = NULL;
1847  si->si_prev    = cur->si_prev;
1848 #ifdef DEBUGGING
1849  si->si_markoff = cx->blk_oldmarksp;
1850 #endif
1851
1852  /* Allocate enough space for all the elements of the original stack up to the
1853   * target context, plus the forthcoming arguments. */
1854  new_mark = cx->blk_oldsp;
1855  av_extend(si->si_stack, new_mark + 1 + args + 1);
1856  Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1857  AvFILLp(si->si_stack) = new_mark;
1858  SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1859
1860  /* Specialized SWITCHSTACK() */
1861  PL_stack_base = AvARRAY(si->si_stack);
1862  old_stack_sp  = PL_stack_sp;
1863  PL_stack_sp   = PL_stack_base + AvFILLp(si->si_stack);
1864  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
1865  SPAGAIN;
1866
1867  /* Copy the context stack up to the context just below the target. */
1868  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1869  if (si->si_cxmax < cxix) {
1870   /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1871   si->si_cxmax = (cxix < 4) ? 4 : cxix;
1872   Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1873  }
1874  Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1875  SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1876
1877  target            = cx->blk_sub.cv;
1878  sud->target       = (CV *) SvREFCNT_inc(target);
1879  sud->target_depth = CvDEPTH(target);
1880
1881  /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1882   * run-time implication, since PL_curcop will be overwritten as soon as we
1883   * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1884   * make it point to the blk_oldcop for the target frame, so that caller()
1885   * reports the right file name, line number and lexical hints. */
1886  SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1887  /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1888   * this point. Don't reset PL_curpm either, we want the most recent matches. */
1889
1890  SU_UPLEVEL_SAVE(curstackinfo, si);
1891  /* If those two are equal, we need to fool POPSTACK_TO() */
1892  if (PL_mainstack == PL_curstack)
1893   SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1894  else
1895   sud->old_mainstack = NULL;
1896  PL_curstack = si->si_stack;
1897
1898  renamed      = su_cv_clone(callback, CvGV(target));
1899  sud->renamed = renamed;
1900
1901  PUSHMARK(SP);
1902  /* Both SP and old_stack_sp point just before the CV. */
1903  Copy(old_stack_sp + 2, SP + 1, args, SV *);
1904  SP += args;
1905  PUSHs((SV *) renamed);
1906  PUTBACK;
1907
1908  Zero(&sub_op, 1, UNOP);
1909  sub_op.op_type  = OP_ENTERSUB;
1910  sub_op.op_next  = NULL;
1911  sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1912  if (PL_DBsub)
1913   sub_op.op_flags |= OPpENTERSUB_DB;
1914
1915  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1916
1917 #if SU_UPLEVEL_HIJACKS_RUNOPS
1918  sud->old_runops = PL_runops;
1919 #endif
1920
1921  sud->old_catch = CATCH_GET;
1922  CATCH_SET(TRUE);
1923
1924  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
1925   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
1926
1927   /* If pp_entersub() returns a non-null OP, it means that the callback is not
1928    * an XSUB. */
1929
1930   sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
1931   CvDEPTH(callback)++;
1932
1933   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1934    /* The call to pp_entersub() has saved the current @_ (in XS terms,
1935     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1936     * with what we put on the stack. But we want to fake up the same arguments
1937     * as the ones in use at the context we uplevel to, so we replace the
1938     * argarray with an unreal copy of the original @_. */
1939    AV *av = newAV();
1940    AvREAL_off(av);
1941    AvREIFY_on(av);
1942    av_extend(av, AvMAX(cx->blk_sub.argarray));
1943    AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1944    Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1945    sub_cx->blk_sub.argarray = av;
1946   } else {
1947    SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
1948   }
1949
1950   if (su_uplevel_goto_static(CvROOT(renamed))) {
1951 #if SU_UPLEVEL_HIJACKS_RUNOPS
1952    if (PL_runops != PL_runops_std) {
1953     if (PL_runops == PL_runops_dbg) {
1954      if (PL_debug)
1955       croak("uplevel() can't execute code that calls goto when debugging flags are set");
1956     } else if (PL_runops != su_uplevel_goto_runops)
1957      croak("uplevel() can't execute code that calls goto with a custom runloop");
1958    }
1959
1960    PL_runops = su_uplevel_goto_runops;
1961 #else  /* SU_UPLEVEL_HIJACKS_RUNOPS */
1962    croak("uplevel() can't execute code that calls goto before perl 5.8");
1963 #endif /* !SU_UPLEVEL_HIJACKS_RUNOPS */
1964   }
1965
1966   CALLRUNOPS(aTHX);
1967  }
1968
1969  sud->died = 0;
1970
1971  ret = PL_stack_sp - (PL_stack_base + new_mark);
1972  if (ret > 0) {
1973   AV *old_stack = sud->old_curstackinfo->si_stack;
1974
1975   if (old_mark + ret > AvMAX(old_stack)) {
1976    /* Specialized EXTEND(old_sp, ret) */
1977    av_extend(old_stack, old_mark + ret + 1);
1978    old_stack_sp = AvARRAY(old_stack) + old_mark;
1979   }
1980
1981   Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1982   PL_stack_sp        += ret;
1983   AvFILLp(old_stack) += ret;
1984  }
1985
1986  LEAVE;
1987
1988  return ret;
1989 }
1990
1991 /* --- Unique context ID --------------------------------------------------- */
1992
1993 static su_uid *su_uid_storage_fetch(pTHX_ UV depth) {
1994 #define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D))
1995  su_uid *map;
1996  STRLEN  alloc;
1997  dMY_CXT;
1998
1999  map   = MY_CXT.uid_storage.map;
2000  alloc = MY_CXT.uid_storage.alloc;
2001
2002  if (depth >= alloc) {
2003   STRLEN i;
2004
2005   Renew(map, depth + 1, su_uid);
2006   for (i = alloc; i <= depth; ++i) {
2007    map[i].seq   = 0;
2008    map[i].flags = 0;
2009   }
2010
2011   MY_CXT.uid_storage.map   = map;
2012   MY_CXT.uid_storage.alloc = depth + 1;
2013  }
2014
2015  if (depth >= MY_CXT.uid_storage.used)
2016   MY_CXT.uid_storage.used = depth + 1;
2017
2018  return map + depth;
2019 }
2020
2021 static int su_uid_storage_check(pTHX_ UV depth, UV seq) {
2022 #define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S))
2023  su_uid *uid;
2024  dMY_CXT;
2025
2026  if (depth >= MY_CXT.uid_storage.used)
2027   return 0;
2028
2029  uid = MY_CXT.uid_storage.map + depth;
2030
2031  return (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE);
2032 }
2033
2034 static SV *su_uid_get(pTHX_ I32 cxix) {
2035 #define su_uid_get(I) su_uid_get(aTHX_ (I))
2036  su_uid *uid;
2037  SV     *uid_sv;
2038  UV      depth;
2039
2040  depth = su_uid_depth(cxix);
2041  uid   = su_uid_storage_fetch(depth);
2042
2043  if (!(uid->flags & SU_UID_ACTIVE)) {
2044   su_ud_uid *ud;
2045
2046   uid->seq    = su_uid_seq_next(depth);
2047   uid->flags |= SU_UID_ACTIVE;
2048
2049   Newx(ud, 1, su_ud_uid);
2050   SU_UD_TYPE(ud) = SU_UD_TYPE_UID;
2051   ud->idx        = depth;
2052   su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
2053  }
2054
2055  uid_sv = sv_newmortal();
2056  sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq);
2057
2058  return uid_sv;
2059 }
2060
2061 #ifdef grok_number
2062
2063 #define su_grok_number(S, L, VP) grok_number((S), (L), (VP))
2064
2065 #else /* grok_number */
2066
2067 #define IS_NUMBER_IN_UV 0x1
2068
2069 static int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) {
2070 #define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP))
2071  STRLEN i;
2072  SV *tmpsv;
2073
2074  /* This crude check should be good enough for a fallback implementation.
2075   * Better be too strict than too lax. */
2076  for (i = 0; i < len; ++i) {
2077   if (!isDIGIT(s[i]))
2078    return 0;
2079  }
2080
2081  tmpsv = sv_newmortal();
2082  sv_setpvn(tmpsv, s, len);
2083  *valuep = sv_2uv(tmpsv);
2084
2085  return IS_NUMBER_IN_UV;
2086 }
2087
2088 #endif /* !grok_number */
2089
2090 static int su_uid_validate(pTHX_ SV *uid) {
2091 #define su_uid_validate(U) su_uid_validate(aTHX_ (U))
2092  const char *s;
2093  STRLEN len, p = 0;
2094  UV depth, seq;
2095  int type;
2096
2097  s = SvPV_const(uid, len);
2098
2099  while (p < len && s[p] != '-')
2100   ++p;
2101  if (p >= len)
2102   croak("UID contains only one part");
2103
2104  type = su_grok_number(s, p, &depth);
2105  if (type != IS_NUMBER_IN_UV)
2106   croak("First UID part is not an unsigned integer");
2107
2108  ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */
2109
2110  type = su_grok_number(s + p, len - p, &seq);
2111  if (type != IS_NUMBER_IN_UV)
2112   croak("Second UID part is not an unsigned integer");
2113
2114  return su_uid_storage_check(depth, seq);
2115 }
2116
2117 /* --- Context operations -------------------------------------------------- */
2118
2119 /* Remove sequences of BLOCKs having DB for stash, followed by a SUB context
2120  * for the debugger callback. */
2121
2122 static I32 su_context_skip_db(pTHX_ I32 cxix) {
2123 #define su_context_skip_db(C) su_context_skip_db(aTHX_ (C))
2124  I32 i;
2125
2126  if (!PL_DBsub)
2127   return cxix;
2128
2129  for (i = cxix; i > 0; --i) {
2130   PERL_CONTEXT *cx = cxstack + i;
2131
2132   switch (CxTYPE(cx)) {
2133 #if SU_HAS_PERL(5, 17, 1)
2134    case CXt_LOOP_PLAIN:
2135 #endif
2136    case CXt_BLOCK:
2137     if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv))
2138      continue;
2139     break;
2140    case CXt_SUB:
2141     if (cx->blk_sub.cv == GvCV(PL_DBsub)) {
2142      cxix = i - 1;
2143      continue;
2144     }
2145     break;
2146    default:
2147     break;
2148   }
2149
2150   break;
2151  }
2152
2153  return cxix;
2154 }
2155
2156
2157 static I32 su_context_normalize_up(pTHX_ I32 cxix) {
2158 #define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C))
2159  PERL_CONTEXT *cx;
2160
2161  if (cxix <= 0)
2162   return 0;
2163
2164  cx = cxstack + cxix;
2165  if (CxTYPE(cx) == CXt_BLOCK) {
2166   PERL_CONTEXT *prev = cx - 1;
2167
2168   switch (CxTYPE(prev)) {
2169 #if SU_HAS_PERL(5, 10, 0)
2170    case CXt_GIVEN:
2171    case CXt_WHEN:
2172 #endif
2173 #if SU_HAS_PERL(5, 11, 0)
2174    /* That's the only subcategory that can cause an extra BLOCK context */
2175    case CXt_LOOP_PLAIN:
2176 #else
2177    case CXt_LOOP:
2178 #endif
2179     if (cx->blk_oldcop == prev->blk_oldcop)
2180      return cxix - 1;
2181     break;
2182    case CXt_SUBST:
2183     if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop)
2184                        && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST)
2185      return cxix - 1;
2186     break;
2187   }
2188  }
2189
2190  return cxix;
2191 }
2192
2193 static I32 su_context_normalize_down(pTHX_ I32 cxix) {
2194 #define su_context_normalize_down(C) su_context_normalize_down(aTHX_ (C))
2195  PERL_CONTEXT *next;
2196
2197  if (cxix >= cxstack_ix)
2198   return cxstack_ix;
2199
2200  next = cxstack + cxix + 1;
2201  if (CxTYPE(next) == CXt_BLOCK) {
2202   PERL_CONTEXT *cx = next - 1;
2203
2204   switch (CxTYPE(cx)) {
2205 #if SU_HAS_PERL(5, 10, 0)
2206    case CXt_GIVEN:
2207    case CXt_WHEN:
2208 #endif
2209 #if SU_HAS_PERL(5, 11, 0)
2210    /* That's the only subcategory that can cause an extra BLOCK context */
2211    case CXt_LOOP_PLAIN:
2212 #else
2213    case CXt_LOOP:
2214 #endif
2215     if (cx->blk_oldcop == next->blk_oldcop)
2216      return cxix + 1;
2217     break;
2218    case CXt_SUBST:
2219     if (next->blk_oldcop && OpSIBLING(next->blk_oldcop)
2220                          && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST)
2221      return cxix + 1;
2222     break;
2223   }
2224  }
2225
2226  return cxix;
2227 }
2228
2229 #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix))
2230
2231 static I32 su_context_gimme(pTHX_ I32 cxix) {
2232 #define su_context_gimme(C) su_context_gimme(aTHX_ (C))
2233  I32 i;
2234
2235  for (i = cxix; i >= 0; --i) {
2236   PERL_CONTEXT *cx = cxstack + i;
2237
2238   switch (CxTYPE(cx)) {
2239    /* gimme is always G_ARRAY for loop contexts. */
2240 #if SU_HAS_PERL(5, 11, 0)
2241    case CXt_LOOP_FOR:
2242    case CXt_LOOP_PLAIN:
2243    case CXt_LOOP_LAZYSV:
2244    case CXt_LOOP_LAZYIV:
2245 #else
2246    case CXt_LOOP:
2247 #endif
2248    case CXt_SUBST: {
2249     const COP *cop = cx->blk_oldcop;
2250     if (cop && OpSIBLING(cop)) {
2251      switch (OpSIBLING(cop)->op_flags & OPf_WANT) {
2252       case OPf_WANT_VOID:
2253        return G_VOID;
2254       case OPf_WANT_SCALAR:
2255        return G_SCALAR;
2256       case OPf_WANT_LIST:
2257        return G_ARRAY;
2258       default:
2259        break;
2260      }
2261     }
2262     break;
2263    }
2264    default:
2265     return CxGIMME(cx);
2266     break;
2267   }
2268  }
2269
2270  return G_VOID;
2271 }
2272
2273 /* --- Global setup/teardown ----------------------------------------------- */
2274
2275 static VOL U32 su_initialized = 0;
2276
2277 static void su_global_teardown(pTHX_ void *root) {
2278  if (!su_initialized)
2279   return;
2280
2281 #if SU_MULTIPLICITY
2282  if (aTHX != root)
2283   return;
2284 #endif
2285
2286  SU_LOCK(&su_uid_seq_counter_mutex);
2287  PerlMemShared_free(su_uid_seq_counter.seqs);
2288  su_uid_seq_counter.size = 0;
2289  SU_UNLOCK(&su_uid_seq_counter_mutex);
2290
2291  MUTEX_DESTROY(&su_uid_seq_counter_mutex);
2292
2293  su_initialized = 0;
2294
2295  return;
2296 }
2297
2298 XS(XS_Scope__Upper_unwind);
2299 XS(XS_Scope__Upper_yield);
2300 XS(XS_Scope__Upper_leave);
2301
2302 #if SU_HAS_PERL(5, 9, 0)
2303 # define SU_XS_FILE_TYPE const char
2304 #else
2305 # define SU_XS_FILE_TYPE char
2306 #endif
2307
2308 static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) {
2309 #define su_global_setup(F) su_global_setup(aTHX_ (F))
2310  HV *stash;
2311
2312  if (su_initialized)
2313   return;
2314
2315  MUTEX_INIT(&su_uid_seq_counter_mutex);
2316
2317  SU_LOCK(&su_uid_seq_counter_mutex);
2318  su_uid_seq_counter.seqs = NULL;
2319  su_uid_seq_counter.size = 0;
2320  SU_UNLOCK(&su_uid_seq_counter_mutex);
2321
2322  stash = gv_stashpv(__PACKAGE__, 1);
2323  newCONSTSUB(stash, "TOP",           newSViv(0));
2324  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
2325
2326  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
2327  newXSproto("Scope::Upper::yield",  XS_Scope__Upper_yield,  file, NULL);
2328  newXSproto("Scope::Upper::leave",  XS_Scope__Upper_leave,  file, NULL);
2329
2330 #if SU_MULTIPLICITY
2331  call_atexit(su_global_teardown, aTHX);
2332 #else
2333  call_atexit(su_global_teardown, NULL);
2334 #endif
2335
2336  su_initialized = 1;
2337
2338  return;
2339 }
2340
2341 /* --- Interpreter setup/teardown ------------------------------------------ */
2342
2343 static void su_local_teardown(pTHX_ void *param) {
2344  su_uplevel_ud *cur;
2345  dMY_CXT;
2346
2347  Safefree(MY_CXT.uid_storage.map);
2348
2349  cur = MY_CXT.uplevel_storage.root;
2350  if (cur) {
2351   su_uplevel_ud *prev;
2352   do {
2353    prev = cur;
2354    cur  = prev->next;
2355    su_uplevel_ud_delete(prev);
2356   } while (cur);
2357  }
2358
2359  return;
2360 }
2361
2362 static void su_local_setup(pTHX) {
2363 #define su_local_setup() su_local_setup(aTHX)
2364  MY_CXT_INIT;
2365
2366  MY_CXT.stack_placeholder = NULL;
2367
2368  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
2369  Zero(&(MY_CXT.unwind_storage.return_op), 1, LISTOP);
2370  MY_CXT.unwind_storage.return_op.op_type   = OP_RETURN;
2371  MY_CXT.unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
2372
2373  Zero(&(MY_CXT.unwind_storage.proxy_op), 1, OP);
2374  MY_CXT.unwind_storage.proxy_op.op_type   = OP_STUB;
2375  MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL;
2376
2377  Zero(&(MY_CXT.yield_storage.leave_op), 1, UNOP);
2378  MY_CXT.yield_storage.leave_op.op_type   = OP_STUB;
2379  MY_CXT.yield_storage.leave_op.op_ppaddr = NULL;
2380
2381  Zero(&(MY_CXT.yield_storage.proxy_op), 1, OP);
2382  MY_CXT.yield_storage.proxy_op.op_type   = OP_STUB;
2383  MY_CXT.yield_storage.proxy_op.op_ppaddr = NULL;
2384
2385  MY_CXT.uplevel_storage.top   = NULL;
2386  MY_CXT.uplevel_storage.root  = NULL;
2387  MY_CXT.uplevel_storage.count = 0;
2388
2389  MY_CXT.uid_storage.map   = NULL;
2390  MY_CXT.uid_storage.used  = 0;
2391  MY_CXT.uid_storage.alloc = 0;
2392
2393  call_atexit(su_local_teardown, NULL);
2394
2395  return;
2396 }
2397
2398 /* --- XS ------------------------------------------------------------------ */
2399
2400 #define SU_GET_CONTEXT(A, B, D) \
2401  STMT_START {                   \
2402   if (items > A) {              \
2403    SV *csv = ST(B);             \
2404    if (!SvOK(csv))              \
2405     goto default_cx;            \
2406    cxix = SvIV(csv);            \
2407    if (cxix < 0)                \
2408     cxix = 0;                   \
2409    else if (cxix > cxstack_ix)  \
2410     goto default_cx;            \
2411   } else {                      \
2412 default_cx:                     \
2413    cxix = (D);                  \
2414   }                             \
2415  } STMT_END
2416
2417 #define SU_GET_LEVEL(A, B) \
2418  STMT_START {              \
2419   level = 0;               \
2420   if (items > 0) {         \
2421    SV *lsv = ST(B);        \
2422    if (SvOK(lsv)) {        \
2423     level = SvIV(lsv);     \
2424     if (level < 0)         \
2425      level = 0;            \
2426    }                       \
2427   }                        \
2428  } STMT_END
2429
2430 #if SU_HAS_PERL(5, 10, 0)
2431 # define SU_INFO_COUNT 11
2432 #else
2433 # define SU_INFO_COUNT 10
2434 #endif
2435
2436 XS(XS_Scope__Upper_unwind) {
2437 #ifdef dVAR
2438  dVAR; dXSARGS;
2439 #else
2440  dXSARGS;
2441 #endif
2442  dMY_CXT;
2443  I32 cxix;
2444
2445  PERL_UNUSED_VAR(cv); /* -W */
2446  PERL_UNUSED_VAR(ax); /* -Wall */
2447
2448  SU_GET_CONTEXT(0, items - 1, cxstack_ix);
2449  do {
2450   PERL_CONTEXT *cx = cxstack + cxix;
2451   switch (CxTYPE(cx)) {
2452    case CXt_SUB:
2453     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2454      continue;
2455    case CXt_EVAL:
2456    case CXt_FORMAT:
2457     MY_CXT.unwind_storage.cxix   = cxix;
2458     MY_CXT.unwind_storage.items  = items;
2459     MY_CXT.unwind_storage.savesp = PL_stack_sp;
2460     if (items > 0) {
2461      MY_CXT.unwind_storage.items--;
2462      MY_CXT.unwind_storage.savesp--;
2463     }
2464     /* pp_entersub will want to sanitize the stack after returning from there
2465      * Screw that, we're insane!
2466      * dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
2467     if (GIMME_V == G_SCALAR)
2468      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
2469     SAVEDESTRUCTOR_X(su_unwind, NULL);
2470     return;
2471    default:
2472     break;
2473   }
2474  } while (--cxix >= 0);
2475  croak("Can't return outside a subroutine");
2476 }
2477
2478 static const char su_yield_name[] = "yield";
2479
2480 XS(XS_Scope__Upper_yield) {
2481 #ifdef dVAR
2482  dVAR; dXSARGS;
2483 #else
2484  dXSARGS;
2485 #endif
2486  dMY_CXT;
2487  I32 cxix;
2488
2489  PERL_UNUSED_VAR(cv); /* -W */
2490  PERL_UNUSED_VAR(ax); /* -Wall */
2491
2492  SU_GET_CONTEXT(0, items - 1, su_context_here());
2493  MY_CXT.yield_storage.cxix   = cxix;
2494  MY_CXT.yield_storage.items  = items;
2495  MY_CXT.yield_storage.savesp = PL_stack_sp;
2496  if (items > 0) {
2497   MY_CXT.yield_storage.items--;
2498   MY_CXT.yield_storage.savesp--;
2499  }
2500  /* See XS_Scope__Upper_unwind */
2501  if (GIMME_V == G_SCALAR)
2502   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
2503  SAVEDESTRUCTOR_X(su_yield, su_yield_name);
2504  return;
2505 }
2506
2507 static const char su_leave_name[] = "leave";
2508
2509 XS(XS_Scope__Upper_leave) {
2510 #ifdef dVAR
2511  dVAR; dXSARGS;
2512 #else
2513  dXSARGS;
2514 #endif
2515  dMY_CXT;
2516
2517  PERL_UNUSED_VAR(cv); /* -W */
2518  PERL_UNUSED_VAR(ax); /* -Wall */
2519
2520  MY_CXT.yield_storage.cxix   = su_context_here();
2521  MY_CXT.yield_storage.items  = items;
2522  MY_CXT.yield_storage.savesp = PL_stack_sp;
2523  /* See XS_Scope__Upper_unwind */
2524  if (GIMME_V == G_SCALAR)
2525   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
2526  SAVEDESTRUCTOR_X(su_yield, su_leave_name);
2527  return;
2528 }
2529
2530 MODULE = Scope::Upper            PACKAGE = Scope::Upper
2531
2532 PROTOTYPES: ENABLE
2533
2534 BOOT:
2535 {
2536  su_global_setup(file);
2537  su_local_setup();
2538 }
2539
2540 #if SU_THREADSAFE
2541
2542 void
2543 CLONE(...)
2544 PROTOTYPE: DISABLE
2545 PREINIT:
2546  su_uid_storage new_cxt;
2547 PPCODE:
2548  {
2549   dMY_CXT;
2550   new_cxt.map   = NULL;
2551   new_cxt.used  = 0;
2552   new_cxt.alloc = 0;
2553   su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used);
2554  }
2555  {
2556   MY_CXT_CLONE;
2557   MY_CXT.uplevel_storage.top   = NULL;
2558   MY_CXT.uplevel_storage.root  = NULL;
2559   MY_CXT.uplevel_storage.count = 0;
2560   MY_CXT.uid_storage           = new_cxt;
2561  }
2562  XSRETURN(0);
2563
2564 #endif /* SU_THREADSAFE */
2565
2566 void
2567 HERE()
2568 PROTOTYPE:
2569 PREINIT:
2570  I32 cxix;
2571 PPCODE:
2572  cxix = su_context_here();
2573  EXTEND(SP, 1);
2574  mPUSHi(cxix);
2575  XSRETURN(1);
2576
2577 void
2578 UP(...)
2579 PROTOTYPE: ;$
2580 PREINIT:
2581  I32 cxix;
2582 PPCODE:
2583  SU_GET_CONTEXT(0, 0, su_context_here());
2584  if (cxix > 0) {
2585   --cxix;
2586   cxix = su_context_skip_db(cxix);
2587   cxix = su_context_normalize_up(cxix);
2588  } else {
2589   warn(su_stack_smash);
2590  }
2591  EXTEND(SP, 1);
2592  mPUSHi(cxix);
2593  XSRETURN(1);
2594
2595 void
2596 SUB(...)
2597 PROTOTYPE: ;$
2598 PREINIT:
2599  I32 cxix;
2600 PPCODE:
2601  SU_GET_CONTEXT(0, 0, cxstack_ix);
2602  EXTEND(SP, 1);
2603  for (; cxix >= 0; --cxix) {
2604   PERL_CONTEXT *cx = cxstack + cxix;
2605   switch (CxTYPE(cx)) {
2606    default:
2607     continue;
2608    case CXt_SUB:
2609     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2610      continue;
2611     mPUSHi(cxix);
2612     XSRETURN(1);
2613   }
2614  }
2615  warn(su_no_such_target, "subroutine");
2616  XSRETURN_UNDEF;
2617
2618 void
2619 EVAL(...)
2620 PROTOTYPE: ;$
2621 PREINIT:
2622  I32 cxix;
2623 PPCODE:
2624  SU_GET_CONTEXT(0, 0, cxstack_ix);
2625  EXTEND(SP, 1);
2626  for (; cxix >= 0; --cxix) {
2627   PERL_CONTEXT *cx = cxstack + cxix;
2628   switch (CxTYPE(cx)) {
2629    default:
2630     continue;
2631    case CXt_EVAL:
2632     mPUSHi(cxix);
2633     XSRETURN(1);
2634   }
2635  }
2636  warn(su_no_such_target, "eval");
2637  XSRETURN_UNDEF;
2638
2639 void
2640 SCOPE(...)
2641 PROTOTYPE: ;$
2642 PREINIT:
2643  I32 cxix, level;
2644 PPCODE:
2645  SU_GET_LEVEL(0, 0);
2646  cxix = su_context_here();
2647  while (--level >= 0) {
2648   if (cxix <= 0) {
2649    warn(su_stack_smash);
2650    break;
2651   }
2652   --cxix;
2653   cxix = su_context_skip_db(cxix);
2654   cxix = su_context_normalize_up(cxix);
2655  }
2656  EXTEND(SP, 1);
2657  mPUSHi(cxix);
2658  XSRETURN(1);
2659
2660 void
2661 CALLER(...)
2662 PROTOTYPE: ;$
2663 PREINIT:
2664  I32 cxix, level;
2665 PPCODE:
2666  SU_GET_LEVEL(0, 0);
2667  for (cxix = cxstack_ix; cxix > 0; --cxix) {
2668   PERL_CONTEXT *cx = cxstack + cxix;
2669   switch (CxTYPE(cx)) {
2670    case CXt_SUB:
2671     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2672      continue;
2673    case CXt_EVAL:
2674    case CXt_FORMAT:
2675     if (--level < 0)
2676      goto done;
2677     break;
2678   }
2679  }
2680 done:
2681  if (level >= 0)
2682   warn(su_stack_smash);
2683  EXTEND(SP, 1);
2684  mPUSHi(cxix);
2685  XSRETURN(1);
2686
2687 void
2688 want_at(...)
2689 PROTOTYPE: ;$
2690 PREINIT:
2691  I32 cxix;
2692 PPCODE:
2693  SU_GET_CONTEXT(0, 0, cxstack_ix);
2694  EXTEND(SP, 1);
2695  while (cxix > 0) {
2696   PERL_CONTEXT *cx = cxstack + cxix--;
2697   switch (CxTYPE(cx)) {
2698    case CXt_SUB:
2699     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2700      continue;
2701    case CXt_EVAL:
2702    case CXt_FORMAT: {
2703     I32 gimme = cx->blk_gimme;
2704     switch (gimme) {
2705      case G_VOID:   XSRETURN_UNDEF; break;
2706      case G_SCALAR: XSRETURN_NO;    break;
2707      case G_ARRAY:  XSRETURN_YES;   break;
2708     }
2709     break;
2710    }
2711   }
2712  }
2713  XSRETURN_UNDEF;
2714
2715 void
2716 context_info(...)
2717 PROTOTYPE: ;$
2718 PREINIT:
2719  I32 cxix;
2720  const PERL_CONTEXT *cx, *dbcx;
2721  COP *cop;
2722 PPCODE:
2723  SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix));
2724  cxix = su_context_normalize_up(cxix);
2725  cx   = cxstack + cxix;
2726  dbcx = cx;
2727  if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) {
2728   I32 i = su_context_skip_db(cxix - 1) + 1;
2729   if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB)
2730    cx = cxstack + i;
2731  }
2732  cop  = cx->blk_oldcop;
2733  EXTEND(SP, SU_INFO_COUNT);
2734  /* stash (0) */
2735  {
2736   HV *stash = CopSTASH(cop);
2737   if (stash)
2738    PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash)));
2739   else
2740    PUSHs(&PL_sv_undef);
2741  }
2742  /* file (1) */
2743  PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop)));
2744  /* line (2) */
2745  mPUSHi(CopLINE(cop));
2746  /* subroutine (3) and has_args (4) */
2747  switch (CxTYPE(cx)) {
2748   case CXt_SUB:
2749   case CXt_FORMAT: {
2750    GV *cvgv = CvGV(dbcx->blk_sub.cv);
2751    if (cvgv && isGV(cvgv)) {
2752     SV *sv = sv_newmortal();
2753     gv_efullname3(sv, cvgv, NULL);
2754     PUSHs(sv);
2755    } else {
2756     PUSHs(su_newmortal_pvs("(unknown)"));
2757    }
2758    if (CxHASARGS(cx))
2759     PUSHs(&PL_sv_yes);
2760    else
2761     PUSHs(&PL_sv_no);
2762    break;
2763   }
2764   case CXt_EVAL:
2765    PUSHs(su_newmortal_pvs("(eval)"));
2766    mPUSHi(0);
2767    break;
2768   default:
2769    PUSHs(&PL_sv_undef);
2770    PUSHs(&PL_sv_undef);
2771  }
2772  /* gimme (5) */
2773  switch (su_context_gimme(cxix)) {
2774   case G_ARRAY:
2775    PUSHs(&PL_sv_yes);
2776    break;
2777   case G_SCALAR:
2778    PUSHs(&PL_sv_no);
2779    break;
2780   default: /* G_VOID */
2781    PUSHs(&PL_sv_undef);
2782    break;
2783  }
2784  /* eval text (6) and is_require (7) */
2785  switch (CxTYPE(cx)) {
2786   case CXt_EVAL:
2787    if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2788     /* eval STRING */
2789 #if SU_HAS_PERL(5, 17, 4)
2790     PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
2791                          SvCUR(cx->blk_eval.cur_text)-2,
2792                          SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
2793 #else
2794     PUSHs(cx->blk_eval.cur_text);
2795 #endif
2796     PUSHs(&PL_sv_no);
2797     break;
2798    } else if (cx->blk_eval.old_namesv) {
2799     /* require */
2800     PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv));
2801     PUSHs(&PL_sv_yes);
2802     break;
2803    }
2804    /* FALLTHROUGH */
2805   default:
2806    /* Anything else including eval BLOCK */
2807    PUSHs(&PL_sv_undef);
2808    PUSHs(&PL_sv_undef);
2809    break;
2810  }
2811  /* hints (8) */
2812  mPUSHi(CopHINTS_get(cop));
2813  /* warnings (9) */
2814  {
2815   SV *mask = NULL;
2816 #if SU_HAS_PERL(5, 9, 4)
2817   STRLEN *old_warnings = cop->cop_warnings;
2818 #else
2819   SV *old_warnings = cop->cop_warnings;
2820 #endif
2821   if (old_warnings == pWARN_STD) {
2822    if (PL_dowarn & G_WARN_ON)
2823     goto context_info_warnings_on;
2824    else
2825 #if SU_HAS_PERL(5, 17, 4)
2826     mask = &PL_sv_undef;
2827 #else
2828     goto context_info_warnings_off;
2829 #endif
2830   } else if (old_warnings == pWARN_NONE) {
2831 #if !SU_HAS_PERL(5, 17, 4)
2832 context_info_warnings_off:
2833 #endif
2834    mask = su_newmortal_pvn(WARN_NONEstring, WARNsize);
2835   } else if (old_warnings == pWARN_ALL) {
2836    HV *bits;
2837 context_info_warnings_on:
2838 #if SU_HAS_PERL(5, 8, 7)
2839    bits = get_hv("warnings::Bits", 0);
2840    if (bits) {
2841     SV **bits_all = hv_fetchs(bits, "all", FALSE);
2842     if (bits_all)
2843      mask = sv_mortalcopy(*bits_all);
2844    }
2845 #endif
2846    if (!mask)
2847     mask = su_newmortal_pvn(WARN_ALLstring, WARNsize);
2848   } else {
2849 #if SU_HAS_PERL(5, 9, 4)
2850    mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]);
2851 #else
2852    mask = sv_mortalcopy(old_warnings);
2853 #endif
2854   }
2855   PUSHs(mask);
2856  }
2857 #if SU_HAS_PERL(5, 10, 0)
2858  /* hints hash (10) */
2859  {
2860   COPHH *hints_hash = CopHINTHASH_get(cop);
2861   if (hints_hash) {
2862    SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0)));
2863    PUSHs(rhv);
2864   } else {
2865    PUSHs(&PL_sv_undef);
2866   }
2867  }
2868 #endif
2869  XSRETURN(SU_INFO_COUNT);
2870
2871 void
2872 reap(SV *hook, ...)
2873 PROTOTYPE: &;$
2874 PREINIT:
2875  I32 cxix;
2876  su_ud_reap *ud;
2877 CODE:
2878  SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix));
2879  cxix = su_context_normalize_down(cxix);
2880  Newx(ud, 1, su_ud_reap);
2881  SU_UD_TYPE(ud) = SU_UD_TYPE_REAP;
2882  ud->cb         = (SvROK(hook) && SvTYPE(SvRV(hook)) >= SVt_PVCV)
2883                   ? SvRV(hook) : hook;
2884  SvREFCNT_inc_simple_void(ud->cb);
2885  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
2886
2887 void
2888 localize(SV *sv, SV *val, ...)
2889 PROTOTYPE: $$;$
2890 PREINIT:
2891  I32 cxix;
2892  I32 size;
2893  su_ud_localize *ud;
2894 CODE:
2895  SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
2896  cxix = su_context_normalize_down(cxix);
2897  Newx(ud, 1, su_ud_localize);
2898  SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE;
2899  size = su_ud_localize_init(ud, sv, val, NULL);
2900  su_init(ud, cxix, size);
2901
2902 void
2903 localize_elem(SV *sv, SV *elem, SV *val, ...)
2904 PROTOTYPE: $$$;$
2905 PREINIT:
2906  I32 cxix;
2907  I32 size;
2908  su_ud_localize *ud;
2909 CODE:
2910  if (SvTYPE(sv) >= SVt_PVGV)
2911   croak("Can't infer the element localization type from a glob and the value");
2912  SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix));
2913  cxix = su_context_normalize_down(cxix);
2914  Newx(ud, 1, su_ud_localize);
2915  /* Initialize SU_UD_ORIGIN(ud) in case SU_UD_LOCALIZE_FREE(ud) needs it */
2916  SU_UD_ORIGIN(ud) = NULL;
2917  SU_UD_TYPE(ud)   = SU_UD_TYPE_LOCALIZE;
2918  size = su_ud_localize_init(ud, sv, val, elem);
2919  if (SU_UD_PRIVATE(ud) != SVt_PVAV && SU_UD_PRIVATE(ud) != SVt_PVHV) {
2920   SU_UD_LOCALIZE_FREE(ud);
2921   croak("Can't localize an element of something that isn't an array or a hash");
2922  }
2923  su_init(ud, cxix, size);
2924
2925 void
2926 localize_delete(SV *sv, SV *elem, ...)
2927 PROTOTYPE: $$;$
2928 PREINIT:
2929  I32 cxix;
2930  I32 size;
2931  su_ud_localize *ud;
2932 CODE:
2933  SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
2934  cxix = su_context_normalize_down(cxix);
2935  Newx(ud, 1, su_ud_localize);
2936  SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE;
2937  size = su_ud_localize_init(ud, sv, NULL, elem);
2938  su_init(ud, cxix, size);
2939
2940 void
2941 uplevel(SV *code, ...)
2942 PROTOTYPE: &@
2943 PREINIT:
2944  I32 cxix, ret, args = 0;
2945 PPCODE:
2946  if (SvROK(code))
2947   code = SvRV(code);
2948  if (SvTYPE(code) < SVt_PVCV)
2949   croak("First argument to uplevel must be a code reference");
2950  SU_GET_CONTEXT(1, items - 1, cxstack_ix);
2951  do {
2952   PERL_CONTEXT *cx = cxstack + cxix;
2953   switch (CxTYPE(cx)) {
2954    case CXt_EVAL:
2955     croak("Can't uplevel to an eval frame");
2956    case CXt_FORMAT:
2957     croak("Can't uplevel to a format frame");
2958    case CXt_SUB:
2959     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2960      continue;
2961     if (items > 1) {
2962      PL_stack_sp--;
2963      args = items - 2;
2964     }
2965     /* su_uplevel() takes care of extending the stack if needed. */
2966     ret = su_uplevel((CV *) code, cxix, args);
2967     XSRETURN(ret);
2968    default:
2969     break;
2970   }
2971  } while (--cxix >= 0);
2972  croak("Can't uplevel outside a subroutine");
2973
2974 void
2975 uid(...)
2976 PROTOTYPE: ;$
2977 PREINIT:
2978  I32 cxix;
2979  SV *uid;
2980 PPCODE:
2981  SU_GET_CONTEXT(0, 0, su_context_here());
2982  uid = su_uid_get(cxix);
2983  EXTEND(SP, 1);
2984  PUSHs(uid);
2985  XSRETURN(1);
2986
2987 void
2988 validate_uid(SV *uid)
2989 PROTOTYPE: $
2990 PREINIT:
2991  SV *ret;
2992 PPCODE:
2993  ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no;
2994  EXTEND(SP, 1);
2995  PUSHs(ret);
2996  XSRETURN(1);