]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - Upper.xs
fda107b1c64ed35ad235a535166e5821a552f170
[perl/modules/Scope-Upper.git] / Upper.xs
1 /* This file is part of the Scope::Upper Perl module.
2  * See http://search.cpan.org/dist/Scope-Upper/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h" 
7 #include "XSUB.h"
8
9 #define __PACKAGE__ "Scope::Upper"
10
11 #ifndef SU_DEBUG
12 # define SU_DEBUG 0
13 #endif
14
15 /* --- Compatibility ------------------------------------------------------- */
16
17 #ifndef NOOP
18 # define NOOP
19 #endif
20
21 #ifndef dNOOP
22 # define dNOOP
23 #endif
24
25 #ifndef PERL_UNUSED_VAR
26 # define PERL_UNUSED_VAR(V)
27 #endif
28
29 #ifndef STMT_START
30 # define STMT_START do
31 #endif
32
33 #ifndef STMT_END
34 # define STMT_END while (0)
35 #endif
36
37 #if SU_DEBUG
38 # define SU_D(X) STMT_START X STMT_END
39 #else
40 # define SU_D(X)
41 #endif
42
43 #ifndef Newx
44 # define Newx(v, n, c) New(0, v, n, c)
45 #endif
46
47 #ifdef DEBUGGING
48 # ifdef PoisonNew
49 #  define SU_POISON(D, N, T) PoisonNew((D), (N), T)
50 # elif defined(Poison)
51 #  define SU_POISON(D, N, T) Poison((D), (N), T)
52 # endif
53 #endif
54 #ifndef SU_POISON
55 # define SU_POISON(D, N, T) NOOP
56 #endif
57
58 #ifndef SvPV_const
59 # define SvPV_const(S, L) SvPV(S, L)
60 #endif
61
62 #ifndef SvPV_nolen_const
63 # define SvPV_nolen_const(S) SvPV_nolen(S)
64 #endif
65
66 #ifndef SvREFCNT_inc_simple_void
67 # define SvREFCNT_inc_simple_void(sv) SvREFCNT_inc(sv)
68 #endif
69
70 #ifndef GvCV_set
71 # define GvCV_set(G, C) (GvCV(G) = (C))
72 #endif
73
74 #ifndef CvGV_set
75 # define CvGV_set(C, G) (CvGV(C) = (G))
76 #endif
77
78 #ifndef CxHASARGS
79 # define CxHASARGS(C) ((C)->blk_sub.hasargs)
80 #endif
81
82 #ifndef HvNAME_get
83 # define HvNAME_get(H) HvNAME(H)
84 #endif
85
86 #ifndef gv_fetchpvn_flags
87 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
88 #endif
89
90 #ifndef cv_clone
91 # define cv_clone(P) Perl_cv_clone(aTHX_ (P))
92 #endif
93
94 #ifndef PERL_MAGIC_tied
95 # define PERL_MAGIC_tied 'P'
96 #endif
97
98 #ifndef PERL_MAGIC_env
99 # define PERL_MAGIC_env 'E'
100 #endif
101
102 #ifndef NEGATIVE_INDICES_VAR
103 # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
104 #endif
105
106 #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
107 #define SU_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S)))
108
109 /* --- Threads and multiplicity -------------------------------------------- */
110
111 #ifndef SU_MULTIPLICITY
112 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
113 #  define SU_MULTIPLICITY 1
114 # else
115 #  define SU_MULTIPLICITY 0
116 # endif
117 #endif
118 #if SU_MULTIPLICITY && !defined(tTHX)
119 # define tTHX PerlInterpreter*
120 #endif
121
122 #if SU_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
123 # define SU_THREADSAFE 1
124 # ifndef MY_CXT_CLONE
125 #  define MY_CXT_CLONE \
126     dMY_CXT_SV;                                                      \
127     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
128     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
129     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
130 # endif
131 #else
132 # define SU_THREADSAFE 0
133 # undef  dMY_CXT
134 # define dMY_CXT      dNOOP
135 # undef  MY_CXT
136 # define MY_CXT       su_globaldata
137 # undef  START_MY_CXT
138 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
139 # undef  MY_CXT_INIT
140 # define MY_CXT_INIT  NOOP
141 # undef  MY_CXT_CLONE
142 # define MY_CXT_CLONE NOOP
143 #endif
144
145 /* --- uplevel() data tokens ----------------------------------------------- */
146
147 typedef struct {
148  void *next;
149
150  I32  cxix;
151  CV  *target;
152  bool died;
153
154  PERL_SI *si;
155  PERL_SI *old_curstackinfo;
156  AV      *old_mainstack;
157
158  I32  old_depth;
159  COP *old_curcop;
160
161  bool old_catch;
162  OP  *old_op;
163  CV  *cloned_cv;
164 } su_uplevel_ud;
165
166 STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
167 #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
168  su_uplevel_ud *sud;
169  PERL_SI       *si;
170
171  Newx(sud, 1, su_uplevel_ud);
172  sud->next = NULL;
173
174  Newx(si, 1, PERL_SI);
175  si->si_stack   = newAV();
176  AvREAL_off(si->si_stack);
177  si->si_cxstack = NULL;
178  si->si_cxmax   = 0;
179
180  sud->si = si;
181
182  return sud;
183 }
184
185 STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
186 #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
187  PERL_SI *si = sud->si;
188
189  Safefree(si->si_cxstack);
190  SvREFCNT_dec(si->si_stack);
191  Safefree(si);
192  Safefree(sud);
193
194  return;
195 }
196
197 typedef struct {
198  su_uplevel_ud *root;
199  I32            count;
200 } su_uplevel_storage;
201
202 #ifndef SU_UPLEVEL_STORAGE_SIZE
203 # define SU_UPLEVEL_STORAGE_SIZE 4
204 #endif
205
206 /* --- Global data --------------------------------------------------------- */
207
208 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
209
210 typedef struct {
211  char    *stack_placeholder;
212
213  I32      cxix;
214  I32      items;
215  SV     **savesp;
216  LISTOP   return_op;
217  OP       proxy_op;
218
219  su_uplevel_storage uplevel_storage;
220 } my_cxt_t;
221
222 START_MY_CXT
223
224 /* --- Stack manipulations ------------------------------------------------- */
225
226 #define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder)
227
228 #define SU_SAVE_DESTRUCTOR_SIZE  3
229 #define SU_SAVE_PLACEHOLDER_SIZE 3
230
231 #define SU_SAVE_SCALAR_SIZE 3
232
233 #define SU_SAVE_ARY_SIZE      3
234 #define SU_SAVE_AELEM_SIZE    4
235 #ifdef SAVEADELETE
236 # define SU_SAVE_ADELETE_SIZE 3
237 #else
238 # define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
239 #endif
240 #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
241 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
242 #else
243 # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
244 #endif
245
246 #define SU_SAVE_HASH_SIZE    3
247 #define SU_SAVE_HELEM_SIZE   4
248 #define SU_SAVE_HDELETE_SIZE 4
249 #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
250 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
251 #else
252 # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
253 #endif
254
255 #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
256
257 #if !SU_HAS_PERL(5, 8, 9)
258 # define SU_SAVE_GP_SIZE 6
259 #elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0))
260 # define SU_SAVE_GP_SIZE 3
261 #elif !SU_HAS_PERL(5, 13, 8)
262 # define SU_SAVE_GP_SIZE 4
263 #else
264 # define SU_SAVE_GP_SIZE 3
265 #endif
266
267 #ifndef SvCANEXISTDELETE
268 # define SvCANEXISTDELETE(sv) \
269   (!SvRMAGICAL(sv)            \
270    || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied))            \
271        && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \
272        && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)     \
273        && gv_fetchmethod_autoload(stash, "DELETE", TRUE)     \
274       )                       \
275    )
276 #endif
277
278 /* ... Saving array elements ............................................... */
279
280 STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
281 #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K))
282  I32 idx;
283
284  if (key >= 0)
285   return key;
286
287 /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */
288 #if SU_HAS_PERL(5, 8, 1)
289  if (SvRMAGICAL(av)) {
290   const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
291   if (tied_magic) {
292    SV * const * const negative_indices_glob =
293                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
294                              NEGATIVE_INDICES_VAR, 16, 0);
295    if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
296     return key;
297   }
298  }
299 #endif
300
301  idx = key + av_len(av) + 1;
302  if (idx < 0)
303   return key;
304
305  return idx;
306 }
307
308 #ifndef SAVEADELETE
309
310 typedef struct {
311  AV *av;
312  I32 idx;
313 } su_ud_adelete;
314
315 STATIC void su_adelete(pTHX_ void *ud_) {
316  su_ud_adelete *ud = (su_ud_adelete *) ud_;
317
318  av_delete(ud->av, ud->idx, G_DISCARD);
319  SvREFCNT_dec(ud->av);
320
321  Safefree(ud);
322 }
323
324 STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) {
325 #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K))
326  su_ud_adelete *ud;
327
328  Newx(ud, 1, su_ud_adelete);
329  ud->av  = av;
330  ud->idx = idx;
331  SvREFCNT_inc_simple_void(av);
332
333  SAVEDESTRUCTOR_X(su_adelete, ud);
334 }
335
336 #define SAVEADELETE(A, K) su_save_adelete((A), (K))
337
338 #endif /* SAVEADELETE */
339
340 STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) {
341 #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V))
342  I32 idx;
343  I32 preeminent = 1;
344  SV **svp;
345  HV *stash;
346  MAGIC *mg;
347
348  idx = su_av_key2idx(av, SvIV(key));
349
350  if (SvCANEXISTDELETE(av))
351   preeminent = av_exists(av, idx);
352
353  svp = av_fetch(av, idx, 1);
354  if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
355
356  if (preeminent)
357   save_aelem(av, idx, svp);
358  else
359   SAVEADELETE(av, idx);
360
361  if (val) { /* local $x[$idx] = $val; */
362   SvSetMagicSV(*svp, val);
363  } else {   /* local $x[$idx]; delete $x[$idx]; */
364   av_delete(av, idx, G_DISCARD);
365  }
366 }
367
368 /* ... Saving hash elements ................................................ */
369
370 STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
371 #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V))
372  I32 preeminent = 1;
373  HE *he;
374  SV **svp;
375  HV *stash;
376  MAGIC *mg;
377
378  if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env))
379   preeminent = hv_exists_ent(hv, keysv, 0);
380
381  he  = hv_fetch_ent(hv, keysv, 1, 0);
382  svp = he ? &HeVAL(he) : NULL;
383  if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
384
385  if (HvNAME_get(hv) && isGV(*svp)) {
386   save_gp((GV *) *svp, 0);
387   return;
388  }
389
390  if (preeminent)
391   save_helem(hv, keysv, svp);
392  else {
393   STRLEN keylen;
394   const char * const key = SvPV_const(keysv, keylen);
395   SAVEDELETE(hv, savepvn(key, keylen),
396                  SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
397  }
398
399  if (val) { /* local $x{$keysv} = $val; */
400   SvSetMagicSV(*svp, val);
401  } else {   /* local $x{$keysv}; delete $x{$keysv}; */
402   (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
403  }
404 }
405
406 /* ... Saving code slots from a glob ....................................... */
407
408 #if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in)
409 # define mro_method_changed_in(G) PL_sub_generation++
410 #endif
411
412 typedef struct {
413  GV *gv;
414  CV *old_cv;
415 } su_save_gvcv_ud;
416
417 STATIC void su_restore_gvcv(pTHX_ void *ud_) {
418  su_save_gvcv_ud *ud = ud_;
419  GV              *gv = ud->gv;
420
421  GvCV_set(gv, ud->old_cv);
422  GvCVGEN(gv) = 0;
423  mro_method_changed_in(GvSTASH(gv));
424
425  Safefree(ud);
426 }
427
428 STATIC void su_save_gvcv(pTHX_ GV *gv) {
429 #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G))
430  su_save_gvcv_ud *ud;
431
432  Newx(ud, 1, su_save_gvcv_ud);
433  ud->gv     = gv;
434  ud->old_cv = GvCV(gv);
435
436  GvCV_set(gv, NULL);
437  GvCVGEN(gv) = 0;
438  mro_method_changed_in(GvSTASH(gv));
439
440  SAVEDESTRUCTOR_X(su_restore_gvcv, ud);
441 }
442
443 /* --- Actions ------------------------------------------------------------- */
444
445 typedef struct {
446  I32 depth;
447  I32 pad;
448  I32 *origin;
449  void (*handler)(pTHX_ void *);
450 } su_ud_common;
451
452 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
453 #define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
454 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
455 #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
456
457 #define SU_UD_FREE(U) STMT_START { \
458  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
459  Safefree(U); \
460 } STMT_END
461
462 /* ... Reap ................................................................ */
463
464 typedef struct {
465  su_ud_common ci;
466  SV *cb;
467 } su_ud_reap;
468
469 STATIC void su_call(pTHX_ void *ud_) {
470  su_ud_reap *ud = (su_ud_reap *) ud_;
471 #if SU_HAS_PERL(5, 9, 5)
472  PERL_CONTEXT saved_cx;
473  I32 cxix;
474 #endif
475
476  dSP;
477
478  SU_D({
479   PerlIO_printf(Perl_debug_log,
480                 "%p: @@@ call\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
481                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
482  });
483
484  ENTER;
485  SAVETMPS;
486
487  PUSHMARK(SP);
488  PUTBACK;
489
490  /* If the recently popped context isn't saved there, it will be overwritten by
491   * the sub scope from call_sv, although it's still needed in our caller. */
492
493 #if SU_HAS_PERL(5, 9, 5)
494  if (cxstack_ix < cxstack_max)
495   cxix = cxstack_ix + 1;
496  else
497   cxix = Perl_cxinc(aTHX);
498  saved_cx = cxstack[cxix];
499 #endif
500
501  call_sv(ud->cb, G_VOID);
502
503 #if SU_HAS_PERL(5, 9, 5)
504  cxstack[cxix] = saved_cx;
505 #endif
506
507  PUTBACK;
508
509  FREETMPS;
510  LEAVE;
511
512  SvREFCNT_dec(ud->cb);
513  SU_UD_FREE(ud);
514 }
515
516 STATIC void su_reap(pTHX_ void *ud) {
517 #define su_reap(U) su_reap(aTHX_ (U))
518  SU_D({
519   PerlIO_printf(Perl_debug_log,
520                 "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
521                  ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
522  });
523
524  SAVEDESTRUCTOR_X(su_call, ud);
525 }
526
527 /* ... Localize & localize array/hash element .............................. */
528
529 typedef struct {
530  su_ud_common ci;
531  SV    *sv;
532  SV    *val;
533  SV    *elem;
534  svtype type;
535 } su_ud_localize;
536
537 #define SU_UD_LOCALIZE_FREE(U) STMT_START { \
538  SvREFCNT_dec((U)->elem); \
539  SvREFCNT_dec((U)->val);  \
540  SvREFCNT_dec((U)->sv);   \
541  SU_UD_FREE(U);           \
542 } STMT_END
543
544 STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
545 #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
546  UV deref = 0;
547  svtype t = SVt_NULL;
548  I32 size;
549
550  SvREFCNT_inc_simple_void(sv);
551
552  if (SvTYPE(sv) >= SVt_PVGV) {
553   if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
554    t = SVt_PVGV;
555   } else {                   /* local *x = \$val; */
556    t = SvTYPE(SvRV(val));
557    deref = 1;
558   }
559  } else if (SvROK(sv)) {
560   croak("Invalid %s reference as the localization target",
561                  sv_reftype(SvRV(sv), 0));
562  } else {
563   STRLEN len, l;
564   const char *p = SvPV_const(sv, len), *s;
565   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
566   if (!l) {
567    l = len;
568    s = p;
569   }
570   switch (*s) {
571    case '$': t = SVt_PV;   break;
572    case '@': t = SVt_PVAV; break;
573    case '%': t = SVt_PVHV; break;
574    case '&': t = SVt_PVCV; break;
575    case '*': t = SVt_PVGV; break;
576   }
577   if (t != SVt_NULL) {
578    ++s;
579    --l;
580   } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
581    if (SvROK(val) && !sv_isobject(val)) {
582     t = SvTYPE(SvRV(val));
583     deref = 1;
584    } else {
585     t = SvTYPE(val);
586    }
587   }
588   SvREFCNT_dec(sv);
589   sv = newSVpvn(s, l);
590  }
591
592  switch (t) {
593   case SVt_PVAV:
594    size  = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
595                 : SU_SAVE_ARY_SIZE;
596    deref = 0;
597    break;
598   case SVt_PVHV:
599    size  = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
600                 : SU_SAVE_HASH_SIZE;
601    deref = 0;
602    break;
603   case SVt_PVGV:
604    size  = SU_SAVE_GP_SIZE;
605    deref = 0;
606    break;
607   case SVt_PVCV:
608    size  = SU_SAVE_GVCV_SIZE;
609    deref = 0;
610    break;
611   default:
612    size = SU_SAVE_SCALAR_SIZE;
613    break;
614  }
615  /* When deref is set, val isn't NULL */
616
617  ud->sv   = sv;
618  ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
619  ud->elem = SvREFCNT_inc(elem);
620  ud->type = t;
621
622  return size;
623 }
624
625 STATIC void su_localize(pTHX_ void *ud_) {
626 #define su_localize(U) su_localize(aTHX_ (U))
627  su_ud_localize *ud = (su_ud_localize *) ud_;
628  SV *sv   = ud->sv;
629  SV *val  = ud->val;
630  SV *elem = ud->elem;
631  svtype t = ud->type;
632  GV *gv;
633
634  if (SvTYPE(sv) >= SVt_PVGV) {
635   gv = (GV *) sv;
636  } else {
637 #ifdef gv_fetchsv
638   gv = gv_fetchsv(sv, GV_ADDMULTI, t);
639 #else
640   STRLEN len;
641   const char *name = SvPV_const(sv, len);
642   gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
643 #endif
644  }
645
646  SU_D({
647   SV *z = newSV(0);
648   SvUPGRADE(z, t);
649   PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0));
650   PerlIO_printf(Perl_debug_log,
651                 "%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
652                  ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
653   SvREFCNT_dec(z);
654  });
655
656  /* Inspired from Alias.pm */
657  switch (t) {
658   case SVt_PVAV:
659    if (elem) {
660     su_save_aelem(GvAV(gv), elem, val);
661     goto done;
662    } else
663     save_ary(gv);
664    break;
665   case SVt_PVHV:
666    if (elem) {
667     su_save_helem(GvHV(gv), elem, val);
668     goto done;
669    } else
670     save_hash(gv);
671    break;
672   case SVt_PVGV:
673    save_gp(gv, 1); /* hide previous entry in symtab */
674    break;
675   case SVt_PVCV:
676    su_save_gvcv(gv);
677    break;
678   default:
679    gv = (GV *) save_scalar(gv);
680    break;
681  }
682
683  if (val)
684   SvSetMagicSV((SV *) gv, val);
685
686 done:
687  SU_UD_LOCALIZE_FREE(ud);
688 }
689
690 /* --- Pop a context back -------------------------------------------------- */
691
692 #if SU_DEBUG
693 # ifdef DEBUGGING
694 #  define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
695 # else
696 #  define SU_CXNAME "XXX"
697 # endif
698 #endif
699
700 STATIC void su_pop(pTHX_ void *ud) {
701 #define su_pop(U) su_pop(aTHX_ (U))
702  I32 depth, base, mark, *origin;
703  depth = SU_UD_DEPTH(ud);
704
705  SU_D(
706   PerlIO_printf(Perl_debug_log,
707    "%p: --- pop a %s\n"
708    "%p: leave scope     at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n",
709     ud, SU_CXNAME,
710     ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix])
711  );
712
713  origin = SU_UD_ORIGIN(ud);
714  mark   = origin[depth];
715  base   = origin[depth - 1];
716
717  SU_D(PerlIO_printf(Perl_debug_log,
718                     "%p: original scope was %*c top=%2d     base=%2d\n",
719                      ud,                24, ' ',    mark,        base));
720
721  if (base < mark) {
722   SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
723   PL_savestack_ix = mark;
724   leave_scope(base);
725  }
726  PL_savestack_ix = base;
727
728  SU_UD_DEPTH(ud) = --depth;
729
730  if (depth > 0) {
731   I32 pad;
732
733   if ((pad = SU_UD_PAD(ud))) {
734    dMY_CXT;
735    do {
736     SU_D(PerlIO_printf(Perl_debug_log,
737           "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n",
738            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
739     SU_SAVE_PLACEHOLDER();
740    } while (--pad);
741   }
742
743   SU_D(PerlIO_printf(Perl_debug_log,
744           "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
745            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
746   SAVEDESTRUCTOR_X(su_pop, ud);
747  } else {
748   SU_UD_HANDLER(ud)(aTHX_ ud);
749  }
750
751  SU_D(PerlIO_printf(Perl_debug_log,
752                     "%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
753                      ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
754 }
755
756 /* --- Initialize the stack and the action userdata ------------------------ */
757
758 STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
759 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
760  I32 i, depth = 1, pad, offset, *origin;
761
762  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
763
764  if (size <= SU_SAVE_DESTRUCTOR_SIZE)
765   pad = 0;
766  else {
767   I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
768   pad = extra / SU_SAVE_PLACEHOLDER_SIZE;
769   if (extra % SU_SAVE_PLACEHOLDER_SIZE)
770    ++pad;
771  }
772  offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad;
773
774  SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
775                                      ud,    size,   pad,   offset));
776
777  for (i = cxstack_ix; i > cxix; --i) {
778   PERL_CONTEXT *cx = cxstack + i;
779   switch (CxTYPE(cx)) {
780 #if SU_HAS_PERL(5, 10, 0)
781    case CXt_BLOCK:
782     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i));
783     /* Given and when blocks are actually followed by a simple block, so skip
784      * it if needed. */
785     if (cxix > 0) { /* Implies i > 0 */
786      PERL_CONTEXT *next = cx - 1;
787      if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN)
788       --cxix;
789     }
790     depth++;
791     break;
792 #endif
793 #if SU_HAS_PERL(5, 11, 0)
794    case CXt_LOOP_FOR:
795    case CXt_LOOP_PLAIN:
796    case CXt_LOOP_LAZYSV:
797    case CXt_LOOP_LAZYIV:
798 #else
799    case CXt_LOOP:
800 #endif
801     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
802     depth += 2;
803     break;
804    default:
805     SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
806     depth++;
807     break;
808   }
809  }
810  SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
811
812  Newx(origin, depth + 1, I32);
813  origin[0] = PL_scopestack[PL_scopestack_ix - depth];
814  PL_scopestack[PL_scopestack_ix - depth] += size;
815  for (i = depth - 1; i >= 1; --i) {
816   I32 j = PL_scopestack_ix - i;
817   origin[depth - i] = PL_scopestack[j];
818   PL_scopestack[j] += offset;
819  }
820  origin[depth] = PL_savestack_ix;
821
822  SU_UD_ORIGIN(ud) = origin;
823  SU_UD_DEPTH(ud)  = depth;
824  SU_UD_PAD(ud)    = pad;
825
826  /* Make sure the first destructor fires by pushing enough fake slots on the
827   * stack. */
828  if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
829                                        <= PL_scopestack[PL_scopestack_ix - 1]) {
830   dMY_CXT;
831   do {
832    SU_D(PerlIO_printf(Perl_debug_log,
833                   "%p: push a fake slot      at scope_ix=%2d  save_ix=%2d\n",
834                    ud,                      PL_scopestack_ix, PL_savestack_ix));
835    SU_SAVE_PLACEHOLDER();
836   } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
837                                         <= PL_scopestack[PL_scopestack_ix - 1]);
838  }
839  SU_D(PerlIO_printf(Perl_debug_log,
840                   "%p: push first destructor at scope_ix=%2d  save_ix=%2d\n",
841                    ud,                      PL_scopestack_ix, PL_savestack_ix));
842  SAVEDESTRUCTOR_X(su_pop, ud);
843
844  SU_D({
845   for (i = 0; i <= depth; ++i) {
846    I32 j = PL_scopestack_ix  - i;
847    PerlIO_printf(Perl_debug_log,
848                  "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n",
849                   ud,        i, j, origin[depth - i],
850                                    i == 0 ? PL_savestack_ix : PL_scopestack[j]);
851   }
852  });
853
854  return depth;
855 }
856
857 /* --- Unwind stack -------------------------------------------------------- */
858
859 STATIC void su_unwind(pTHX_ void *ud_) {
860  dMY_CXT;
861  I32 cxix    = MY_CXT.cxix;
862  I32 items   = MY_CXT.items - 1;
863  SV **savesp = MY_CXT.savesp;
864  I32 mark;
865
866  PERL_UNUSED_VAR(ud_);
867
868  if (savesp)
869   PL_stack_sp = savesp;
870
871  if (cxstack_ix > cxix)
872   dounwind(cxix);
873
874  /* Hide the level */
875  if (items >= 0)
876   PL_stack_sp--;
877
878  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
879  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
880
881  SU_D({
882   I32 gimme = GIMME_V;
883   PerlIO_printf(Perl_debug_log,
884                 "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
885                 &MY_CXT, cxix,
886                 gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
887                 items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
888  });
889
890  PL_op = (OP *) &(MY_CXT.return_op);
891  PL_op = PL_op->op_ppaddr(aTHX);
892
893  *PL_markstack_ptr = mark;
894
895  MY_CXT.proxy_op.op_next = PL_op;
896  PL_op = &(MY_CXT.proxy_op);
897 }
898
899 /* --- Uplevel ------------------------------------------------------------- */
900
901 #ifndef OP_GIMME_REVERSE
902 STATIC U8 su_op_gimme_reverse(U8 gimme) {
903  switch (gimme) {
904   case G_VOID:
905    return OPf_WANT_VOID;
906   case G_ARRAY:
907    return OPf_WANT_LIST;
908   default:
909    break;
910  }
911
912  return OPf_WANT_SCALAR;
913 }
914 #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
915 #endif
916
917 #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
918 #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
919
920 STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
921  su_uplevel_ud_delete((su_uplevel_ud *) mg->mg_ptr);
922
923  return 0;
924 }
925
926 STATIC MGVTBL su_uplevel_restore_vtbl = {
927  0,
928  0,
929  0,
930  0,
931  su_uplevel_restore_free
932 };
933
934 STATIC void su_uplevel_restore(pTHX_ void *sus_) {
935  su_uplevel_ud *sud = sus_;
936  PERL_SI *cur = sud->old_curstackinfo;
937  PERL_SI *si  = sud->si;
938  dMY_CXT;
939
940  /* When we reach this place, POPSUB has already been called (with our fake
941   * argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
942   * before uplevel). argarray is either the fake AV we created in su_uplevel()
943   * or some empty replacement POPSUB creates when @_ is reified. In both cases
944   * we have to destroy it before the context stack is swapped back to its
945   * original state. */
946  SvREFCNT_dec(cxstack[sud->cxix].blk_sub.argarray);
947
948  CATCH_SET(sud->old_catch);
949
950  SvREFCNT_dec(sud->cloned_cv);
951
952  SU_UPLEVEL_RESTORE(op);
953
954  /* stack_grow() wants PL_curstack so restore the old stack first */
955  if (PL_curstackinfo == si) {
956   PL_curstack = cur->si_stack;
957   if (sud->old_mainstack)
958    SU_UPLEVEL_RESTORE(mainstack);
959   SU_UPLEVEL_RESTORE(curstackinfo);
960
961   if (sud->died) {
962    CV *target_cv = sud->target;
963    I32 levels = 0, i;
964
965    /* When we die, the depth of the target CV is not updated because of the
966     * stack switcheroo. So we have to look at all the frames between the
967     * uplevel call and the catch block to count how many call frames to the
968     * target CV were skipped. */
969    for (i = cur->si_cxix; i > sud->cxix; i--) {
970     register const PERL_CONTEXT *cx = cxstack + i;
971
972     if (CxTYPE(cx) == CXt_SUB) {
973      if (cx->blk_sub.cv == target_cv)
974       ++levels;
975     }
976    }
977
978    /* If we died, the replacement stack was already unwinded to the first
979     * eval frame, and all the contexts down there were popped. We don't have
980     * to pop manually any context of the original stack, because they must
981     * have been in the replacement stack as well (since the second was copied
982     * from the first). Thus we only have to make sure the original stack index
983     * points to the context just below the first eval scope under the target
984     * frame. */
985    for (; i >= 0; i--) {
986     register const PERL_CONTEXT *cx = cxstack + i;
987
988     switch (CxTYPE(cx)) {
989      case CXt_SUB:
990       if (cx->blk_sub.cv == target_cv)
991        ++levels;
992       break;
993      case CXt_EVAL:
994       goto found_it;
995       break;
996      default:
997       break;
998     }
999    }
1000
1001 found_it:
1002    CvDEPTH(target_cv) = sud->old_depth - levels;
1003    PL_curstackinfo->si_cxix = i - 1;
1004
1005 #if !SU_HAS_PERL(5, 13, 1)
1006    /* Since $@ was maybe localized between the target frame and the uplevel
1007     * call, we forcefully flush the save stack to get rid of it and then
1008     * reset $@ to its proper value. Note that the the call to
1009     * su_uplevel_restore() must happen before the "reset $@" item of the save
1010     * stack is processed, as uplevel was called after the localization.
1011     * Andrew's change to how $@ was treated, which were mainly integrated
1012     * between perl 5.13.0 and 5.13.1, fixed this. */
1013    if (ERRSV && SvTRUE(ERRSV)) {
1014     register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1015     SV *errsv = SvREFCNT_inc(ERRSV);
1016     PL_scopestack_ix = cx->blk_oldscopesp;
1017     leave_scope(PL_scopestack[PL_scopestack_ix]);
1018     sv_setsv(ERRSV, errsv);
1019     SvREFCNT_dec(errsv);
1020    }
1021 #endif
1022   }
1023  }
1024
1025  SU_UPLEVEL_RESTORE(curcop);
1026
1027  SvREFCNT_dec(sud->target);
1028
1029  PL_stack_base = AvARRAY(cur->si_stack);
1030  PL_stack_sp   = PL_stack_base + AvFILLp(cur->si_stack);
1031  PL_stack_max  = PL_stack_base + AvMAX(cur->si_stack);
1032
1033 #if SU_HAS_PERL(5, 8, 0)
1034  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
1035   /* When an exception is thrown from the uplevel'd subroutine,
1036    * su_uplevel_restore() may be called by the LEAVE in die_unwind() (called
1037    * die_where() in more recent perls), which has the sad habit of keeping a
1038    * pointer to the current context frame across this call. This means that
1039    * we can't free the temporary context stack we used for the uplevel call
1040    * right now, or that pointer upwards would point to garbage. We work around
1041    * this by attaching the state data to a scalar that will be freed "soon".
1042    * This issue has been fixed in perl with commit 8f89e5a9. */
1043   SV *sv = sv_newmortal();
1044   sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
1045                         (const char *) sud, 0);
1046  } else {
1047 #endif
1048   sud->next = MY_CXT.uplevel_storage.root;
1049   MY_CXT.uplevel_storage.root = sud;
1050   MY_CXT.uplevel_storage.count++;
1051 #if SU_HAS_PERL(5, 8, 0)
1052  }
1053 #endif
1054
1055  return;
1056 }
1057
1058 STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
1059 #define su_cv_clone(C) su_cv_clone(aTHX_ (C))
1060  CV *new_cv;
1061
1062  /* Starting from commit b5c19bd7, cv_clone() has an assert that checks whether
1063   * CvDEPTH(CvOUTSIDE(proto)) > 0, so we have to fool cv_clone() with a little
1064   * dance. */
1065 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1066  I32 old_depth;
1067  CV *outside = CvOUTSIDE(old_cv);
1068
1069  if (outside && CvCLONE(outside) && !CvCLONED(outside))
1070   outside = find_runcv(NULL);
1071  old_depth = CvDEPTH(outside);
1072  if (!old_depth)
1073   CvDEPTH(outside) = 1;
1074 #endif
1075
1076  new_cv = cv_clone(old_cv);
1077
1078 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1079  CvDEPTH(outside) = old_depth;
1080 #endif
1081
1082  /* Starting from perl 5.9 (more exactly commit b5c19bd7), cv_clone() is no
1083   * longer able to clone named subs propery. With this commit, pad_findlex()
1084   * stores the parent index of a fake pad entry in the NV slot of the
1085   * corresponding pad name SV, but only for anonymous subs (since named subs
1086   * aren't supposed to be cloned in pure Perl land). To fix this, we just
1087   * manually relink the new fake pad entries to the new ones.
1088   * For some reason perl 5.8 crashes too without this, supposedly because of
1089   * other closure bugs. Hence we enable it everywhere. */
1090  if (!CvCLONE(old_cv)) {
1091   const AV  *old_padname = (const AV *)  AvARRAY(CvPADLIST(old_cv))[0];
1092   AV        *old_pad     = (AV *)        AvARRAY(CvPADLIST(old_cv))[1];
1093   AV        *new_pad     = (AV *)        AvARRAY(CvPADLIST(new_cv))[1];
1094   const SV **old_aryname = (const SV **) AvARRAY(old_padname);
1095   SV       **old_ary     = AvARRAY(old_pad);
1096   SV       **new_ary     = AvARRAY(new_pad);
1097   I32 fname = AvFILLp(old_padname);
1098   I32 fpad  = AvFILLp(old_pad);
1099   I32 ix;
1100
1101   for (ix = fpad; ix > 0; ix--) {
1102    const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
1103
1104    if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
1105     SvREFCNT_dec(new_ary[ix]);
1106     new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
1107    }
1108   }
1109  }
1110
1111  return new_cv;
1112 }
1113
1114 STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
1115 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1116  su_uplevel_ud *sud;
1117  const PERL_CONTEXT *cx = cxstack + cxix;
1118  PERL_SI *si;
1119  PERL_SI *cur = PL_curstackinfo;
1120  SV **old_stack_sp;
1121  CV  *target_cv;
1122  UNOP sub_op;
1123  I32  marksize;
1124  I32  gimme;
1125  I32  old_mark, new_mark;
1126  I32  ret;
1127  dSP;
1128  dMY_CXT;
1129
1130  ENTER;
1131
1132  gimme = GIMME_V;
1133  /* Make PL_stack_sp point just before the CV. */
1134  PL_stack_sp -= args + 1;
1135  old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1136  SPAGAIN;
1137
1138  sud = MY_CXT.uplevel_storage.root;
1139  if (sud) {
1140   MY_CXT.uplevel_storage.root = sud->next;
1141   MY_CXT.uplevel_storage.count--;
1142  } else {
1143   sud = su_uplevel_ud_new();
1144  }
1145  si = sud->si;
1146
1147  sud->cxix = cxix;
1148  sud->died = 1;
1149  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1150
1151  si->si_type = cur->si_type;
1152  si->si_next = NULL;
1153  si->si_prev = cur->si_prev;
1154
1155  /* Allocate enough space for all the elements of the original stack up to the
1156   * target context, plus the forthcoming arguments. */
1157  new_mark = cx->blk_oldsp;
1158  av_extend(si->si_stack, new_mark + 1 + args + 1);
1159  Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1160  AvFILLp(si->si_stack) = new_mark;
1161  SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1162
1163  /* Specialized SWITCHSTACK() */
1164  PL_stack_base = AvARRAY(si->si_stack);
1165  old_stack_sp  = PL_stack_sp;
1166  PL_stack_sp   = PL_stack_base + AvFILLp(si->si_stack);
1167  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
1168  SPAGAIN;
1169
1170 #ifdef DEBUGGING
1171  si->si_markoff = cx->blk_oldmarksp;
1172 #endif
1173
1174  /* Copy the context stack up to the context just below the target. */
1175  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1176  if (si->si_cxmax < cxix) {
1177   /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1178   si->si_cxmax = (cxix < 4) ? 4 : cxix;
1179   Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1180  }
1181  Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1182  SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1183
1184  target_cv      = cx->blk_sub.cv;
1185  sud->target    = (CV *) SvREFCNT_inc(target_cv);
1186  sud->old_depth = CvDEPTH(target_cv);
1187
1188  /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1189   * run-time implication, since PL_curcop will be overwritten as soon as we
1190   * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1191   * make it point to the blk_oldcop for the target frame, so that caller()
1192   * reports the right file name, line number and lexical hints. */
1193  SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1194  /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1195   * this point. */
1196  /* Don't reset PL_curpm, we want the most recent matches. */
1197
1198  SU_UPLEVEL_SAVE(curstackinfo, si);
1199  /* If those two are equal, we need to fool POPSTACK_TO() */
1200  if (PL_mainstack == PL_curstack)
1201   SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1202  else
1203   sud->old_mainstack = NULL;
1204  PL_curstack = si->si_stack;
1205
1206  cv = su_cv_clone(cv);
1207  sud->cloned_cv = cv;
1208  CvGV_set(cv, CvGV(target_cv));
1209
1210  PUSHMARK(SP);
1211  /* Both SP and old_stack_sp points just before the CV. */
1212  Copy(old_stack_sp + 2, SP + 1, args, SV *);
1213  SP += args;
1214  PUSHs((SV *) cv);
1215  PUTBACK;
1216
1217  Zero(&sub_op, 1, UNOP);
1218  sub_op.op_type  = OP_ENTERSUB;
1219  sub_op.op_next  = NULL;
1220  sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1221  if (PL_DBsub)
1222   sub_op.op_flags |= OPpENTERSUB_DB;
1223
1224  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1225
1226  sud->old_catch = CATCH_GET;
1227  CATCH_SET(TRUE);
1228
1229  if (PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)) {
1230   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1231    /* The call to pp_entersub() has saved the current @_ (in XS terms,
1232     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1233     * with what we put on the stack. But we want to fake up the same arguments
1234     * as the ones in use at the context we uplevel to, so we replace the
1235     * argarray with an unreal copy of the original @_. */
1236    AV *av = newAV();
1237    AvREAL_off(av);
1238    av_extend(av, AvMAX(cx->blk_sub.argarray));
1239    AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1240    Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1241    cxstack[cxix].blk_sub.argarray = av;
1242   } else {
1243    SvREFCNT_inc(cxstack[cxix].blk_sub.argarray);
1244   }
1245
1246   CALLRUNOPS(aTHX);
1247
1248   ret = PL_stack_sp - (PL_stack_base + new_mark);
1249  }
1250
1251  sud->died = 0;
1252
1253  SPAGAIN;
1254
1255  if (ret > 0) {
1256   AV *old_stack = sud->old_curstackinfo->si_stack;
1257
1258   if (old_mark + ret > AvMAX(old_stack)) {
1259    /* Specialized EXTEND(old_sp, ret) */
1260    av_extend(old_stack, old_mark + ret + 1);
1261    old_stack_sp = AvARRAY(old_stack) + old_mark;
1262   }
1263
1264   Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1265   PL_stack_sp        += ret;
1266   AvFILLp(old_stack) += ret;
1267  }
1268
1269  PUTBACK;
1270
1271  LEAVE;
1272
1273  return ret;
1274 }
1275
1276 /* --- Interpreter setup/teardown ------------------------------------------ */
1277
1278 STATIC void su_teardown(pTHX_ void *param) {
1279  su_uplevel_ud *cur, *prev;
1280  dMY_CXT;
1281
1282  cur = MY_CXT.uplevel_storage.root;
1283  if (cur) {
1284   su_uplevel_ud *prev;
1285   do {
1286    prev = cur;
1287    cur  = prev->next;
1288    su_uplevel_ud_delete(prev);
1289   } while (cur);
1290  }
1291
1292  return;
1293 }
1294
1295 STATIC void su_setup(pTHX) {
1296 #define su_setup() su_setup(aTHX)
1297  MY_CXT_INIT;
1298
1299  MY_CXT.stack_placeholder = NULL;
1300
1301  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
1302  Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
1303  MY_CXT.return_op.op_type   = OP_RETURN;
1304  MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
1305
1306  Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
1307  MY_CXT.proxy_op.op_type   = OP_STUB;
1308  MY_CXT.proxy_op.op_ppaddr = NULL;
1309
1310  MY_CXT.uplevel_storage.root  = NULL;
1311  MY_CXT.uplevel_storage.count = 0;
1312
1313  call_atexit(su_teardown, NULL);
1314
1315  return;
1316 }
1317
1318 /* --- XS ------------------------------------------------------------------ */
1319
1320 #if SU_HAS_PERL(5, 8, 9)
1321 # define SU_SKIP_DB_MAX 2
1322 #else
1323 # define SU_SKIP_DB_MAX 3
1324 #endif
1325
1326 /* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
1327  * followed by a DB sub */
1328
1329 #define SU_SKIP_DB(C) \
1330  STMT_START {         \
1331   I32 skipped = 0;    \
1332   PERL_CONTEXT *base = cxstack;      \
1333   PERL_CONTEXT *cx   = base + (C);   \
1334   while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
1335    --cx, ++skipped;                  \
1336   if (cx >= base && (C) > skipped) { \
1337    switch (CxTYPE(cx)) {  \
1338     case CXt_SUB:         \
1339      if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
1340       (C) -= skipped + 1; \
1341       break;              \
1342     default:              \
1343      break;               \
1344    }                      \
1345   }                       \
1346  } STMT_END
1347
1348 #define SU_GET_CONTEXT(A, B)   \
1349  STMT_START {                  \
1350   if (items > A) {             \
1351    SV *csv = ST(B);            \
1352    if (!SvOK(csv))             \
1353     goto default_cx;           \
1354    cxix = SvIV(csv);           \
1355    if (cxix < 0)               \
1356     cxix = 0;                  \
1357    else if (cxix > cxstack_ix) \
1358     cxix = cxstack_ix;         \
1359   } else {                     \
1360 default_cx:                    \
1361    cxix = cxstack_ix;          \
1362    if (PL_DBsub)               \
1363     SU_SKIP_DB(cxix);          \
1364   }                            \
1365  } STMT_END
1366
1367 #define SU_GET_LEVEL(A, B) \
1368  STMT_START {              \
1369   level = 0;               \
1370   if (items > 0) {         \
1371    SV *lsv = ST(B);        \
1372    if (SvOK(lsv)) {        \
1373     level = SvIV(lsv);     \
1374     if (level < 0)         \
1375      level = 0;            \
1376    }                       \
1377   }                        \
1378  } STMT_END
1379
1380 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
1381
1382 XS(XS_Scope__Upper_unwind) {
1383 #ifdef dVAR
1384  dVAR; dXSARGS;
1385 #else
1386  dXSARGS;
1387 #endif
1388  dMY_CXT;
1389  I32 cxix;
1390
1391  PERL_UNUSED_VAR(cv); /* -W */
1392  PERL_UNUSED_VAR(ax); /* -Wall */
1393
1394  SU_GET_CONTEXT(0, items - 1);
1395  do {
1396   PERL_CONTEXT *cx = cxstack + cxix;
1397   switch (CxTYPE(cx)) {
1398    case CXt_SUB:
1399     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1400      continue;
1401    case CXt_EVAL:
1402    case CXt_FORMAT:
1403     MY_CXT.cxix  = cxix;
1404     MY_CXT.items = items;
1405     /* pp_entersub will want to sanitize the stack after returning from there
1406      * Screw that, we're insane */
1407     if (GIMME_V == G_SCALAR) {
1408      MY_CXT.savesp = PL_stack_sp;
1409      /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
1410      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
1411     } else {
1412      MY_CXT.savesp = NULL;
1413     }
1414     SAVEDESTRUCTOR_X(su_unwind, NULL);
1415     return;
1416    default:
1417     break;
1418   }
1419  } while (--cxix >= 0);
1420  croak("Can't return outside a subroutine");
1421 }
1422
1423 MODULE = Scope::Upper            PACKAGE = Scope::Upper
1424
1425 PROTOTYPES: ENABLE
1426
1427 BOOT:
1428 {
1429  HV *stash;
1430
1431  stash = gv_stashpv(__PACKAGE__, 1);
1432  newCONSTSUB(stash, "TOP",           newSViv(0));
1433  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
1434
1435  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
1436
1437  su_setup();
1438 }
1439
1440 #if SU_THREADSAFE
1441
1442 void
1443 CLONE(...)
1444 PROTOTYPE: DISABLE
1445 PPCODE:
1446  {
1447   MY_CXT_CLONE;
1448   MY_CXT.uplevel_storage.root  = NULL;
1449   MY_CXT.uplevel_storage.count = 0;
1450  }
1451  XSRETURN(0);
1452
1453 #endif /* SU_THREADSAFE */
1454
1455 SV *
1456 HERE()
1457 PROTOTYPE:
1458 PREINIT:
1459  I32 cxix = cxstack_ix;
1460 CODE:
1461  if (PL_DBsub)
1462   SU_SKIP_DB(cxix);
1463  RETVAL = newSViv(cxix);
1464 OUTPUT:
1465  RETVAL
1466
1467 SV *
1468 UP(...)
1469 PROTOTYPE: ;$
1470 PREINIT:
1471  I32 cxix;
1472 CODE:
1473  SU_GET_CONTEXT(0, 0);
1474  if (--cxix < 0)
1475   cxix = 0;
1476  if (PL_DBsub)
1477   SU_SKIP_DB(cxix);
1478  RETVAL = newSViv(cxix);
1479 OUTPUT:
1480  RETVAL
1481
1482 void
1483 SUB(...)
1484 PROTOTYPE: ;$
1485 PREINIT:
1486  I32 cxix;
1487 PPCODE:
1488  SU_GET_CONTEXT(0, 0);
1489  for (; cxix >= 0; --cxix) {
1490   PERL_CONTEXT *cx = cxstack + cxix;
1491   switch (CxTYPE(cx)) {
1492    default:
1493     continue;
1494    case CXt_SUB:
1495     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1496      continue;
1497     ST(0) = sv_2mortal(newSViv(cxix));
1498     XSRETURN(1);
1499   }
1500  }
1501  XSRETURN_UNDEF;
1502
1503 void
1504 EVAL(...)
1505 PROTOTYPE: ;$
1506 PREINIT:
1507  I32 cxix;
1508 PPCODE:
1509  SU_GET_CONTEXT(0, 0);
1510  for (; cxix >= 0; --cxix) {
1511   PERL_CONTEXT *cx = cxstack + cxix;
1512   switch (CxTYPE(cx)) {
1513    default:
1514     continue;
1515    case CXt_EVAL:
1516     ST(0) = sv_2mortal(newSViv(cxix));
1517     XSRETURN(1);
1518   }
1519  }
1520  XSRETURN_UNDEF;
1521
1522 void
1523 SCOPE(...)
1524 PROTOTYPE: ;$
1525 PREINIT:
1526  I32 cxix, level;
1527 PPCODE:
1528  SU_GET_LEVEL(0, 0);
1529  cxix = cxstack_ix;
1530  if (PL_DBsub) {
1531   SU_SKIP_DB(cxix);
1532   while (cxix > 0) {
1533    if (--level < 0)
1534     break;
1535    --cxix;
1536    SU_SKIP_DB(cxix);
1537   }
1538  } else {
1539   cxix -= level;
1540   if (cxix < 0)
1541    cxix = 0;
1542  }
1543  ST(0) = sv_2mortal(newSViv(cxix));
1544  XSRETURN(1);
1545
1546 void
1547 CALLER(...)
1548 PROTOTYPE: ;$
1549 PREINIT:
1550  I32 cxix, level;
1551 PPCODE:
1552  SU_GET_LEVEL(0, 0);
1553  for (cxix = cxstack_ix; cxix > 0; --cxix) {
1554   PERL_CONTEXT *cx = cxstack + cxix;
1555   switch (CxTYPE(cx)) {
1556    case CXt_SUB:
1557     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1558      continue;
1559    case CXt_EVAL:
1560    case CXt_FORMAT:
1561     if (--level < 0)
1562      goto done;
1563     break;
1564   }
1565  }
1566 done:
1567  ST(0) = sv_2mortal(newSViv(cxix));
1568  XSRETURN(1);
1569
1570 void
1571 want_at(...)
1572 PROTOTYPE: ;$
1573 PREINIT:
1574  I32 cxix;
1575 PPCODE:
1576  SU_GET_CONTEXT(0, 0);
1577  while (cxix > 0) {
1578   PERL_CONTEXT *cx = cxstack + cxix--;
1579   switch (CxTYPE(cx)) {
1580    case CXt_SUB:
1581    case CXt_EVAL:
1582    case CXt_FORMAT: {
1583     I32 gimme = cx->blk_gimme;
1584     switch (gimme) {
1585      case G_VOID:   XSRETURN_UNDEF; break;
1586      case G_SCALAR: XSRETURN_NO;    break;
1587      case G_ARRAY:  XSRETURN_YES;   break;
1588     }
1589     break;
1590    }
1591   }
1592  }
1593  XSRETURN_UNDEF;
1594
1595 void
1596 reap(SV *hook, ...)
1597 PROTOTYPE: &;$
1598 PREINIT:
1599  I32 cxix;
1600  su_ud_reap *ud;
1601 CODE:
1602  SU_GET_CONTEXT(1, 1);
1603  Newx(ud, 1, su_ud_reap);
1604  SU_UD_ORIGIN(ud)  = NULL;
1605  SU_UD_HANDLER(ud) = su_reap;
1606  ud->cb = newSVsv(hook);
1607  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1608
1609 void
1610 localize(SV *sv, SV *val, ...)
1611 PROTOTYPE: $$;$
1612 PREINIT:
1613  I32 cxix;
1614  I32 size;
1615  su_ud_localize *ud;
1616 CODE:
1617  SU_GET_CONTEXT(2, 2);
1618  Newx(ud, 1, su_ud_localize);
1619  SU_UD_ORIGIN(ud)  = NULL;
1620  SU_UD_HANDLER(ud) = su_localize;
1621  size = su_ud_localize_init(ud, sv, val, NULL);
1622  su_init(ud, cxix, size);
1623
1624 void
1625 localize_elem(SV *sv, SV *elem, SV *val, ...)
1626 PROTOTYPE: $$$;$
1627 PREINIT:
1628  I32 cxix;
1629  I32 size;
1630  su_ud_localize *ud;
1631 CODE:
1632  if (SvTYPE(sv) >= SVt_PVGV)
1633   croak("Can't infer the element localization type from a glob and the value");
1634  SU_GET_CONTEXT(3, 3);
1635  Newx(ud, 1, su_ud_localize);
1636  SU_UD_ORIGIN(ud)  = NULL;
1637  SU_UD_HANDLER(ud) = su_localize;
1638  size = su_ud_localize_init(ud, sv, val, elem);
1639  if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
1640   SU_UD_LOCALIZE_FREE(ud);
1641   croak("Can't localize an element of something that isn't an array or a hash");
1642  }
1643  su_init(ud, cxix, size);
1644
1645 void
1646 localize_delete(SV *sv, SV *elem, ...)
1647 PROTOTYPE: $$;$
1648 PREINIT:
1649  I32 cxix;
1650  I32 size;
1651  su_ud_localize *ud;
1652 CODE:
1653  SU_GET_CONTEXT(2, 2);
1654  Newx(ud, 1, su_ud_localize);
1655  SU_UD_ORIGIN(ud)  = NULL;
1656  SU_UD_HANDLER(ud) = su_localize;
1657  size = su_ud_localize_init(ud, sv, NULL, elem);
1658  su_init(ud, cxix, size);
1659
1660 void
1661 uplevel(SV *code, ...)
1662 PROTOTYPE: &@
1663 PREINIT:
1664  I32 cxix, ret, args = 0;
1665 PPCODE:
1666  if (SvROK(code))
1667   code = SvRV(code);
1668  if (SvTYPE(code) < SVt_PVCV)
1669   croak("First argument to uplevel must be a code reference");
1670  SU_GET_CONTEXT(1, items - 1);
1671  do {
1672   PERL_CONTEXT *cx = cxstack + cxix;
1673   switch (CxTYPE(cx)) {
1674    case CXt_EVAL:
1675     croak("Can't uplevel to an eval frame");
1676    case CXt_FORMAT:
1677     croak("Can't uplevel to a format frame");
1678    case CXt_SUB:
1679     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1680      continue;
1681     if (items > 1) {
1682      PL_stack_sp--;
1683      args = items - 2;
1684     }
1685     ret = su_uplevel((CV *) code, cxix, args);
1686     XSRETURN(ret);
1687    default:
1688     break;
1689   }
1690  } while (--cxix >= 0);
1691  croak("Can't uplevel outside a subroutine");