File Coverage

File:Upper.xs
Coverage:95.7%

linestmtbrancondsubpodtimecode
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
75STATIC 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/* --- Unique context ID global storage ------------------------------------ */
183
184/* ... Sequence ID counter ................................................. */
185
186typedef struct {
187 UV *seqs;
188 STRLEN size;
189} su_uv_array;
190
191STATIC su_uv_array su_uid_seq_counter;
192
193#ifdef USE_ITHREADS
194
195STATIC perl_mutex su_uid_seq_counter_mutex;
196
197#define SU_LOCK(M) MUTEX_LOCK(M)
198#define SU_UNLOCK(M) MUTEX_UNLOCK(M)
199
200#else /* USE_ITHREADS */
201
202#define SU_LOCK(M)
203#define SU_UNLOCK(M)
204
205#endif /* !USE_ITHREADS */
206
207
823
STATIC UV su_uid_seq_next(pTHX_ UV depth) {
208#define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D))
209 UV seq;
210 UV *seqs;
211
212 SU_LOCK(&su_uid_seq_counter_mutex);
213
214
823
 seqs = su_uid_seq_counter.seqs;
215
216
823
 if (depth >= su_uid_seq_counter.size) {
217  UV i;
218
219
20
  seqs = PerlMemShared_realloc(seqs, (depth + 1) * sizeof(UV));
220
69
  for (i = su_uid_seq_counter.size; i <= depth; ++i)
221
49
   seqs[i] = 0;
222
223
20
  su_uid_seq_counter.seqs = seqs;
224
20
  su_uid_seq_counter.size = depth + 1;
225 }
226
227
823
 seq = ++seqs[depth];
228
229 SU_UNLOCK(&su_uid_seq_counter_mutex);
230
231
823
 return seq;
232}
233
234/* ... UID storage ......................................................... */
235
236typedef struct {
237 UV seq;
238 U32 flags;
239} su_uid;
240
241#define SU_UID_ACTIVE 1
242
243
3588
STATIC UV su_uid_depth(pTHX_ I32 cxix) {
244#define su_uid_depth(I) su_uid_depth(aTHX_ (I))
245 const PERL_SI *si;
246 UV depth;
247
248
3588
 depth = cxix;
249
3592
 for (si = PL_curstackinfo->si_prev; si; si = si->si_prev)
250
4
  depth += si->si_cxix + 1;
251
252
3588
 return depth;
253}
254
255typedef struct {
256 su_uid **map;
257 STRLEN used;
258 STRLEN alloc;
259} su_uid_storage;
260
261
2749
STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) {
262#define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D))
263
2749
 su_uid **old_map = old_cxt->map;
264
265
2749
 if (old_map) {
266
503
  su_uid **new_map = new_cxt->map;
267
503
  STRLEN old_used = old_cxt->used;
268
503
  STRLEN old_alloc = old_cxt->alloc;
269  STRLEN new_used, new_alloc;
270  STRLEN i;
271
272
503
  new_used = max_depth < old_used ? max_depth : old_used;
273
503
  new_cxt->used = new_used;
274
275
503
  if (new_used <= new_cxt->alloc)
276
241
   new_alloc = new_cxt->alloc;
277  else {
278
262
   new_alloc = new_used;
279
262
   Renew(new_map, new_alloc, su_uid *);
280
2428
   for (i = new_cxt->alloc; i < new_alloc; ++i)
281
2166
    new_map[i] = NULL;
282
262
   new_cxt->map = new_map;
283
262
   new_cxt->alloc = new_alloc;
284  }
285
286
8307
  for (i = 0; i < new_alloc; ++i) {
287
5558
   su_uid *new_uid = new_map[i];
288
289
5558
   if (i < new_used) { /* => i < max_depth && i < old_used */
290
3980
    su_uid *old_uid = old_map[i];
291
292
3980
    if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) {
293
1658
     if (!new_uid) {
294
1233
      Newx(new_uid, 1, su_uid);
295
1233
      new_map[i] = new_uid;
296     }
297
1658
     *new_uid = *old_uid;
298
1658
     continue;
299    }
300   }
301
302
3900
   if (new_uid)
303
1129
    new_uid->flags &= ~SU_UID_ACTIVE;
304  }
305 }
306
307 return;
308}
309
310/* --- unwind() global storage --------------------------------------------- */
311
312typedef struct {
313 I32 cxix;
314 I32 items;
315 SV **savesp;
316 LISTOP return_op;
317 OP proxy_op;
318} su_unwind_storage;
319
320/* --- uplevel() data tokens and global storage ---------------------------- */
321
322#define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0)
323
324typedef struct {
325 void *next;
326
327 I32 cxix;
328 bool died;
329
330 CV *target;
331 I32 target_depth;
332
333 CV *callback;
334 CV *renamed;
335
336 PERL_SI *si;
337 PERL_SI *old_curstackinfo;
338 AV *old_mainstack;
339
340 COP *old_curcop;
341
342#if SU_UPLEVEL_HIJACKS_RUNOPS
343 runops_proc_t old_runops;
344#endif
345 bool old_catch;
346 OP *old_op;
347
348 su_uid_storage new_uid_storage, old_uid_storage;
349} su_uplevel_ud;
350
351
242
STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
352#define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
353 su_uplevel_ud *sud;
354 PERL_SI *si;
355
356
242
 Newx(sud, 1, su_uplevel_ud);
357
242
 sud->next = NULL;
358
359
242
 sud->new_uid_storage.map = NULL;
360
242
 sud->new_uid_storage.used = 0;
361
242
 sud->new_uid_storage.alloc = 0;
362
363
242
 Newx(si, 1, PERL_SI);
364
242
 si->si_stack = newAV();
365
242
 AvREAL_off(si->si_stack);
366
242
 si->si_cxstack = NULL;
367
242
 si->si_cxmax = 0;
368
369
242
 sud->si = si;
370
371
242
 return sud;
372}
373
374
242
STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
375#define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
376
242
 PERL_SI *si = sud->si;
377
378
242
 Safefree(si->si_cxstack);
379
242
 SvREFCNT_dec(si->si_stack);
380
242
 Safefree(si);
381
382
242
 if (sud->new_uid_storage.map) {
383
230
  su_uid **map = sud->new_uid_storage.map;
384
230
  STRLEN alloc = sud->new_uid_storage.alloc;
385  STRLEN i;
386
387
2604
  for (i = 0; i < alloc; ++i)
388
2374
   Safefree(map[i]);
389
390
230
  Safefree(map);
391 }
392
393
242
 Safefree(sud);
394
395 return;
396}
397
398typedef struct {
399 su_uplevel_ud *top;
400 su_uplevel_ud *root;
401 I32 count;
402} su_uplevel_storage;
403
404#ifndef SU_UPLEVEL_STORAGE_SIZE
405# define SU_UPLEVEL_STORAGE_SIZE 4
406#endif
407
408/* --- Global data --------------------------------------------------------- */
409
410#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
411
412typedef struct {
413 char *stack_placeholder;
414 su_unwind_storage unwind_storage;
415 su_uplevel_storage uplevel_storage;
416 su_uid_storage uid_storage;
417} my_cxt_t;
418
419START_MY_CXT
420
421/* --- Stack manipulations ------------------------------------------------- */
422
423#define SU_SAVE_PLACEHOLDER() save_pptr(&MY_CXT.stack_placeholder)
424
425#define SU_SAVE_DESTRUCTOR_SIZE 3
426#define SU_SAVE_PLACEHOLDER_SIZE 3
427
428#define SU_SAVE_SCALAR_SIZE 3
429
430#define SU_SAVE_ARY_SIZE 3
431#define SU_SAVE_AELEM_SIZE 4
432#ifdef SAVEADELETE
433# define SU_SAVE_ADELETE_SIZE 3
434#else
435# define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE
436#endif
437#if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE
438# define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_ADELETE_SIZE
439#else
440# define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE
441#endif
442
443#define SU_SAVE_HASH_SIZE 3
444#define SU_SAVE_HELEM_SIZE 4
445#define SU_SAVE_HDELETE_SIZE 4
446#if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE
447# define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HDELETE_SIZE
448#else
449# define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
450#endif
451
452#define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE
453
454#if !SU_HAS_PERL(5, 8, 9)
455# define SU_SAVE_GP_SIZE 6
456#elif !SU_HAS_PERL(5, 13, 0) || (SU_RELEASE && SU_HAS_PERL_EXACT(5, 13, 0))
457# define SU_SAVE_GP_SIZE 3
458#elif !SU_HAS_PERL(5, 13, 8)
459# define SU_SAVE_GP_SIZE 4
460#else
461# define SU_SAVE_GP_SIZE 3
462#endif
463
464#ifndef SvCANEXISTDELETE
465# define SvCANEXISTDELETE(sv) \
466  (!SvRMAGICAL(sv) \
467   || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied)) \
468       && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \
469       && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) \
470       && gv_fetchmethod_autoload(stash, "DELETE", TRUE) \
471      ) \
472   )
473#endif
474
475/* ... Saving array elements ............................................... */
476
477
5129
STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) {
478#define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K))
479 I32 idx;
480
481
5129
 if (key >= 0)
482
5122
  return key;
483
484/* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */
485#if SU_HAS_PERL(5, 8, 1)
486
7
 if (SvRMAGICAL(av)) {
487
2
  const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied);
488
2
  if (tied_magic) {
489
2
   SV * const * const negative_indices_glob =
490
2
                    hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))),
491                             NEGATIVE_INDICES_VAR, 16, 0);
492
2
   if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
493
1
    return key;
494  }
495 }
496#endif
497
498
6
 idx = key + av_len(av) + 1;
499
6
 if (idx < 0)
500
2
  return key;
501
502
5129
 return idx;
503}
504
505#ifndef SAVEADELETE
506
507typedef struct {
508 AV *av;
509 I32 idx;
510} su_ud_adelete;
511
512STATIC void su_adelete(pTHX_ void *ud_) {
513 su_ud_adelete *ud = (su_ud_adelete *) ud_;
514
515 av_delete(ud->av, ud->idx, G_DISCARD);
516 SvREFCNT_dec(ud->av);
517
518 Safefree(ud);
519}
520
521STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) {
522#define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K))
523 su_ud_adelete *ud;
524
525 Newx(ud, 1, su_ud_adelete);
526 ud->av = av;
527 ud->idx = idx;
528 SvREFCNT_inc_simple_void(av);
529
530 SAVEDESTRUCTOR_X(su_adelete, ud);
531}
532
533#define SAVEADELETE(A, K) su_save_adelete((A), (K))
534
535#endif /* SAVEADELETE */
536
537
5129
STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) {
538#define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V))
539 I32 idx;
540
5129
 I32 preeminent = 1;
541 SV **svp;
542 HV *stash;
543 MAGIC *mg;
544
545
5129
 idx = su_av_key2idx(av, SvIV(key));
546
547
5129
 if (SvCANEXISTDELETE(av))
548
5125
  preeminent = av_exists(av, idx);
549
550
5129
 svp = av_fetch(av, idx, 1);
551
5129
 if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
552
553
5127
 if (preeminent)
554
5121
  save_aelem(av, idx, svp);
555 else
556
6
  SAVEADELETE(av, idx);
557
558
5127
 if (val) { /* local $x[$idx] = $val; */
559
4031
  SvSetMagicSV(*svp, val);
560 } else { /* local $x[$idx]; delete $x[$idx]; */
561
1096
  av_delete(av, idx, G_DISCARD);
562 }
563
5127
}
564
565/* ... Saving hash elements ................................................ */
566
567
3118
STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
568#define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V))
569
3118
 I32 preeminent = 1;
570 HE *he;
571 SV **svp;
572 HV *stash;
573 MAGIC *mg;
574
575
3118
 if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env))
576
3117
  preeminent = hv_exists_ent(hv, keysv, 0);
577
578
3118
 he = hv_fetch_ent(hv, keysv, 1, 0);
579
3118
 svp = he ? &HeVAL(he) : NULL;
580
3118
 if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
581
582
3118
 if (HvNAME_get(hv) && isGV(*svp)) {
583
0
  save_gp((GV *) *svp, 0);
584
0
  return;
585 }
586
587
3118
 if (preeminent)
588
2295
  save_helem(hv, keysv, svp);
589 else {
590  STRLEN keylen;
591
823
  const char * const key = SvPV_const(keysv, keylen);
592
823
  SAVEDELETE(hv, savepvn(key, keylen),
593                 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
594 }
595
596
3118
 if (val) { /* local $x{$keysv} = $val; */
597
3030
  SvSetMagicSV(*svp, val);
598 } else { /* local $x{$keysv}; delete $x{$keysv}; */
599
3118
  (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he));
600 }
601}
602
603/* ... Saving code slots from a glob ....................................... */
604
605#if !SU_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in)
606# define mro_method_changed_in(G) PL_sub_generation++
607#endif
608
609typedef struct {
610 GV *gv;
611 CV *old_cv;
612} su_save_gvcv_ud;
613
614
12
STATIC void su_restore_gvcv(pTHX_ void *ud_) {
615
12
 su_save_gvcv_ud *ud = ud_;
616
12
 GV *gv = ud->gv;
617
618
12
 GvCV_set(gv, ud->old_cv);
619
12
 GvCVGEN(gv) = 0;
620
12
 mro_method_changed_in(GvSTASH(gv));
621
622
12
 Safefree(ud);
623
12
}
624
625
12
STATIC void su_save_gvcv(pTHX_ GV *gv) {
626#define su_save_gvcv(G) su_save_gvcv(aTHX_ (G))
627 su_save_gvcv_ud *ud;
628
629
12
 Newx(ud, 1, su_save_gvcv_ud);
630
12
 ud->gv = gv;
631
12
 ud->old_cv = GvCV(gv);
632
633
12
 GvCV_set(gv, NULL);
634
12
 GvCVGEN(gv) = 0;
635
12
 mro_method_changed_in(GvSTASH(gv));
636
637
12
 SAVEDESTRUCTOR_X(su_restore_gvcv, ud);
638
12
}
639
640/* --- Actions ------------------------------------------------------------- */
641
642typedef struct {
643 I32 depth;
644 I32 pad;
645 I32 *origin;
646 void (*handler)(pTHX_ void *);
647} su_ud_common;
648
649#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth)
650#define SU_UD_PAD(U) (((su_ud_common *) (U))->pad)
651#define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin)
652#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
653
654#define SU_UD_FREE(U) STMT_START { \
655 if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
656 Safefree(U); \
657} STMT_END
658
659/* ... Reap ................................................................ */
660
661typedef struct {
662 su_ud_common ci;
663 SV *cb;
664} su_ud_reap;
665
666
4433
STATIC void su_call(pTHX_ void *ud_) {
667
4433
 su_ud_reap *ud = (su_ud_reap *) ud_;
668#if SU_HAS_PERL(5, 9, 5)
669 PERL_CONTEXT saved_cx;
670 I32 cxix;
671#endif
672
673
4433
 dSP;
674
675 SU_D({
676  PerlIO_printf(Perl_debug_log,
677                "%p: @@@ call\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
678                 ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
679 });
680
681
4433
 ENTER;
682
4433
 SAVETMPS;
683
684
4433
 PUSHMARK(SP);
685
4433
 PUTBACK;
686
687 /* If the recently popped context isn't saved there, it will be overwritten by
688  * the sub scope from call_sv, although it's still needed in our caller. */
689
690#if SU_HAS_PERL(5, 9, 5)
691
4433
 if (cxstack_ix < cxstack_max)
692
4433
  cxix = cxstack_ix + 1;
693 else
694
0
  cxix = Perl_cxinc(aTHX);
695
4433
 saved_cx = cxstack[cxix];
696#endif
697
698
4433
 call_sv(ud->cb, G_VOID);
699
700#if SU_HAS_PERL(5, 9, 5)
701
4431
 cxstack[cxix] = saved_cx;
702#endif
703
704
4431
 PUTBACK;
705
706
4431
 FREETMPS;
707
4431
 LEAVE;
708
709
4431
 SvREFCNT_dec(ud->cb);
710
4431
 SU_UD_FREE(ud);
711
4431
}
712
713
4433
STATIC void su_reap(pTHX_ void *ud) {
714#define su_reap(U) su_reap(aTHX_ (U))
715 SU_D({
716  PerlIO_printf(Perl_debug_log,
717                "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
718                 ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
719 });
720
721
4433
 SAVEDESTRUCTOR_X(su_call, ud);
722
4433
}
723
724/* ... Localize & localize array/hash element .............................. */
725
726typedef struct {
727 su_ud_common ci;
728 SV *sv;
729 SV *val;
730 SV *elem;
731 svtype type;
732} su_ud_localize;
733
734#define SU_UD_LOCALIZE_FREE(U) STMT_START { \
735 SvREFCNT_dec((U)->elem); \
736 SvREFCNT_dec((U)->val); \
737 SvREFCNT_dec((U)->sv); \
738 SU_UD_FREE(U); \
739} STMT_END
740
741
12341
STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
742#define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
743
12341
 UV deref = 0;
744
12341
 svtype t = SVt_NULL;
745 I32 size;
746
747
12341
 SvREFCNT_inc_simple_void(sv);
748
749
12341
 if (SvTYPE(sv) >= SVt_PVGV) {
750
1013
  if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
751
1002
   t = SVt_PVGV;
752  } else { /* local *x = \$val; */
753
11
   t = SvTYPE(SvRV(val));
754
1013
   deref = 1;
755  }
756
11328
 } else if (SvROK(sv)) {
757
12
  croak("Invalid %s reference as the localization target",
758
12
                 sv_reftype(SvRV(sv), 0));
759 } else {
760  STRLEN len, l;
761
11316
  const char *p = SvPV_const(sv, len), *s;
762
11317
  for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
763
11316
  if (!l) {
764
1
   l = len;
765
1
   s = p;
766  }
767
11316
  switch (*s) {
768
3054
   case '$': t = SVt_PV; break;
769
5129
   case '@': t = SVt_PVAV; break;
770
3118
   case '%': t = SVt_PVHV; break;
771
7
   case '&': t = SVt_PVCV; break;
772
1
   case '*': t = SVt_PVGV; break;
773  }
774
11316
  if (t != SVt_NULL) {
775
11309
   ++s;
776
11309
   --l;
777
7
  } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
778
7
   if (SvROK(val) && !sv_isobject(val)) {
779
4
    t = SvTYPE(SvRV(val));
780
4
    deref = 1;
781   } else {
782
3
    t = SvTYPE(val);
783   }
784  }
785
11316
  SvREFCNT_dec(sv);
786
11316
  sv = newSVpvn(s, l);
787 }
788
789
12329
 switch (t) {
790  case SVt_PVAV:
791
5131
   size = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
792
5131
                : SU_SAVE_ARY_SIZE;
793
5131
   deref = 0;
794
5131
   break;
795  case SVt_PVHV:
796
3120
   size = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
797
3120
                : SU_SAVE_HASH_SIZE;
798
3120
   deref = 0;
799
3120
   break;
800  case SVt_PVGV:
801
1003
   size = SU_SAVE_GP_SIZE;
802
1003
   deref = 0;
803
1003
   break;
804  case SVt_PVCV:
805
13
   size = SU_SAVE_GVCV_SIZE;
806
13
   deref = 0;
807
13
   break;
808  default:
809
3062
   size = SU_SAVE_SCALAR_SIZE;
810
3062
   break;
811 }
812 /* When deref is set, val isn't NULL */
813
814
12329
 ud->sv = sv;
815
12329
 ud->val = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
816
12329
 ud->elem = SvREFCNT_inc(elem);
817
12329
 ud->type = t;
818
819
12329
 return size;
820}
821
822
12326
STATIC void su_localize(pTHX_ void *ud_) {
823#define su_localize(U) su_localize(aTHX_ (U))
824
12326
 su_ud_localize *ud = (su_ud_localize *) ud_;
825
12326
 SV *sv = ud->sv;
826
12326
 SV *val = ud->val;
827
12326
 SV *elem = ud->elem;
828
12326
 svtype t = ud->type;
829 GV *gv;
830
831
12326
 if (SvTYPE(sv) >= SVt_PVGV) {
832
1013
  gv = (GV *) sv;
833 } else {
834#ifdef gv_fetchsv
835
11313
  gv = gv_fetchsv(sv, GV_ADDMULTI, t);
836#else
837  STRLEN len;
838  const char *name = SvPV_const(sv, len);
839  gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
840#endif
841 }
842
843 SU_D({
844  SV *z = newSV(0);
845  SvUPGRADE(z, t);
846  PerlIO_printf(Perl_debug_log, "%p: === localize a %s\n",ud, sv_reftype(z, 0));
847  PerlIO_printf(Perl_debug_log,
848                "%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
849                 ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
850  SvREFCNT_dec(z);
851 });
852
853 /* Inspired from Alias.pm */
854
12326
 switch (t) {
855  case SVt_PVAV:
856
5131
   if (elem) {
857
5129
    su_save_aelem(GvAV(gv), elem, val);
858
5127
    goto done;
859   } else
860
2
    save_ary(gv);
861
2
   break;
862  case SVt_PVHV:
863
3120
   if (elem) {
864
3118
    su_save_helem(GvHV(gv), elem, val);
865
3118
    goto done;
866   } else
867
2
    save_hash(gv);
868
2
   break;
869  case SVt_PVGV:
870
1002
   save_gp(gv, 1); /* hide previous entry in symtab */
871
1002
   break;
872  case SVt_PVCV:
873
12
   su_save_gvcv(gv);
874
12
   break;
875  default:
876
3061
   gv = (GV *) save_scalar(gv);
877
3061
   break;
878 }
879
880
4079
 if (val)
881
4071
  SvSetMagicSV((SV *) gv, val);
882
883done:
884
12324
 SU_UD_LOCALIZE_FREE(ud);
885
12324
}
886
887/* --- Pop a context back -------------------------------------------------- */
888
889#if SU_DEBUG
890# ifdef DEBUGGING
891# define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
892# else
893# define SU_CXNAME "XXX"
894# endif
895#endif
896
897
48144
STATIC void su_pop(pTHX_ void *ud) {
898#define su_pop(U) su_pop(aTHX_ (U))
899 I32 depth, base, mark, *origin;
900
48144
 depth = SU_UD_DEPTH(ud);
901
902 SU_D(
903  PerlIO_printf(Perl_debug_log,
904   "%p: --- pop a %s\n"
905   "%p: leave scope at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n",
906    ud, SU_CXNAME,
907    ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix])
908 );
909
910
48144
 origin = SU_UD_ORIGIN(ud);
911
48144
 mark = origin[depth];
912
48144
 base = origin[depth - 1];
913
914 SU_D(PerlIO_printf(Perl_debug_log,
915                    "%p: original scope was %*c top=%2d base=%2d\n",
916                     ud, 24, ' ', mark, base));
917
918
48144
 if (base < mark) {
919  SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
920
42139
  PL_savestack_ix = mark;
921
42139
  leave_scope(base);
922 }
923
48144
 PL_savestack_ix = base;
924
925
48144
 SU_UD_DEPTH(ud) = --depth;
926
927
48144
 if (depth > 0) {
928  I32 pad;
929
930
30562
  if ((pad = SU_UD_PAD(ud))) {
931   dMY_CXT;
932   do {
933    SU_D(PerlIO_printf(Perl_debug_log,
934          "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n",
935           ud, depth, PL_scopestack_ix, PL_savestack_ix));
936
14626
    SU_SAVE_PLACEHOLDER();
937
14626
   } while (--pad);
938  }
939
940  SU_D(PerlIO_printf(Perl_debug_log,
941          "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
942           ud, depth, PL_scopestack_ix, PL_savestack_ix));
943
30562
  SAVEDESTRUCTOR_X(su_pop, ud);
944 } else {
945
17582
  SU_UD_HANDLER(ud)(aTHX_ ud);
946 }
947
948 SU_D(PerlIO_printf(Perl_debug_log,
949                    "%p: --- end pop: cur_top=%2d == cur_base=%2d\n",
950                     ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
951
48142
}
952
953/* --- Initialize the stack and the action userdata ------------------------ */
954
955
17582
STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
956#define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
957
17582
 I32 i, depth = 1, pad, offset, *origin;
958
959 SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
960
961
17582
 if (size <= SU_SAVE_DESTRUCTOR_SIZE)
962
9335
  pad = 0;
963 else {
964
8247
  I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
965
8247
  pad = extra / SU_SAVE_PLACEHOLDER_SIZE;
966
8247
  if (extra % SU_SAVE_PLACEHOLDER_SIZE)
967
8247
   ++pad;
968 }
969
17582
 offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_PLACEHOLDER_SIZE * pad;
970
971 SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
972                                     ud, size, pad, offset));
973
974
40159
 for (i = cxstack_ix; i > cxix; --i) {
975
22577
  PERL_CONTEXT *cx = cxstack + i;
976
22577
  switch (CxTYPE(cx)) {
977#if SU_HAS_PERL(5, 10, 0)
978   case CXt_BLOCK:
979    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i));
980    /* Given and when blocks are actually followed by a simple block, so skip
981     * it if needed. */
982
3441
    if (cxix > 0) { /* Implies i > 0 */
983
3441
     PERL_CONTEXT *next = cx - 1;
984
3441
     if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN)
985
1585
      --cxix;
986    }
987
3441
    depth++;
988
3441
    break;
989#endif
990#if SU_HAS_PERL(5, 11, 0)
991   case CXt_LOOP_FOR:
992   case CXt_LOOP_PLAIN:
993   case CXt_LOOP_LAZYSV:
994   case CXt_LOOP_LAZYIV:
995#else
996   case CXt_LOOP:
997#endif
998    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
999
7985
    depth += 2;
1000
7985
    break;
1001   default:
1002    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
1003
11151
    depth++;
1004
11151
    break;
1005  }
1006 }
1007 SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
1008
1009
17582
 Newx(origin, depth + 1, I32);
1010
17582
 origin[0] = PL_scopestack[PL_scopestack_ix - depth];
1011
17582
 PL_scopestack[PL_scopestack_ix - depth] += size;
1012
48144
 for (i = depth - 1; i >= 1; --i) {
1013
30562
  I32 j = PL_scopestack_ix - i;
1014
30562
  origin[depth - i] = PL_scopestack[j];
1015
30562
  PL_scopestack[j] += offset;
1016 }
1017
17582
 origin[depth] = PL_savestack_ix;
1018
1019
17582
 SU_UD_ORIGIN(ud) = origin;
1020
17582
 SU_UD_DEPTH(ud) = depth;
1021
17582
 SU_UD_PAD(ud) = pad;
1022
1023 /* Make sure the first destructor fires by pushing enough fake slots on the
1024  * stack. */
1025
17582
 if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
1026
17582
                                       <= PL_scopestack[PL_scopestack_ix - 1]) {
1027  dMY_CXT;
1028  do {
1029   SU_D(PerlIO_printf(Perl_debug_log,
1030                  "%p: push a fake slot at scope_ix=%2d save_ix=%2d\n",
1031                   ud, PL_scopestack_ix, PL_savestack_ix));
1032
7785
   SU_SAVE_PLACEHOLDER();
1033
7785
  } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
1034
7785
                                        <= PL_scopestack[PL_scopestack_ix - 1]);
1035 }
1036 SU_D(PerlIO_printf(Perl_debug_log,
1037                  "%p: push first destructor at scope_ix=%2d save_ix=%2d\n",
1038                   ud, PL_scopestack_ix, PL_savestack_ix));
1039
17582
 SAVEDESTRUCTOR_X(su_pop, ud);
1040
1041 SU_D({
1042  for (i = 0; i <= depth; ++i) {
1043   I32 j = PL_scopestack_ix - i;
1044   PerlIO_printf(Perl_debug_log,
1045                 "%p: depth=%2d scope_ix=%2d saved_floor=%2d new_floor=%2d\n",
1046                  ud, i, j, origin[depth - i],
1047                                   i == 0 ? PL_savestack_ix : PL_scopestack[j]);
1048  }
1049 });
1050
1051
17582
 return depth;
1052}
1053
1054/* --- Unwind stack -------------------------------------------------------- */
1055
1056
11278
STATIC void su_unwind(pTHX_ void *ud_) {
1057 dMY_CXT;
1058
11278
 I32 cxix = MY_CXT.unwind_storage.cxix;
1059
11278
 I32 items = MY_CXT.unwind_storage.items - 1;
1060
11278
 SV **savesp = MY_CXT.unwind_storage.savesp;
1061 I32 mark;
1062
1063 PERL_UNUSED_VAR(ud_);
1064
1065
11278
 if (savesp)
1066
3756
  PL_stack_sp = savesp;
1067
1068
11278
 if (cxstack_ix > cxix)
1069
5639
  dounwind(cxix);
1070
1071 /* Hide the level */
1072
11278
 if (items >= 0)
1073
11277
  PL_stack_sp--;
1074
1075
11278
 mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
1076
11278
 *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
1077
1078 SU_D({
1079  I32 gimme = GIMME_V;
1080  PerlIO_printf(Perl_debug_log,
1081                "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
1082                &MY_CXT, cxix,
1083                gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
1084                items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
1085 });
1086
1087
11278
 PL_op = (OP *) &(MY_CXT.unwind_storage.return_op);
1088
11278
 PL_op = PL_op->op_ppaddr(aTHX);
1089
1090
11278
 *PL_markstack_ptr = mark;
1091
1092
11278
 MY_CXT.unwind_storage.proxy_op.op_next = PL_op;
1093
11278
 PL_op = &(MY_CXT.unwind_storage.proxy_op);
1094
11278
}
1095
1096/* --- Uplevel ------------------------------------------------------------- */
1097
1098#ifndef OP_GIMME_REVERSE
1099STATIC U8 su_op_gimme_reverse(U8 gimme) {
1100 switch (gimme) {
1101  case G_VOID:
1102   return OPf_WANT_VOID;
1103  case G_ARRAY:
1104   return OPf_WANT_LIST;
1105  default:
1106   break;
1107 }
1108
1109 return OPf_WANT_SCALAR;
1110}
1111#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
1112#endif
1113
1114#define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
1115#define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
1116
1117
2749
STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) {
1118#define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I))
1119 su_uplevel_ud *sud;
1120 UV depth;
1121 dMY_CXT;
1122
1123
2749
 sud = MY_CXT.uplevel_storage.root;
1124
2749
 if (sud) {
1125
2507
  MY_CXT.uplevel_storage.root = sud->next;
1126
2507
  MY_CXT.uplevel_storage.count--;
1127 } else {
1128
242
  sud = su_uplevel_ud_new();
1129 }
1130
1131
2749
 sud->next = MY_CXT.uplevel_storage.top;
1132
2749
 MY_CXT.uplevel_storage.top = sud;
1133
1134
2749
 depth = su_uid_depth(cxix);
1135
2749
 su_uid_storage_dup(&sud->new_uid_storage, &MY_CXT.uid_storage, depth);
1136
2749
 sud->old_uid_storage = MY_CXT.uid_storage;
1137
2749
 MY_CXT.uid_storage = sud->new_uid_storage;
1138
1139
2749
 return sud;
1140}
1141
1142
2749
STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
1143#define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
1144 dMY_CXT;
1145
1146
2749
 sud->new_uid_storage = MY_CXT.uid_storage;
1147
2749
 MY_CXT.uid_storage = sud->old_uid_storage;
1148 {
1149  su_uid **map;
1150  UV i, alloc;
1151
2749
  map = sud->new_uid_storage.map;
1152
2749
  alloc = sud->new_uid_storage.alloc;
1153
8515
  for (i = 0; i < alloc; ++i) {
1154
5766
   if (map[i])
1155
2997
    map[i]->flags &= SU_UID_ACTIVE;
1156  }
1157 }
1158
2749
 MY_CXT.uplevel_storage.top = sud->next;
1159
1160
2749
 if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
1161
224
  su_uplevel_ud_delete(sud);
1162 } else {
1163
2525
  sud->next = MY_CXT.uplevel_storage.root;
1164
2525
  MY_CXT.uplevel_storage.root = sud;
1165
2525
  MY_CXT.uplevel_storage.count++;
1166 }
1167
2749
}
1168
1169
53888
STATIC int su_uplevel_goto_static(const OP *o) {
1170
157762
 for (; o; o = o->op_sibling) {
1171  /* goto ops are unops with kids. */
1172
104187
  if (!(o->op_flags & OPf_KIDS))
1173
52939
   continue;
1174
1175
51248
  switch (o->op_type) {
1176   case OP_LEAVEEVAL:
1177   case OP_LEAVETRY:
1178    /* Don't care about gotos inside eval, as they are forbidden at run time. */
1179
0
    break;
1180   case OP_GOTO:
1181
104
    return 1;
1182   default:
1183
51144
    if (su_uplevel_goto_static(cUNOPo->op_first))
1184
209
     return 1;
1185
50935
    break;
1186  }
1187 }
1188
1189
53888
 return 0;
1190}
1191
1192#if SU_UPLEVEL_HIJACKS_RUNOPS
1193
1194
1206
STATIC int su_uplevel_goto_runops(pTHX) {
1195#define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
1196 register OP *op;
1197 dVAR;
1198
1199
1206
 op = PL_op;
1200 do {
1201
181535
  if (op->op_type == OP_GOTO) {
1202
124
   AV *argarray = NULL;
1203   I32 cxix;
1204
1205
124
   for (cxix = cxstack_ix; cxix >= 0; --cxix) {
1206
124
    const PERL_CONTEXT *cx = cxstack + cxix;
1207
1208
124
    switch (CxTYPE(cx)) {
1209     case CXt_SUB:
1210
124
      if (CxHASARGS(cx)) {
1211
124
       argarray = cx->blk_sub.argarray;
1212
124
       goto done;
1213      }
1214
0
      break;
1215     case CXt_EVAL:
1216     case CXt_FORMAT:
1217
0
      goto done;
1218     default:
1219
0
      break;
1220    }
1221   }
1222
1223done:
1224
124
   if (argarray) {
1225    dMY_CXT;
1226
1227
124
    if (MY_CXT.uplevel_storage.top->cxix == cxix) {
1228
124
     AV *args = GvAV(PL_defgv);
1229
124
     I32 items = AvFILLp(args);
1230
1231
124
     av_extend(argarray, items);
1232
124
     Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
1233
124
     AvFILLp(argarray) = items;
1234    }
1235   }
1236  }
1237
1238
181535
  PL_op = op = op->op_ppaddr(aTHX);
1239
1240#if !SU_HAS_PERL(5, 13, 0)
1241  PERL_ASYNC_CHECK();
1242#endif
1243
181375
 } while (op);
1244
1245
1046
 TAINT_NOT;
1246
1247
1046
 return 0;
1248}
1249
1250#endif /* SU_UPLEVEL_HIJACKS_RUNOPS */
1251
1252#define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
1253
1254
2749
STATIC void su_uplevel_restore(pTHX_ void *sus_) {
1255
2749
 su_uplevel_ud *sud = sus_;
1256
2749
 PERL_SI *cur = sud->old_curstackinfo;
1257
2749
 PERL_SI *si = sud->si;
1258
1259#if SU_UPLEVEL_HIJACKS_RUNOPS
1260
2749
 if (PL_runops == su_uplevel_goto_runops)
1261
125
  PL_runops = sud->old_runops;
1262#endif
1263
1264
2749
 if (sud->callback) {
1265
2744
  PERL_CONTEXT *cx = cxstack + sud->cxix;
1266
2744
  AV *argarray = MUTABLE_AV(su_at_underscore(sud->callback));
1267
1268  /* We have to fix the pad entry for @_ in the original callback because it
1269   * may have been reified. */
1270
2744
  if (AvREAL(argarray)) {
1271
20
   const I32 fill = AvFILLp(argarray);
1272
20
   SvREFCNT_dec(argarray);
1273
20
   argarray = newAV();
1274
20
   AvREAL_off(argarray);
1275
20
   AvREIFY_on(argarray);
1276
20
   av_extend(argarray, fill);
1277
20
   su_at_underscore(sud->callback) = MUTABLE_SV(argarray);
1278  } else {
1279
2724
   CLEAR_ARGARRAY(argarray);
1280  }
1281
1282  /* If the old cv member is our renamed CV, it means that this place has been
1283   * reached without a goto() happening, and the old argarray member is
1284   * actually our fake argarray. Destroy it properly in that case. */
1285
2744
  if (cx->blk_sub.cv == sud->renamed) {
1286
2641
   SvREFCNT_dec(cx->blk_sub.argarray);
1287
2641
   cx->blk_sub.argarray = argarray;
1288  }
1289
1290
2744
  CvDEPTH(sud->callback)--;
1291
2744
  SvREFCNT_dec(sud->callback);
1292 }
1293
1294 /* Free the renamed CV. We must do it ourselves so that we can force the
1295  * depth to be 0, or perl would complain about it being "still in use".
1296  * But we *know* that it cannot be so. */
1297
2749
 if (sud->renamed) {
1298
2749
  CvDEPTH(sud->renamed) = 0;
1299
2749
  CvPADLIST(sud->renamed) = NULL;
1300
2749
  SvREFCNT_dec(sud->renamed);
1301 }
1302
1303
2749
 CATCH_SET(sud->old_catch);
1304
1305
2749
 SU_UPLEVEL_RESTORE(op);
1306
1307 /* stack_grow() wants PL_curstack so restore the old stack first */
1308
2749
 if (PL_curstackinfo == si) {
1309
2749
  PL_curstack = cur->si_stack;
1310
2749
  if (sud->old_mainstack)
1311
2749
   SU_UPLEVEL_RESTORE(mainstack);
1312
2749
  SU_UPLEVEL_RESTORE(curstackinfo);
1313
1314
2749
  if (sud->died) {
1315
1013
   CV *target = sud->target;
1316
1013
   I32 levels = 0, i;
1317
1318   /* When we die, the depth of the target CV is not updated because of the
1319    * stack switcheroo. So we have to look at all the frames between the
1320    * uplevel call and the catch block to count how many call frames to the
1321    * target CV were skipped. */
1322
21465
   for (i = cur->si_cxix; i > sud->cxix; i--) {
1323
20452
    register const PERL_CONTEXT *cx = cxstack + i;
1324
1325
20452
    if (CxTYPE(cx) == CXt_SUB) {
1326
4868
     if (cx->blk_sub.cv == target)
1327
4867
      ++levels;
1328    }
1329   }
1330
1331   /* If we died, the replacement stack was already unwinded to the first
1332    * eval frame, and all the contexts down there were popped. We don't have
1333    * to pop manually any context of the original stack, because they must
1334    * have been in the replacement stack as well (since the second was copied
1335    * from the first). Thus we only have to make sure the original stack index
1336    * points to the context just below the first eval scope under the target
1337    * frame. */
1338
2026
   for (; i >= 0; i--) {
1339
2026
    register const PERL_CONTEXT *cx = cxstack + i;
1340
1341
2026
    switch (CxTYPE(cx)) {
1342     case CXt_SUB:
1343
1013
      if (cx->blk_sub.cv == target)
1344
1013
       ++levels;
1345
1013
      break;
1346     case CXt_EVAL:
1347
1013
      goto found_it;
1348      break;
1349     default:
1350
0
      break;
1351    }
1352   }
1353
1354found_it:
1355
1013
   CvDEPTH(target) = sud->target_depth - levels;
1356
1013
   PL_curstackinfo->si_cxix = i - 1;
1357
1358#if !SU_HAS_PERL(5, 13, 1)
1359   /* Since $@ was maybe localized between the target frame and the uplevel
1360    * call, we forcefully flush the save stack to get rid of it and then
1361    * reset $@ to its proper value. Note that the the call to
1362    * su_uplevel_restore() must happen before the "reset $@" item of the save
1363    * stack is processed, as uplevel was called after the localization.
1364    * Andrew's changes to how $@ was handled, which were mainly integrated
1365    * between perl 5.13.0 and 5.13.1, fixed this. */
1366   if (ERRSV && SvTRUE(ERRSV)) {
1367    register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
1368    SV *errsv = SvREFCNT_inc(ERRSV);
1369    PL_scopestack_ix = cx->blk_oldscopesp;
1370    leave_scope(PL_scopestack[PL_scopestack_ix]);
1371    sv_setsv(ERRSV, errsv);
1372    SvREFCNT_dec(errsv);
1373   }
1374#endif
1375  }
1376 }
1377
1378
2749
 SU_UPLEVEL_RESTORE(curcop);
1379
1380
2749
 SvREFCNT_dec(sud->target);
1381
1382
2749
 PL_stack_base = AvARRAY(cur->si_stack);
1383
2749
 PL_stack_sp = PL_stack_base + AvFILLp(cur->si_stack);
1384
2749
 PL_stack_max = PL_stack_base + AvMAX(cur->si_stack);
1385
1386 /* When an exception is thrown from the uplevel'd subroutine,
1387  * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed
1388  * die_where() in more recent perls), which has the sad habit of keeping a
1389  * pointer to the current context frame across this call. This means that we
1390  * can't free the temporary context stack we used for the uplevel call right
1391  * now, or that pointer upwards would point to garbage. */
1392#if SU_HAS_PERL(5, 13, 7)
1393 /* This issue has been fixed in perl with commit 8f89e5a9, which was made
1394  * public in perl 5.13.7. */
1395
2749
 su_uplevel_storage_delete(sud);
1396#else
1397 /* Otherwise, we just enqueue it back in the global storage list. */
1398 {
1399  dMY_CXT;
1400
1401  sud->new_uid_storage = MY_CXT.uid_storage;
1402  MY_CXT.uid_storage = sud->old_uid_storage;
1403
1404  MY_CXT.uplevel_storage.top = sud->next;
1405  sud->next = MY_CXT.uplevel_storage.root;
1406  MY_CXT.uplevel_storage.root = sud;
1407  MY_CXT.uplevel_storage.count++;
1408 }
1409#endif
1410
1411 return;
1412}
1413
1414
2749
STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
1415#define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
1416 dVAR;
1417 CV *cv;
1418
1419
2749
 cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1420
1421
2749
 CvFLAGS(cv) = CvFLAGS(proto);
1422#ifdef CVf_CVGV_RC
1423
2749
 CvFLAGS(cv) &= ~CVf_CVGV_RC;
1424#endif
1425
2749
 CvDEPTH(cv) = CvDEPTH(proto);
1426#ifdef USE_ITHREADS
1427 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto));
1428#else
1429
2749
 CvFILE(cv) = CvFILE(proto);
1430#endif
1431
1432
2749
 CvGV_set(cv, gv);
1433
2749
 CvSTASH_set(cv, CvSTASH(proto));
1434 /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
1435  * stashes. CvSTASH_set() started to do it as well with commit c68d95645
1436  * (which was part of perl 5.13.7). */
1437#if SU_HAS_PERL(5, 13, 3) && !SU_HAS_PERL(5, 13, 7)
1438 if (CvSTASH(proto))
1439  Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
1440#endif
1441
1442
2749
 if (CvISXSUB(proto)) {
1443
5
  CvXSUB(cv) = CvXSUB(proto);
1444
5
  CvXSUBANY(cv) = CvXSUBANY(proto);
1445 } else {
1446  OP_REFCNT_LOCK;
1447
2744
  CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1448  OP_REFCNT_UNLOCK;
1449
2744
  CvSTART(cv) = CvSTART(proto);
1450 }
1451
2749
 CvOUTSIDE(cv) = CvOUTSIDE(proto);
1452#ifdef CVf_WEAKOUTSIDE
1453
2749
 if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
1454#endif
1455
2749
  SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
1456
2749
 CvPADLIST(cv) = CvPADLIST(proto);
1457#ifdef CvOUTSIDE_SEQ
1458
2749
 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1459#endif
1460
1461
2749
 if (SvPOK(proto))
1462
5
  sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1463
1464#ifdef CvCONST
1465
2749
 if (CvCONST(cv))
1466
0
  CvCONST_off(cv);
1467#endif
1468
1469
2749
 return cv;
1470}
1471
1472
2749
STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
1473#define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
1474 su_uplevel_ud *sud;
1475
2749
 const PERL_CONTEXT *cx = cxstack + cxix;
1476 PERL_SI *si;
1477
2749
 PERL_SI *cur = PL_curstackinfo;
1478 SV **old_stack_sp;
1479 CV *target;
1480 CV *renamed;
1481 UNOP sub_op;
1482 I32 gimme;
1483 I32 old_mark, new_mark;
1484 I32 ret;
1485
2749
 dSP;
1486
1487
2749
 ENTER;
1488
1489
2749
 gimme = GIMME_V;
1490 /* Make PL_stack_sp point just before the CV. */
1491
2749
 PL_stack_sp -= args + 1;
1492
2749
 old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
1493
2749
 SPAGAIN;
1494
1495
2749
 sud = su_uplevel_storage_new(cxix);
1496
1497
2749
 sud->cxix = cxix;
1498
2749
 sud->died = 1;
1499
2749
 sud->callback = NULL;
1500
2749
 sud->renamed = NULL;
1501
2749
 SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
1502
1503
2749
 si = sud->si;
1504
1505
2749
 si->si_type = cur->si_type;
1506
2749
 si->si_next = NULL;
1507
2749
 si->si_prev = cur->si_prev;
1508#ifdef DEBUGGING
1509 si->si_markoff = cx->blk_oldmarksp;
1510#endif
1511
1512 /* Allocate enough space for all the elements of the original stack up to the
1513  * target context, plus the forthcoming arguments. */
1514
2749
 new_mark = cx->blk_oldsp;
1515
2749
 av_extend(si->si_stack, new_mark + 1 + args + 1);
1516
2749
 Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
1517
2749
 AvFILLp(si->si_stack) = new_mark;
1518 SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
1519
1520 /* Specialized SWITCHSTACK() */
1521
2749
 PL_stack_base = AvARRAY(si->si_stack);
1522
2749
 old_stack_sp = PL_stack_sp;
1523
2749
 PL_stack_sp = PL_stack_base + AvFILLp(si->si_stack);
1524
2749
 PL_stack_max = PL_stack_base + AvMAX(si->si_stack);
1525
2749
 SPAGAIN;
1526
1527 /* Copy the context stack up to the context just below the target. */
1528
2749
 si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
1529
2749
 if (si->si_cxmax < cxix) {
1530  /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
1531
245
  si->si_cxmax = (cxix < 4) ? 4 : cxix;
1532
245
  Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
1533 }
1534
2749
 Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
1535 SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
1536
1537
2749
 target = cx->blk_sub.cv;
1538
2749
 sud->target = (CV *) SvREFCNT_inc(target);
1539
2749
 sud->target_depth = CvDEPTH(target);
1540
1541 /* blk_oldcop is essentially needed for caller() and stack traces. It has no
1542  * run-time implication, since PL_curcop will be overwritten as soon as we
1543  * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
1544  * make it point to the blk_oldcop for the target frame, so that caller()
1545  * reports the right file name, line number and lexical hints. */
1546
2749
 SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
1547 /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
1548  * this point. Don't reset PL_curpm either, we want the most recent matches. */
1549
1550
2749
 SU_UPLEVEL_SAVE(curstackinfo, si);
1551 /* If those two are equal, we need to fool POPSTACK_TO() */
1552
2749
 if (PL_mainstack == PL_curstack)
1553
2749
  SU_UPLEVEL_SAVE(mainstack, si->si_stack);
1554 else
1555
0
  sud->old_mainstack = NULL;
1556
2749
 PL_curstack = si->si_stack;
1557
1558
2749
 renamed = su_cv_clone(callback, CvGV(target));
1559
2749
 sud->renamed = renamed;
1560
1561
2749
 PUSHMARK(SP);
1562 /* Both SP and old_stack_sp point just before the CV. */
1563
2749
 Copy(old_stack_sp + 2, SP + 1, args, SV *);
1564
2749
 SP += args;
1565
2749
 PUSHs((SV *) renamed);
1566
2749
 PUTBACK;
1567
1568
2749
 Zero(&sub_op, 1, UNOP);
1569
2749
 sub_op.op_type = OP_ENTERSUB;
1570
2749
 sub_op.op_next = NULL;
1571
2749
 sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
1572
2749
 if (PL_DBsub)
1573
2749
  sub_op.op_flags |= OPpENTERSUB_DB;
1574
1575
2749
 SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
1576
1577#if SU_UPLEVEL_HIJACKS_RUNOPS
1578
2749
 sud->old_runops = PL_runops;
1579#endif
1580
1581
2749
 sud->old_catch = CATCH_GET;
1582
2749
 CATCH_SET(TRUE);
1583
1584
2749
 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
1585
2744
  PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
1586
1587  /* If pp_entersub() returns a non-null OP, it means that the callback is not
1588   * an XSUB. */
1589
1590
2744
  sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
1591
2744
  CvDEPTH(callback)++;
1592
1593
5488
  if (CxHASARGS(cx) && cx->blk_sub.argarray) {
1594   /* The call to pp_entersub() has saved the current @_ (in XS terms,
1595    * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
1596    * with what we put on the stack. But we want to fake up the same arguments
1597    * as the ones in use at the context we uplevel to, so we replace the
1598    * argarray with an unreal copy of the original @_. */
1599
2744
   AV *av = newAV();
1600
2744
   AvREAL_off(av);
1601
2744
   AvREIFY_on(av);
1602
2744
   av_extend(av, AvMAX(cx->blk_sub.argarray));
1603
2744
   AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
1604
2744
   Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
1605
2744
   sub_cx->blk_sub.argarray = av;
1606  } else {
1607
0
   SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
1608  }
1609
1610
2744
  if (su_uplevel_goto_static(CvROOT(renamed))) {
1611#if SU_UPLEVEL_HIJACKS_RUNOPS
1612
104
   if (PL_runops != PL_runops_std) {
1613
20
    if (PL_runops == PL_runops_dbg) {
1614
0
     if (PL_debug)
1615
0
      croak("uplevel() can't execute code that calls goto when debugging flags are set");
1616
20
    } else if (PL_runops != su_uplevel_goto_runops)
1617
0
     croak("uplevel() can't execute code that calls goto with a custom runloop");
1618   }
1619
1620
104
   PL_runops = su_uplevel_goto_runops;
1621#else /* SU_UPLEVEL_HIJACKS_RUNOPS */
1622   croak("uplevel() can't execute code that calls goto before perl 5.8");
1623#endif /* !SU_UPLEVEL_HIJACKS_RUNOPS */
1624  }
1625
1626
2744
  CALLRUNOPS(aTHX);
1627 }
1628
1629
1736
 sud->died = 0;
1630
1631
1736
 ret = PL_stack_sp - (PL_stack_base + new_mark);
1632
1736
 if (ret > 0) {
1633
1207
  AV *old_stack = sud->old_curstackinfo->si_stack;
1634
1635
1207
  if (old_mark + ret > AvMAX(old_stack)) {
1636   /* Specialized EXTEND(old_sp, ret) */
1637
0
   av_extend(old_stack, old_mark + ret + 1);
1638
0
   old_stack_sp = AvARRAY(old_stack) + old_mark;
1639  }
1640
1641
1207
  Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
1642
1207
  PL_stack_sp += ret;
1643
1207
  AvFILLp(old_stack) += ret;
1644 }
1645
1646
1736
 LEAVE;
1647
1648
1736
 return ret;
1649}
1650
1651/* --- Unique context ID --------------------------------------------------- */
1652
1653
839
STATIC su_uid *su_uid_storage_fetch(pTHX_ UV depth) {
1654#define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D))
1655 su_uid **map, *uid;
1656 STRLEN alloc;
1657 dMY_CXT;
1658
1659
839
 map = MY_CXT.uid_storage.map;
1660
839
 alloc = MY_CXT.uid_storage.alloc;
1661
1662
839
 if (depth >= alloc) {
1663  STRLEN i;
1664
1665
228
  Renew(map, depth + 1, su_uid *);
1666
485
  for (i = alloc; i <= depth; ++i)
1667
257
   map[i] = NULL;
1668
1669
228
  MY_CXT.uid_storage.map = map;
1670
228
  MY_CXT.uid_storage.alloc = depth + 1;
1671 }
1672
1673
839
 uid = map[depth];
1674
1675
839
 if (!uid) {
1676
231
  Newx(uid, 1, su_uid);
1677
231
  uid->seq = 0;
1678
231
  uid->flags = 0;
1679
231
  map[depth] = uid;
1680 }
1681
1682
839
 if (depth >= MY_CXT.uid_storage.used)
1683
417
  MY_CXT.uid_storage.used = depth + 1;
1684
1685
839
 return uid;
1686}
1687
1688
858
STATIC int su_uid_storage_check(pTHX_ UV depth, UV seq) {
1689#define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S))
1690 su_uid *uid;
1691 dMY_CXT;
1692
1693
858
 if (depth >= MY_CXT.uid_storage.used)
1694
448
  return 0;
1695
1696
410
 uid = MY_CXT.uid_storage.map[depth];
1697
1698
858
 return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE);
1699}
1700
1701
823
STATIC void su_uid_drop(pTHX_ void *ud_) {
1702
823
 su_uid *uid = ud_;
1703
1704
823
 uid->flags &= ~SU_UID_ACTIVE;
1705
823
}
1706
1707
823
STATIC void su_uid_bump(pTHX_ void *ud_) {
1708
823
 su_ud_reap *ud = ud_;
1709
1710
823
 SAVEDESTRUCTOR_X(su_uid_drop, ud->cb);
1711
823
}
1712
1713
839
STATIC SV *su_uid_get(pTHX_ I32 cxix) {
1714#define su_uid_get(I) su_uid_get(aTHX_ (I))
1715 su_uid *uid;
1716 SV *uid_sv;
1717 UV depth;
1718
1719
839
 depth = su_uid_depth(cxix);
1720
839
 uid = su_uid_storage_fetch(depth);
1721
1722
839
 if (!(uid->flags & SU_UID_ACTIVE)) {
1723  su_ud_reap *ud;
1724
1725
823
  uid->seq = su_uid_seq_next(depth);
1726
823
  uid->flags |= SU_UID_ACTIVE;
1727
1728
823
  Newx(ud, 1, su_ud_reap);
1729
823
  SU_UD_ORIGIN(ud) = NULL;
1730
823
  SU_UD_HANDLER(ud) = su_uid_bump;
1731
823
  ud->cb = (SV *) uid;
1732
823
  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
1733 }
1734
1735
839
 uid_sv = sv_newmortal();
1736
839
 sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq);
1737
839
 return uid_sv;
1738}
1739
1740#ifdef grok_number
1741
1742#define su_grok_number(S, L, VP) grok_number((S), (L), (VP))
1743
1744#else /* grok_number */
1745
1746#define IS_NUMBER_IN_UV 0x1
1747
1748STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) {
1749#define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP))
1750 STRLEN i;
1751 SV *tmpsv;
1752
1753 /* This crude check should be good enough for a fallback implementation.
1754  * Better be too strict than too lax. */
1755 for (i = 0; i < len; ++i) {
1756  if (!isDIGIT(s[i]))
1757   return 0;
1758 }
1759
1760 tmpsv = sv_newmortal();
1761 sv_setpvn(tmpsv, s, len);
1762 *valuep = sv_2uv(tmpsv);
1763
1764 return IS_NUMBER_IN_UV;
1765}
1766
1767#endif /* !grok_number */
1768
1769
863
STATIC int su_uid_validate(pTHX_ SV *uid) {
1770#define su_uid_validate(U) su_uid_validate(aTHX_ (U))
1771 const char *s;
1772
863
 STRLEN len, p = 0;
1773 UV depth, seq;
1774 int type;
1775
1776
863
 s = SvPV_const(uid, len);
1777
1778
2102
 while (p < len && s[p] != '-')
1779
1239
  ++p;
1780
863
 if (p >= len)
1781
1
  croak("UID contains only one part");
1782
1783
862
 type = su_grok_number(s, p, &depth);
1784
862
 if (type != IS_NUMBER_IN_UV)
1785
2
  croak("First UID part is not an unsigned integer");
1786
1787
860
 ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */
1788
1789
860
 type = su_grok_number(s + p, len - p, &seq);
1790
860
 if (type != IS_NUMBER_IN_UV)
1791
2
  croak("Second UID part is not an unsigned integer");
1792
1793
858
 return su_uid_storage_check(depth, seq);
1794}
1795
1796/* --- Interpreter setup/teardown ------------------------------------------ */
1797
1798
43
STATIC void su_teardown(pTHX_ void *param) {
1799 su_uplevel_ud *cur;
1800 su_uid **map;
1801 dMY_CXT;
1802
1803
43
 map = MY_CXT.uid_storage.map;
1804
43
 if (map) {
1805  STRLEN i;
1806
53
  for (i = 0; i < MY_CXT.uid_storage.used; ++i)
1807
49
   Safefree(map[i]);
1808
4
  Safefree(map);
1809 }
1810
1811
43
 cur = MY_CXT.uplevel_storage.root;
1812
43
 if (cur) {
1813  su_uplevel_ud *prev;
1814  do {
1815
18
   prev = cur;
1816
18
   cur = prev->next;
1817
18
   su_uplevel_ud_delete(prev);
1818
50
  } while (cur);
1819 }
1820
1821 return;
1822}
1823
1824
43
STATIC void su_setup(pTHX) {
1825#define su_setup() su_setup(aTHX)
1826 MY_CXT_INIT;
1827
1828
43
 MY_CXT.stack_placeholder = NULL;
1829
1830 /* NewOp() calls calloc() which just zeroes the memory with memset(). */
1831
43
 Zero(&(MY_CXT.unwind_storage.return_op), 1, LISTOP);
1832
43
 MY_CXT.unwind_storage.return_op.op_type = OP_RETURN;
1833
43
 MY_CXT.unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
1834
1835
43
 Zero(&(MY_CXT.unwind_storage.proxy_op), 1, OP);
1836
43
 MY_CXT.unwind_storage.proxy_op.op_type = OP_STUB;
1837
43
 MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL;
1838
1839
43
 MY_CXT.uplevel_storage.top = NULL;
1840
43
 MY_CXT.uplevel_storage.root = NULL;
1841
43
 MY_CXT.uplevel_storage.count = 0;
1842
1843
43
 MY_CXT.uid_storage.map = NULL;
1844
43
 MY_CXT.uid_storage.used = 0;
1845
43
 MY_CXT.uid_storage.alloc = 0;
1846
1847
43
 call_atexit(su_teardown, NULL);
1848
1849 return;
1850}
1851
1852/* --- XS ------------------------------------------------------------------ */
1853
1854#if SU_HAS_PERL(5, 8, 9)
1855# define SU_SKIP_DB_MAX 2
1856#else
1857# define SU_SKIP_DB_MAX 3
1858#endif
1859
1860/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
1861 * followed by a DB sub */
1862
1863#define SU_SKIP_DB(C) \
1864 STMT_START { \
1865  I32 skipped = 0; \
1866  PERL_CONTEXT *base = cxstack; \
1867  PERL_CONTEXT *cx = base + (C); \
1868  while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
1869   --cx, ++skipped; \
1870  if (cx >= base && (C) > skipped) { \
1871   switch (CxTYPE(cx)) { \
1872    case CXt_SUB: \
1873     if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
1874      (C) -= skipped + 1; \
1875      break; \
1876    default: \
1877     break; \
1878   } \
1879  } \
1880 } STMT_END
1881
1882#define SU_GET_CONTEXT(A, B) \
1883 STMT_START { \
1884  if (items > A) { \
1885   SV *csv = ST(B); \
1886   if (!SvOK(csv)) \
1887    goto default_cx; \
1888   cxix = SvIV(csv); \
1889   if (cxix < 0) \
1890    cxix = 0; \
1891   else if (cxix > cxstack_ix) \
1892    cxix = cxstack_ix; \
1893  } else { \
1894default_cx: \
1895   cxix = cxstack_ix; \
1896   if (PL_DBsub) \
1897    SU_SKIP_DB(cxix); \
1898  } \
1899 } STMT_END
1900
1901#define SU_GET_LEVEL(A, B) \
1902 STMT_START { \
1903  level = 0; \
1904  if (items > 0) { \
1905   SV *lsv = ST(B); \
1906   if (SvOK(lsv)) { \
1907    level = SvIV(lsv); \
1908    if (level < 0) \
1909     level = 0; \
1910   } \
1911  } \
1912 } STMT_END
1913
1914XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
1915
1916
11280
XS(XS_Scope__Upper_unwind) {
1917#ifdef dVAR
1918
11280
 dVAR; dXSARGS;
1919#else
1920 dXSARGS;
1921#endif
1922 dMY_CXT;
1923 I32 cxix;
1924
1925 PERL_UNUSED_VAR(cv); /* -W */
1926 PERL_UNUSED_VAR(ax); /* -Wall */
1927
1928
11280
 SU_GET_CONTEXT(0, items - 1);
1929 do {
1930
11286
  PERL_CONTEXT *cx = cxstack + cxix;
1931
11286
  switch (CxTYPE(cx)) {
1932   case CXt_SUB:
1933
5658
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
1934
0
     continue;
1935   case CXt_EVAL:
1936   case CXt_FORMAT:
1937
11278
    MY_CXT.unwind_storage.cxix = cxix;
1938
11278
    MY_CXT.unwind_storage.items = items;
1939    /* pp_entersub will want to sanitize the stack after returning from there
1940     * Screw that, we're insane */
1941
11278
    if (GIMME_V == G_SCALAR) {
1942
3756
     MY_CXT.unwind_storage.savesp = PL_stack_sp;
1943     /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
1944
3756
     PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
1945    } else {
1946
7522
     MY_CXT.unwind_storage.savesp = NULL;
1947    }
1948
11278
    SAVEDESTRUCTOR_X(su_unwind, NULL);
1949    return;
1950   default:
1951
8
    break;
1952  }
1953
8
 } while (--cxix >= 0);
1954
2
 croak("Can't return outside a subroutine");
1955}
1956
1957MODULE = Scope::Upper PACKAGE = Scope::Upper
1958
1959PROTOTYPES: ENABLE
1960
1961BOOT:
1962{
1963 HV *stash;
1964
1965 MUTEX_INIT(&su_uid_seq_counter_mutex);
1966
1967
43
 su_uid_seq_counter.seqs = NULL;
1968
43
 su_uid_seq_counter.size = 0;
1969
1970
43
 stash = gv_stashpv(__PACKAGE__, 1);
1971
43
 newCONSTSUB(stash, "TOP", newSViv(0));
1972
43
 newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
1973
1974
43
 newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
1975
1976
43
 su_setup();
1977}
1978
1979#if SU_THREADSAFE
1980
1981void
1982CLONE(...)
1983PROTOTYPE: DISABLE
1984PREINIT:
1985 su_uid_storage new_cxt;
1986PPCODE:
1987 {
1988  dMY_CXT;
1989  new_cxt.map = NULL;
1990  new_cxt.used = 0;
1991  new_cxt.alloc = 0;
1992  su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used);
1993 }
1994 {
1995  MY_CXT_CLONE;
1996  MY_CXT.uplevel_storage.top = NULL;
1997  MY_CXT.uplevel_storage.root = NULL;
1998  MY_CXT.uplevel_storage.count = 0;
1999  MY_CXT.uid_storage = new_cxt;
2000 }
2001 XSRETURN(0);
2002
2003#endif /* SU_THREADSAFE */
2004
2005void
2006HERE()
2007PROTOTYPE:
2008PREINIT:
2009
7780
 I32 cxix = cxstack_ix;
2010PPCODE:
2011
7780
 if (PL_DBsub)
2012
8036
  SU_SKIP_DB(cxix);
2013
7780
 EXTEND(SP, 1);
2014
7780
 mPUSHi(cxix);
2015
7780
 XSRETURN(1);
2016
2017void
2018UP(...)
2019PROTOTYPE: ;$
2020PREINIT:
2021 I32 cxix;
2022PPCODE:
2023
35148
 SU_GET_CONTEXT(0, 0);
2024
31488
 if (--cxix < 0)
2025
1
  cxix = 0;
2026
31488
 if (PL_DBsub)
2027
35191
  SU_SKIP_DB(cxix);
2028
31488
 EXTEND(SP, 1);
2029
31488
 mPUSHi(cxix);
2030
31488
 XSRETURN(1);
2031
2032void
2033SUB(...)
2034PROTOTYPE: ;$
2035PREINIT:
2036 I32 cxix;
2037PPCODE:
2038
6891
 SU_GET_CONTEXT(0, 0);
2039
5890
 EXTEND(SP, 1);
2040
21458
 for (; cxix >= 0; --cxix) {
2041
21458
  PERL_CONTEXT *cx = cxstack + cxix;
2042
21458
  switch (CxTYPE(cx)) {
2043   default:
2044
15568
    continue;
2045   case CXt_SUB:
2046
5890
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2047
0
     continue;
2048
5890
    mPUSHi(cxix);
2049
5890
    XSRETURN(1);
2050  }
2051 }
2052
5890
 XSRETURN_UNDEF;
2053
2054void
2055EVAL(...)
2056PROTOTYPE: ;$
2057PREINIT:
2058 I32 cxix;
2059PPCODE:
2060
0
 SU_GET_CONTEXT(0, 0);
2061
0
 EXTEND(SP, 1);
2062
0
 for (; cxix >= 0; --cxix) {
2063
0
  PERL_CONTEXT *cx = cxstack + cxix;
2064
0
  switch (CxTYPE(cx)) {
2065   default:
2066
0
    continue;
2067   case CXt_EVAL:
2068
0
    mPUSHi(cxix);
2069
0
    XSRETURN(1);
2070  }
2071 }
2072
0
 XSRETURN_UNDEF;
2073
2074void
2075SCOPE(...)
2076PROTOTYPE: ;$
2077PREINIT:
2078 I32 cxix, level;
2079PPCODE:
2080
8
 SU_GET_LEVEL(0, 0);
2081
8
 cxix = cxstack_ix;
2082
8
 if (PL_DBsub) {
2083
8
  SU_SKIP_DB(cxix);
2084
28
  while (cxix > 0) {
2085
20
   if (--level < 0)
2086
8
    break;
2087
12
   --cxix;
2088
14
   SU_SKIP_DB(cxix);
2089  }
2090 } else {
2091
0
  cxix -= level;
2092
0
  if (cxix < 0)
2093
0
   cxix = 0;
2094 }
2095
8
 EXTEND(SP, 1);
2096
8
 mPUSHi(cxix);
2097
8
 XSRETURN(1);
2098
2099void
2100CALLER(...)
2101PROTOTYPE: ;$
2102PREINIT:
2103 I32 cxix, level;
2104PPCODE:
2105
1125
 SU_GET_LEVEL(0, 0);
2106
12717
 for (cxix = cxstack_ix; cxix > 0; --cxix) {
2107
12717
  PERL_CONTEXT *cx = cxstack + cxix;
2108
12717
  switch (CxTYPE(cx)) {
2109   case CXt_SUB:
2110
6426
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2111
0
     continue;
2112   case CXt_EVAL:
2113   case CXt_FORMAT:
2114
6427
    if (--level < 0)
2115
1125
     goto done;
2116
5302
    break;
2117  }
2118 }
2119done:
2120
1125
 EXTEND(SP, 1);
2121
1125
 mPUSHi(cxix);
2122
1125
 XSRETURN(1);
2123
2124void
2125want_at(...)
2126PROTOTYPE: ;$
2127PREINIT:
2128 I32 cxix;
2129PPCODE:
2130
20
 SU_GET_CONTEXT(0, 0);
2131
19
 EXTEND(SP, 1);
2132
27
 while (cxix > 0) {
2133
23
  PERL_CONTEXT *cx = cxstack + cxix--;
2134
23
  switch (CxTYPE(cx)) {
2135   case CXt_SUB:
2136   case CXt_EVAL:
2137   case CXt_FORMAT: {
2138
15
    I32 gimme = cx->blk_gimme;
2139
15
    switch (gimme) {
2140
1
     case G_VOID: XSRETURN_UNDEF; break;
2141
3
     case G_SCALAR: XSRETURN_NO; break;
2142
11
     case G_ARRAY: XSRETURN_YES; break;
2143    }
2144
0
    break;
2145   }
2146  }
2147 }
2148
19
 XSRETURN_UNDEF;
2149
2150void
2151reap(SV *hook, ...)
2152PROTOTYPE: &;$
2153PREINIT:
2154 I32 cxix;
2155 su_ud_reap *ud;
2156CODE:
2157
4433
 SU_GET_CONTEXT(1, 1);
2158
4433
 Newx(ud, 1, su_ud_reap);
2159
4433
 SU_UD_ORIGIN(ud) = NULL;
2160
4433
 SU_UD_HANDLER(ud) = su_reap;
2161
4433
 ud->cb = newSVsv(hook);
2162
4433
 su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
2163
2164void
2165localize(SV *sv, SV *val, ...)
2166PROTOTYPE: $$;$
2167PREINIT:
2168 I32 cxix;
2169 I32 size;
2170 su_ud_localize *ud;
2171CODE:
2172
4075
 SU_GET_CONTEXT(2, 2);
2173
4075
 Newx(ud, 1, su_ud_localize);
2174
4075
 SU_UD_ORIGIN(ud) = NULL;
2175
4075
 SU_UD_HANDLER(ud) = su_localize;
2176
4075
 size = su_ud_localize_init(ud, sv, val, NULL);
2177
4071
 su_init(ud, cxix, size);
2178
2179void
2180localize_elem(SV *sv, SV *elem, SV *val, ...)
2181PROTOTYPE: $$$;$
2182PREINIT:
2183 I32 cxix;
2184 I32 size;
2185 su_ud_localize *ud;
2186CODE:
2187
7074
 if (SvTYPE(sv) >= SVt_PVGV)
2188
5
  croak("Can't infer the element localization type from a glob and the value");
2189
7069
 SU_GET_CONTEXT(3, 3);
2190
7069
 Newx(ud, 1, su_ud_localize);
2191
7069
 SU_UD_ORIGIN(ud) = NULL;
2192
7069
 SU_UD_HANDLER(ud) = su_localize;
2193
7069
 size = su_ud_localize_init(ud, sv, val, elem);
2194
7065
 if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
2195
3
  SU_UD_LOCALIZE_FREE(ud);
2196
3
  croak("Can't localize an element of something that isn't an array or a hash");
2197 }
2198
7062
 su_init(ud, cxix, size);
2199
2200void
2201localize_delete(SV *sv, SV *elem, ...)
2202PROTOTYPE: $$;$
2203PREINIT:
2204 I32 cxix;
2205 I32 size;
2206 su_ud_localize *ud;
2207CODE:
2208
1197
 SU_GET_CONTEXT(2, 2);
2209
1197
 Newx(ud, 1, su_ud_localize);
2210
1197
 SU_UD_ORIGIN(ud) = NULL;
2211
1197
 SU_UD_HANDLER(ud) = su_localize;
2212
1197
 size = su_ud_localize_init(ud, sv, NULL, elem);
2213
1193
 su_init(ud, cxix, size);
2214
2215void
2216uplevel(SV *code, ...)
2217PROTOTYPE: &@
2218PREINIT:
2219
2754
 I32 cxix, ret, args = 0;
2220PPCODE:
2221
2754
 if (SvROK(code))
2222
2753
  code = SvRV(code);
2223
2754
 if (SvTYPE(code) < SVt_PVCV)
2224
2
  croak("First argument to uplevel must be a code reference");
2225
3522
 SU_GET_CONTEXT(1, items - 1);
2226 do {
2227
3523
  PERL_CONTEXT *cx = cxstack + cxix;
2228
3523
  switch (CxTYPE(cx)) {
2229   case CXt_EVAL:
2230
2
    croak("Can't uplevel to an eval frame");
2231   case CXt_FORMAT:
2232
0
    croak("Can't uplevel to a format frame");
2233   case CXt_SUB:
2234
2749
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
2235
0
     continue;
2236
2749
    if (items > 1) {
2237
2336
     PL_stack_sp--;
2238
2336
     args = items - 2;
2239    }
2240    /* su_uplevel() takes care of extending the stack if needed. */
2241
2749
    ret = su_uplevel((CV *) code, cxix, args);
2242
1736
    XSRETURN(ret);
2243   default:
2244
772
    break;
2245  }
2246
772
 } while (--cxix >= 0);
2247
1
 croak("Can't uplevel outside a subroutine");
2248
2249void
2250uid(...)
2251PROTOTYPE: ;$
2252PREINIT:
2253 I32 cxix;
2254 SV *uid;
2255PPCODE:
2256
1612
 SU_GET_CONTEXT(0, 0);
2257
839
 uid = su_uid_get(cxix);
2258
839
 EXTEND(SP, 1);
2259
839
 PUSHs(uid);
2260
839
 XSRETURN(1);
2261
2262void
2263validate_uid(SV *uid)
2264PROTOTYPE: $
2265PREINIT:
2266 SV *ret;
2267PPCODE:
2268
863
 ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no;
2269
858
 EXTEND(SP, 1);
2270
858
 PUSHs(ret);
2271
858
 XSRETURN(1);