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