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