]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - Upper.xs
1c717aeaf8d9e926d25ebc96ca12f620df4924d3
[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 su_uplevel_ud *su_uplevel_storage_new(pTHX) {
921 #define su_uplevel_storage_new() su_uplevel_storage_new(aTHX)
922  su_uplevel_ud *sud;
923  dMY_CXT;
924
925  sud = MY_CXT.uplevel_storage.root;
926  if (sud) {
927   MY_CXT.uplevel_storage.root = sud->next;
928   MY_CXT.uplevel_storage.count--;
929  } else {
930   sud = su_uplevel_ud_new();
931  }
932
933  return sud;
934 }
935
936 STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
937 #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
938  dMY_CXT;
939
940  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
941   su_uplevel_ud_delete(sud);
942  } else {
943   sud->next = MY_CXT.uplevel_storage.root;
944   MY_CXT.uplevel_storage.root = sud;
945   MY_CXT.uplevel_storage.count++;
946  }
947 }
948
949 #define SU_HAS_EXT_MAGIC SU_HAS_PERL(5, 8, 0)
950
951 #if SU_HAS_EXT_MAGIC
952
953 STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
954  su_uplevel_storage_delete((su_uplevel_ud *) mg->mg_ptr);
955
956  return 0;
957 }
958
959 STATIC MGVTBL su_uplevel_restore_vtbl = {
960  0,
961  0,
962  0,
963  0,
964  su_uplevel_restore_free
965 };
966
967 #endif /* SU_HAS_EXT_MAGIC */
968
969 STATIC void su_uplevel_restore(pTHX_ void *sus_) {
970  su_uplevel_ud *sud = sus_;
971  PERL_SI *cur = sud->old_curstackinfo;
972  PERL_SI *si  = sud->si;
973
974  /* When we reach this place, POPSUB has already been called (with our fake
975   * argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
976   * before uplevel). argarray is either the fake AV we created in su_uplevel()
977   * or some empty replacement POPSUB creates when @_ is reified. In both cases
978   * we have to destroy it before the context stack is swapped back to its
979   * original state. */
980  SvREFCNT_dec(cxstack[sud->cxix].blk_sub.argarray);
981
982  CATCH_SET(sud->old_catch);
983
984  SvREFCNT_dec(sud->cloned_cv);
985
986  SU_UPLEVEL_RESTORE(op);
987
988  /* stack_grow() wants PL_curstack so restore the old stack first */
989  if (PL_curstackinfo == si) {
990   PL_curstack = cur->si_stack;
991   if (sud->old_mainstack)
992    SU_UPLEVEL_RESTORE(mainstack);
993   SU_UPLEVEL_RESTORE(curstackinfo);
994
995   if (sud->died) {
996    CV *target_cv = sud->target;
997    I32 levels = 0, i;
998
999    /* When we die, the depth of the target CV is not updated because of the
1000     * stack switcheroo. So we have to look at all the frames between the
1001     * uplevel call and the catch block to count how many call frames to the
1002     * target CV were skipped. */
1003    for (i = cur->si_cxix; i > sud->cxix; i--) {
1004     register const PERL_CONTEXT *cx = cxstack + i;
1005
1006     if (CxTYPE(cx) == CXt_SUB) {
1007      if (cx->blk_sub.cv == target_cv)
1008       ++levels;
1009     }
1010    }
1011
1012    /* If we died, the replacement stack was already unwinded to the first
1013     * eval frame, and all the contexts down there were popped. We don't have
1014     * to pop manually any context of the original stack, because they must
1015     * have been in the replacement stack as well (since the second was copied
1016     * from the first). Thus we only have to make sure the original stack index
1017     * points to the context just below the first eval scope under the target
1018     * frame. */
1019    for (; i >= 0; i--) {
1020     register const PERL_CONTEXT *cx = cxstack + i;
1021
1022     switch (CxTYPE(cx)) {
1023      case CXt_SUB:
1024       if (cx->blk_sub.cv == target_cv)
1025        ++levels;
1026       break;
1027      case CXt_EVAL:
1028       goto found_it;
1029       break;
1030      default:
1031       break;
1032     }
1033    }
1034
1035 found_it:
1036    CvDEPTH(target_cv) = sud->old_depth - levels;
1037    PL_curstackinfo->si_cxix = i - 1;
1038
1039 #if !SU_HAS_PERL(5, 13, 1)
1040    /* Since $@ was maybe localized between the target frame and the uplevel
1041     * call, we forcefully flush the save stack to get rid of it and then
1042     * reset $@ to its proper value. Note that the the call to
1043     * su_uplevel_restore() must happen before the "reset $@" item of the save
1044     * stack is processed, as uplevel was called after the localization.
1045     * Andrew's changes to how $@ was handled, which were mainly integrated
1046     * between perl 5.13.0 and 5.13.1, fixed this. */
1047    if (ERRSV && SvTRUE(ERRSV)) {
1048     register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1049     SV *errsv = SvREFCNT_inc(ERRSV);
1050     PL_scopestack_ix = cx->blk_oldscopesp;
1051     leave_scope(PL_scopestack[PL_scopestack_ix]);
1052     sv_setsv(ERRSV, errsv);
1053     SvREFCNT_dec(errsv);
1054    }
1055 #endif
1056   }
1057  }
1058
1059  SU_UPLEVEL_RESTORE(curcop);
1060
1061  SvREFCNT_dec(sud->target);
1062
1063  PL_stack_base = AvARRAY(cur->si_stack);
1064  PL_stack_sp   = PL_stack_base + AvFILLp(cur->si_stack);
1065  PL_stack_max  = PL_stack_base + AvMAX(cur->si_stack);
1066
1067  /* When an exception is thrown from the uplevel'd subroutine,
1068   * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed
1069   * die_where() in more recent perls), which has the sad habit of keeping a
1070   * pointer to the current context frame across this call. This means that we
1071   * can't free the temporary context stack we used for the uplevel call right
1072   * now, or that pointer upwards would point to garbage. */
1073 #if SU_HAS_PERL(5, 13, 7)
1074  /* This issue has been fixed in perl with commit 8f89e5a9, which was made
1075   * public in perl 5.13.7. */
1076  su_uplevel_storage_delete(sud);
1077 #elif SU_HAS_EXT_MAGIC
1078  /* If 'ext' magic is available, we work around this by attaching the state
1079   * data to a scalar that will be freed "soon". */
1080  {
1081   SV *sv = sv_newmortal();
1082
1083   sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
1084                         (const char *) sud, 0);
1085  }
1086 #else
1087  /* Otherwise, we just enqueue it back in the global storage list. */
1088  {
1089   dMY_CXT;
1090
1091   sud->next = MY_CXT.uplevel_storage.root;
1092   MY_CXT.uplevel_storage.root = sud;
1093   MY_CXT.uplevel_storage.count++;
1094  }
1095 #endif
1096
1097  return;
1098 }
1099
1100 STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
1101 #define su_cv_clone(C) su_cv_clone(aTHX_ (C))
1102  CV *new_cv;
1103
1104  /* Starting from commit b5c19bd7 (first made public with perl 5.9.0),
1105   * cv_clone() has an assert that checks whether CvDEPTH(CvOUTSIDE(proto)) > 0.
1106   * If this perl has DEBUGGING enabled, we have to fool cv_clone() with a
1107   * little dance. */
1108 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1109  I32 old_depth;
1110  CV *outside = CvOUTSIDE(old_cv);
1111
1112  if (outside && CvCLONE(outside) && !CvCLONED(outside))
1113   outside = find_runcv(NULL);
1114  old_depth = CvDEPTH(outside);
1115  if (!old_depth)
1116   CvDEPTH(outside) = 1;
1117 #endif
1118
1119  new_cv = cv_clone(old_cv);
1120
1121 #if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
1122  CvDEPTH(outside) = old_depth;
1123 #endif
1124
1125  /* Still from commit b5c19bd7, cv_clone() is no longer able to clone named
1126   * subs propery. With this commit, pad_findlex() stores the parent index of a
1127   * fake pad entry in the NV slot of the corresponding pad name SV, but only
1128   * for anonymous subs (since named subs aren't supposed to be cloned in pure
1129   * Perl land). To fix this, we just manually relink the new fake pad entries
1130   * to the new ones.
1131   * For some reason perl 5.8 crashes too without this, supposedly because of
1132   * other closure bugs. Hence we enable it everywhere. */
1133  if (!CvCLONE(old_cv)) {
1134   const AV  *old_padname = (const AV *)  AvARRAY(CvPADLIST(old_cv))[0];
1135   AV        *old_pad     = (AV *)        AvARRAY(CvPADLIST(old_cv))[1];
1136   AV        *new_pad     = (AV *)        AvARRAY(CvPADLIST(new_cv))[1];
1137   const SV **old_aryname = (const SV **) AvARRAY(old_padname);
1138   SV       **old_ary     = AvARRAY(old_pad);
1139   SV       **new_ary     = AvARRAY(new_pad);
1140   I32 fname = AvFILLp(old_padname);
1141   I32 fpad  = AvFILLp(old_pad);
1142   I32 ix;
1143
1144   for (ix = fpad; ix > 0; ix--) {
1145    const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
1146
1147    if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
1148     SvREFCNT_dec(new_ary[ix]);
1149     new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
1150    }
1151   }
1152  }
1153
1154  return new_cv;
1155 }
1156
1157 STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
1158 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1159  su_uplevel_ud *sud;
1160  const PERL_CONTEXT *cx = cxstack + cxix;
1161  PERL_SI *si;
1162  PERL_SI *cur = PL_curstackinfo;
1163  SV **old_stack_sp;
1164  CV  *target_cv;
1165  UNOP sub_op;
1166  I32  marksize;
1167  I32  gimme;
1168  I32  old_mark, new_mark;
1169  I32  ret;
1170  dSP;
1171
1172  ENTER;
1173
1174  gimme = GIMME_V;
1175  /* Make PL_stack_sp point just before the CV. */
1176  PL_stack_sp -= args + 1;
1177  old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1178  SPAGAIN;
1179
1180  sud = su_uplevel_storage_new();
1181  si  = sud->si;
1182
1183  sud->cxix = cxix;
1184  sud->died = 1;
1185  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1186
1187  si->si_type = cur->si_type;
1188  si->si_next = NULL;
1189  si->si_prev = cur->si_prev;
1190
1191  /* Allocate enough space for all the elements of the original stack up to the
1192   * target context, plus the forthcoming arguments. */
1193  new_mark = cx->blk_oldsp;
1194  av_extend(si->si_stack, new_mark + 1 + args + 1);
1195  Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1196  AvFILLp(si->si_stack) = new_mark;
1197  SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1198
1199  /* Specialized SWITCHSTACK() */
1200  PL_stack_base = AvARRAY(si->si_stack);
1201  old_stack_sp  = PL_stack_sp;
1202  PL_stack_sp   = PL_stack_base + AvFILLp(si->si_stack);
1203  PL_stack_max  = PL_stack_base + AvMAX(si->si_stack);
1204  SPAGAIN;
1205
1206 #ifdef DEBUGGING
1207  si->si_markoff = cx->blk_oldmarksp;
1208 #endif
1209
1210  /* Copy the context stack up to the context just below the target. */
1211  si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1212  if (si->si_cxmax < cxix) {
1213   /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1214   si->si_cxmax = (cxix < 4) ? 4 : cxix;
1215   Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1216  }
1217  Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1218  SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1219
1220  target_cv      = cx->blk_sub.cv;
1221  sud->target    = (CV *) SvREFCNT_inc(target_cv);
1222  sud->old_depth = CvDEPTH(target_cv);
1223
1224  /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1225   * run-time implication, since PL_curcop will be overwritten as soon as we
1226   * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1227   * make it point to the blk_oldcop for the target frame, so that caller()
1228   * reports the right file name, line number and lexical hints. */
1229  SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1230  /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1231   * this point. Don't reset PL_curpm either, we want the most recent matches. */
1232
1233  SU_UPLEVEL_SAVE(curstackinfo, si);
1234  /* If those two are equal, we need to fool POPSTACK_TO() */
1235  if (PL_mainstack == PL_curstack)
1236   SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1237  else
1238   sud->old_mainstack = NULL;
1239  PL_curstack = si->si_stack;
1240
1241  cv = su_cv_clone(cv);
1242  sud->cloned_cv = cv;
1243  CvGV_set(cv, CvGV(target_cv));
1244
1245  PUSHMARK(SP);
1246  /* Both SP and old_stack_sp point just before the CV. */
1247  Copy(old_stack_sp + 2, SP + 1, args, SV *);
1248  SP += args;
1249  PUSHs((SV *) cv);
1250  PUTBACK;
1251
1252  Zero(&sub_op, 1, UNOP);
1253  sub_op.op_type  = OP_ENTERSUB;
1254  sub_op.op_next  = NULL;
1255  sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1256  if (PL_DBsub)
1257   sub_op.op_flags |= OPpENTERSUB_DB;
1258
1259  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1260
1261  sud->old_catch = CATCH_GET;
1262  CATCH_SET(TRUE);
1263
1264  if (PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)) {
1265   if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1266    /* The call to pp_entersub() has saved the current @_ (in XS terms,
1267     * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1268     * with what we put on the stack. But we want to fake up the same arguments
1269     * as the ones in use at the context we uplevel to, so we replace the
1270     * argarray with an unreal copy of the original @_. */
1271    AV *av = newAV();
1272    AvREAL_off(av);
1273    av_extend(av, AvMAX(cx->blk_sub.argarray));
1274    AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1275    Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1276    cxstack[cxix].blk_sub.argarray = av;
1277   } else {
1278    SvREFCNT_inc(cxstack[cxix].blk_sub.argarray);
1279   }
1280
1281   CALLRUNOPS(aTHX);
1282
1283   ret = PL_stack_sp - (PL_stack_base + new_mark);
1284  }
1285
1286  sud->died = 0;
1287
1288  SPAGAIN;
1289
1290  if (ret > 0) {
1291   AV *old_stack = sud->old_curstackinfo->si_stack;
1292
1293   if (old_mark + ret > AvMAX(old_stack)) {
1294    /* Specialized EXTEND(old_sp, ret) */
1295    av_extend(old_stack, old_mark + ret + 1);
1296    old_stack_sp = AvARRAY(old_stack) + old_mark;
1297   }
1298
1299   Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1300   PL_stack_sp        += ret;
1301   AvFILLp(old_stack) += ret;
1302  }
1303
1304  PUTBACK;
1305
1306  LEAVE;
1307
1308  return ret;
1309 }
1310
1311 /* --- Interpreter setup/teardown ------------------------------------------ */
1312
1313 STATIC void su_teardown(pTHX_ void *param) {
1314  su_uplevel_ud *cur, *prev;
1315  dMY_CXT;
1316
1317  cur = MY_CXT.uplevel_storage.root;
1318  if (cur) {
1319   su_uplevel_ud *prev;
1320   do {
1321    prev = cur;
1322    cur  = prev->next;
1323    su_uplevel_ud_delete(prev);
1324   } while (cur);
1325  }
1326
1327  return;
1328 }
1329
1330 STATIC void su_setup(pTHX) {
1331 #define su_setup() su_setup(aTHX)
1332  MY_CXT_INIT;
1333
1334  MY_CXT.stack_placeholder = NULL;
1335
1336  /* NewOp() calls calloc() which just zeroes the memory with memset(). */
1337  Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
1338  MY_CXT.return_op.op_type   = OP_RETURN;
1339  MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
1340
1341  Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
1342  MY_CXT.proxy_op.op_type   = OP_STUB;
1343  MY_CXT.proxy_op.op_ppaddr = NULL;
1344
1345  MY_CXT.uplevel_storage.root  = NULL;
1346  MY_CXT.uplevel_storage.count = 0;
1347
1348  call_atexit(su_teardown, NULL);
1349
1350  return;
1351 }
1352
1353 /* --- XS ------------------------------------------------------------------ */
1354
1355 #if SU_HAS_PERL(5, 8, 9)
1356 # define SU_SKIP_DB_MAX 2
1357 #else
1358 # define SU_SKIP_DB_MAX 3
1359 #endif
1360
1361 /* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
1362  * followed by a DB sub */
1363
1364 #define SU_SKIP_DB(C) \
1365  STMT_START {         \
1366   I32 skipped = 0;    \
1367   PERL_CONTEXT *base = cxstack;      \
1368   PERL_CONTEXT *cx   = base + (C);   \
1369   while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
1370    --cx, ++skipped;                  \
1371   if (cx >= base && (C) > skipped) { \
1372    switch (CxTYPE(cx)) {  \
1373     case CXt_SUB:         \
1374      if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
1375       (C) -= skipped + 1; \
1376       break;              \
1377     default:              \
1378      break;               \
1379    }                      \
1380   }                       \
1381  } STMT_END
1382
1383 #define SU_GET_CONTEXT(A, B)   \
1384  STMT_START {                  \
1385   if (items > A) {             \
1386    SV *csv = ST(B);            \
1387    if (!SvOK(csv))             \
1388     goto default_cx;           \
1389    cxix = SvIV(csv);           \
1390    if (cxix < 0)               \
1391     cxix = 0;                  \
1392    else if (cxix > cxstack_ix) \
1393     cxix = cxstack_ix;         \
1394   } else {                     \
1395 default_cx:                    \
1396    cxix = cxstack_ix;          \
1397    if (PL_DBsub)               \
1398     SU_SKIP_DB(cxix);          \
1399   }                            \
1400  } STMT_END
1401
1402 #define SU_GET_LEVEL(A, B) \
1403  STMT_START {              \
1404   level = 0;               \
1405   if (items > 0) {         \
1406    SV *lsv = ST(B);        \
1407    if (SvOK(lsv)) {        \
1408     level = SvIV(lsv);     \
1409     if (level < 0)         \
1410      level = 0;            \
1411    }                       \
1412   }                        \
1413  } STMT_END
1414
1415 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
1416
1417 XS(XS_Scope__Upper_unwind) {
1418 #ifdef dVAR
1419  dVAR; dXSARGS;
1420 #else
1421  dXSARGS;
1422 #endif
1423  dMY_CXT;
1424  I32 cxix;
1425
1426  PERL_UNUSED_VAR(cv); /* -W */
1427  PERL_UNUSED_VAR(ax); /* -Wall */
1428
1429  SU_GET_CONTEXT(0, items - 1);
1430  do {
1431   PERL_CONTEXT *cx = cxstack + cxix;
1432   switch (CxTYPE(cx)) {
1433    case CXt_SUB:
1434     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1435      continue;
1436    case CXt_EVAL:
1437    case CXt_FORMAT:
1438     MY_CXT.cxix  = cxix;
1439     MY_CXT.items = items;
1440     /* pp_entersub will want to sanitize the stack after returning from there
1441      * Screw that, we're insane */
1442     if (GIMME_V == G_SCALAR) {
1443      MY_CXT.savesp = PL_stack_sp;
1444      /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
1445      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
1446     } else {
1447      MY_CXT.savesp = NULL;
1448     }
1449     SAVEDESTRUCTOR_X(su_unwind, NULL);
1450     return;
1451    default:
1452     break;
1453   }
1454  } while (--cxix >= 0);
1455  croak("Can't return outside a subroutine");
1456 }
1457
1458 MODULE = Scope::Upper            PACKAGE = Scope::Upper
1459
1460 PROTOTYPES: ENABLE
1461
1462 BOOT:
1463 {
1464  HV *stash;
1465
1466  stash = gv_stashpv(__PACKAGE__, 1);
1467  newCONSTSUB(stash, "TOP",           newSViv(0));
1468  newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
1469
1470  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
1471
1472  su_setup();
1473 }
1474
1475 #if SU_THREADSAFE
1476
1477 void
1478 CLONE(...)
1479 PROTOTYPE: DISABLE
1480 PPCODE:
1481  {
1482   MY_CXT_CLONE;
1483   MY_CXT.uplevel_storage.root  = NULL;
1484   MY_CXT.uplevel_storage.count = 0;
1485  }
1486  XSRETURN(0);
1487
1488 #endif /* SU_THREADSAFE */
1489
1490 SV *
1491 HERE()
1492 PROTOTYPE:
1493 PREINIT:
1494  I32 cxix = cxstack_ix;
1495 CODE:
1496  if (PL_DBsub)
1497   SU_SKIP_DB(cxix);
1498  RETVAL = newSViv(cxix);
1499 OUTPUT:
1500  RETVAL
1501
1502 SV *
1503 UP(...)
1504 PROTOTYPE: ;$
1505 PREINIT:
1506  I32 cxix;
1507 CODE:
1508  SU_GET_CONTEXT(0, 0);
1509  if (--cxix < 0)
1510   cxix = 0;
1511  if (PL_DBsub)
1512   SU_SKIP_DB(cxix);
1513  RETVAL = newSViv(cxix);
1514 OUTPUT:
1515  RETVAL
1516
1517 void
1518 SUB(...)
1519 PROTOTYPE: ;$
1520 PREINIT:
1521  I32 cxix;
1522 PPCODE:
1523  SU_GET_CONTEXT(0, 0);
1524  for (; cxix >= 0; --cxix) {
1525   PERL_CONTEXT *cx = cxstack + cxix;
1526   switch (CxTYPE(cx)) {
1527    default:
1528     continue;
1529    case CXt_SUB:
1530     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1531      continue;
1532     ST(0) = sv_2mortal(newSViv(cxix));
1533     XSRETURN(1);
1534   }
1535  }
1536  XSRETURN_UNDEF;
1537
1538 void
1539 EVAL(...)
1540 PROTOTYPE: ;$
1541 PREINIT:
1542  I32 cxix;
1543 PPCODE:
1544  SU_GET_CONTEXT(0, 0);
1545  for (; cxix >= 0; --cxix) {
1546   PERL_CONTEXT *cx = cxstack + cxix;
1547   switch (CxTYPE(cx)) {
1548    default:
1549     continue;
1550    case CXt_EVAL:
1551     ST(0) = sv_2mortal(newSViv(cxix));
1552     XSRETURN(1);
1553   }
1554  }
1555  XSRETURN_UNDEF;
1556
1557 void
1558 SCOPE(...)
1559 PROTOTYPE: ;$
1560 PREINIT:
1561  I32 cxix, level;
1562 PPCODE:
1563  SU_GET_LEVEL(0, 0);
1564  cxix = cxstack_ix;
1565  if (PL_DBsub) {
1566   SU_SKIP_DB(cxix);
1567   while (cxix > 0) {
1568    if (--level < 0)
1569     break;
1570    --cxix;
1571    SU_SKIP_DB(cxix);
1572   }
1573  } else {
1574   cxix -= level;
1575   if (cxix < 0)
1576    cxix = 0;
1577  }
1578  ST(0) = sv_2mortal(newSViv(cxix));
1579  XSRETURN(1);
1580
1581 void
1582 CALLER(...)
1583 PROTOTYPE: ;$
1584 PREINIT:
1585  I32 cxix, level;
1586 PPCODE:
1587  SU_GET_LEVEL(0, 0);
1588  for (cxix = cxstack_ix; cxix > 0; --cxix) {
1589   PERL_CONTEXT *cx = cxstack + cxix;
1590   switch (CxTYPE(cx)) {
1591    case CXt_SUB:
1592     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1593      continue;
1594    case CXt_EVAL:
1595    case CXt_FORMAT:
1596     if (--level < 0)
1597      goto done;
1598     break;
1599   }
1600  }
1601 done:
1602  ST(0) = sv_2mortal(newSViv(cxix));
1603  XSRETURN(1);
1604
1605 void
1606 want_at(...)
1607 PROTOTYPE: ;$
1608 PREINIT:
1609  I32 cxix;
1610 PPCODE:
1611  SU_GET_CONTEXT(0, 0);
1612  while (cxix > 0) {
1613   PERL_CONTEXT *cx = cxstack + cxix--;
1614   switch (CxTYPE(cx)) {
1615    case CXt_SUB:
1616    case CXt_EVAL:
1617    case CXt_FORMAT: {
1618     I32 gimme = cx->blk_gimme;
1619     switch (gimme) {
1620      case G_VOID:   XSRETURN_UNDEF; break;
1621      case G_SCALAR: XSRETURN_NO;    break;
1622      case G_ARRAY:  XSRETURN_YES;   break;
1623     }
1624     break;
1625    }
1626   }
1627  }
1628  XSRETURN_UNDEF;
1629
1630 void
1631 reap(SV *hook, ...)
1632 PROTOTYPE: &;$
1633 PREINIT:
1634  I32 cxix;
1635  su_ud_reap *ud;
1636 CODE:
1637  SU_GET_CONTEXT(1, 1);
1638  Newx(ud, 1, su_ud_reap);
1639  SU_UD_ORIGIN(ud)  = NULL;
1640  SU_UD_HANDLER(ud) = su_reap;
1641  ud->cb = newSVsv(hook);
1642  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1643
1644 void
1645 localize(SV *sv, SV *val, ...)
1646 PROTOTYPE: $$;$
1647 PREINIT:
1648  I32 cxix;
1649  I32 size;
1650  su_ud_localize *ud;
1651 CODE:
1652  SU_GET_CONTEXT(2, 2);
1653  Newx(ud, 1, su_ud_localize);
1654  SU_UD_ORIGIN(ud)  = NULL;
1655  SU_UD_HANDLER(ud) = su_localize;
1656  size = su_ud_localize_init(ud, sv, val, NULL);
1657  su_init(ud, cxix, size);
1658
1659 void
1660 localize_elem(SV *sv, SV *elem, SV *val, ...)
1661 PROTOTYPE: $$$;$
1662 PREINIT:
1663  I32 cxix;
1664  I32 size;
1665  su_ud_localize *ud;
1666 CODE:
1667  if (SvTYPE(sv) >= SVt_PVGV)
1668   croak("Can't infer the element localization type from a glob and the value");
1669  SU_GET_CONTEXT(3, 3);
1670  Newx(ud, 1, su_ud_localize);
1671  SU_UD_ORIGIN(ud)  = NULL;
1672  SU_UD_HANDLER(ud) = su_localize;
1673  size = su_ud_localize_init(ud, sv, val, elem);
1674  if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
1675   SU_UD_LOCALIZE_FREE(ud);
1676   croak("Can't localize an element of something that isn't an array or a hash");
1677  }
1678  su_init(ud, cxix, size);
1679
1680 void
1681 localize_delete(SV *sv, SV *elem, ...)
1682 PROTOTYPE: $$;$
1683 PREINIT:
1684  I32 cxix;
1685  I32 size;
1686  su_ud_localize *ud;
1687 CODE:
1688  SU_GET_CONTEXT(2, 2);
1689  Newx(ud, 1, su_ud_localize);
1690  SU_UD_ORIGIN(ud)  = NULL;
1691  SU_UD_HANDLER(ud) = su_localize;
1692  size = su_ud_localize_init(ud, sv, NULL, elem);
1693  su_init(ud, cxix, size);
1694
1695 void
1696 uplevel(SV *code, ...)
1697 PROTOTYPE: &@
1698 PREINIT:
1699  I32 cxix, ret, args = 0;
1700 PPCODE:
1701  if (SvROK(code))
1702   code = SvRV(code);
1703  if (SvTYPE(code) < SVt_PVCV)
1704   croak("First argument to uplevel must be a code reference");
1705  SU_GET_CONTEXT(1, items - 1);
1706  do {
1707   PERL_CONTEXT *cx = cxstack + cxix;
1708   switch (CxTYPE(cx)) {
1709    case CXt_EVAL:
1710     croak("Can't uplevel to an eval frame");
1711    case CXt_FORMAT:
1712     croak("Can't uplevel to a format frame");
1713    case CXt_SUB:
1714     if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1715      continue;
1716     if (items > 1) {
1717      PL_stack_sp--;
1718      args = items - 2;
1719     }
1720     ret = su_uplevel((CV *) code, cxix, args);
1721     XSRETURN(ret);
1722    default:
1723     break;
1724   }
1725  } while (--cxix >= 0);
1726  croak("Can't uplevel outside a subroutine");