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