X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=906065a73020430db9eebed6735ada1ed05836c9;hb=dcc300c85d8832a6e0ad6852f68ea4ec5899348d;hp=0ae07f085059f5729a2342bc3ea965f0a98ea6ae;hpb=c6e995c68b5384510061cde2d433e9506a3935f5;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index 0ae07f0..906065a 100644 --- a/Upper.xs +++ b/Upper.xs @@ -116,6 +116,11 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define CvISXSUB(C) CvXSUB(C) #endif +#ifndef PadlistARRAY +# define PadlistARRAY(P) AvARRAY(P) +# define PadARRAY(P) AvARRAY(P) +#endif + #ifndef CxHASARGS # define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif @@ -128,6 +133,22 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D)) #endif +#ifndef OP_GIMME_REVERSE +STATIC U8 su_op_gimme_reverse(U8 gimme) { + switch (gimme) { + case G_VOID: + return OPf_WANT_VOID; + case G_ARRAY: + return OPf_WANT_LIST; + default: + break; + } + + return OPf_WANT_SCALAR; +} +#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) +#endif + #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif @@ -179,6 +200,133 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define MY_CXT_CLONE NOOP #endif +/* --- Unique context ID global storage ------------------------------------ */ + +/* ... Sequence ID counter ................................................. */ + +typedef struct { + UV *seqs; + STRLEN size; +} su_uv_array; + +STATIC su_uv_array su_uid_seq_counter; + +#ifdef USE_ITHREADS + +STATIC perl_mutex su_uid_seq_counter_mutex; + +#define SU_LOCK(M) MUTEX_LOCK(M) +#define SU_UNLOCK(M) MUTEX_UNLOCK(M) + +#else /* USE_ITHREADS */ + +#define SU_LOCK(M) +#define SU_UNLOCK(M) + +#endif /* !USE_ITHREADS */ + +STATIC UV su_uid_seq_next(pTHX_ UV depth) { +#define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D)) + UV seq; + UV *seqs; + + SU_LOCK(&su_uid_seq_counter_mutex); + + seqs = su_uid_seq_counter.seqs; + + if (depth >= su_uid_seq_counter.size) { + UV i; + + seqs = PerlMemShared_realloc(seqs, (depth + 1) * sizeof(UV)); + for (i = su_uid_seq_counter.size; i <= depth; ++i) + seqs[i] = 0; + + su_uid_seq_counter.seqs = seqs; + su_uid_seq_counter.size = depth + 1; + } + + seq = ++seqs[depth]; + + SU_UNLOCK(&su_uid_seq_counter_mutex); + + return seq; +} + +/* ... UID storage ......................................................... */ + +typedef struct { + UV seq; + U32 flags; +} su_uid; + +#define SU_UID_ACTIVE 1 + +STATIC UV su_uid_depth(pTHX_ I32 cxix) { +#define su_uid_depth(I) su_uid_depth(aTHX_ (I)) + const PERL_SI *si; + UV depth; + + depth = cxix; + for (si = PL_curstackinfo->si_prev; si; si = si->si_prev) + depth += si->si_cxix + 1; + + return depth; +} + +typedef struct { + su_uid **map; + STRLEN used; + STRLEN alloc; +} su_uid_storage; + +STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { +#define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D)) + su_uid **old_map = old_cxt->map; + + if (old_map) { + su_uid **new_map = new_cxt->map; + STRLEN old_used = old_cxt->used; + STRLEN new_used, new_alloc; + STRLEN i; + + new_used = max_depth < old_used ? max_depth : old_used; + new_cxt->used = new_used; + + if (new_used <= new_cxt->alloc) + new_alloc = new_cxt->alloc; + else { + new_alloc = new_used; + Renew(new_map, new_alloc, su_uid *); + for (i = new_cxt->alloc; i < new_alloc; ++i) + new_map[i] = NULL; + new_cxt->map = new_map; + new_cxt->alloc = new_alloc; + } + + for (i = 0; i < new_alloc; ++i) { + su_uid *new_uid = new_map[i]; + + if (i < new_used) { /* => i < max_depth && i < old_used */ + su_uid *old_uid = old_map[i]; + + if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) { + if (!new_uid) { + Newx(new_uid, 1, su_uid); + new_map[i] = new_uid; + } + *new_uid = *old_uid; + continue; + } + } + + if (new_uid) + new_uid->flags &= ~SU_UID_ACTIVE; + } + } + + return; +} + /* --- unwind() global storage --------------------------------------------- */ typedef struct { @@ -194,28 +342,32 @@ typedef struct { #define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0) typedef struct { - void *next; + void *next; - I32 cxix; - bool died; + su_uid_storage tmp_uid_storage; + su_uid_storage old_uid_storage; - CV *target; - I32 target_depth; + I32 cxix; - CV *callback; - CV *renamed; + I32 target_depth; + CV *target; - PERL_SI *si; - PERL_SI *old_curstackinfo; - AV *old_mainstack; + CV *callback; + CV *renamed; + + PERL_SI *si; + PERL_SI *old_curstackinfo; + AV *old_mainstack; - COP *old_curcop; + COP *old_curcop; + OP *old_op; #if SU_UPLEVEL_HIJACKS_RUNOPS runops_proc_t old_runops; #endif bool old_catch; - OP *old_op; + + bool died; } su_uplevel_ud; STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { @@ -226,6 +378,10 @@ STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { Newx(sud, 1, su_uplevel_ud); sud->next = NULL; + sud->tmp_uid_storage.map = NULL; + sud->tmp_uid_storage.used = 0; + sud->tmp_uid_storage.alloc = 0; + Newx(si, 1, PERL_SI); si->si_stack = newAV(); AvREAL_off(si->si_stack); @@ -244,6 +400,18 @@ STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { Safefree(si->si_cxstack); SvREFCNT_dec(si->si_stack); Safefree(si); + + if (sud->tmp_uid_storage.map) { + su_uid **map = sud->tmp_uid_storage.map; + STRLEN alloc = sud->tmp_uid_storage.alloc; + STRLEN i; + + for (i = 0; i < alloc; ++i) + Safefree(map[i]); + + Safefree(map); + } + Safefree(sud); return; @@ -267,6 +435,7 @@ typedef struct { char *stack_placeholder; su_unwind_storage unwind_storage; su_uplevel_storage uplevel_storage; + su_uid_storage uid_storage; } my_cxt_t; START_MY_CXT @@ -511,6 +680,8 @@ typedef struct { /* ... Reap ................................................................ */ +#define SU_SAVE_LAST_CX (!SU_HAS_PERL(5, 8, 4) || (SU_HAS_PERL(5, 9, 5) && !SU_HAS_PERL(5, 14, 0)) || SU_HAS_PERL(5, 15, 0)) + typedef struct { su_ud_common ci; SV *cb; @@ -518,10 +689,10 @@ typedef struct { STATIC void su_call(pTHX_ void *ud_) { su_ud_reap *ud = (su_ud_reap *) ud_; -#if SU_HAS_PERL(5, 9, 5) - PERL_CONTEXT saved_cx; +#if SU_SAVE_LAST_CX I32 cxix; -#endif + PERL_CONTEXT saved_cx; +#endif /* SU_SAVE_LAST_CX */ dSP; @@ -537,22 +708,18 @@ STATIC void su_call(pTHX_ void *ud_) { PUSHMARK(SP); PUTBACK; +#if SU_SAVE_LAST_CX /* If the recently popped context isn't saved there, it will be overwritten by * the sub scope from call_sv, although it's still needed in our caller. */ - -#if SU_HAS_PERL(5, 9, 5) - if (cxstack_ix < cxstack_max) - cxix = cxstack_ix + 1; - else - cxix = Perl_cxinc(aTHX); + cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); saved_cx = cxstack[cxix]; -#endif +#endif /* SU_SAVE_LAST_CX */ call_sv(ud->cb, G_VOID); -#if SU_HAS_PERL(5, 9, 5) +#if SU_SAVE_LAST_CX cxstack[cxix] = saved_cx; -#endif +#endif /* SU_SAVE_LAST_CX */ PUTBACK; @@ -741,9 +908,9 @@ done: #if SU_DEBUG # ifdef DEBUGGING -# define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])] +# define SU_CXNAME(C) PL_block_type[CxTYPE(C)] # else -# define SU_CXNAME "XXX" +# define SU_CXNAME(C) "XXX" # endif #endif @@ -756,7 +923,7 @@ STATIC void su_pop(pTHX_ void *ud) { PerlIO_printf(Perl_debug_log, "%p: --- pop a %s\n" "%p: leave scope at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n", - ud, SU_CXNAME, + ud, SU_CXNAME(cxstack + cxstack_ix), ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix]) ); @@ -827,19 +994,6 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { for (i = cxstack_ix; i > cxix; --i) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { -#if SU_HAS_PERL(5, 10, 0) - case CXt_BLOCK: - SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i)); - /* Given and when blocks are actually followed by a simple block, so skip - * it if needed. */ - if (cxix > 0) { /* Implies i > 0 */ - PERL_CONTEXT *next = cx - 1; - if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN) - --cxix; - } - depth++; - break; -#endif #if SU_HAS_PERL(5, 11, 0) case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: @@ -948,28 +1102,13 @@ STATIC void su_unwind(pTHX_ void *ud_) { /* --- Uplevel ------------------------------------------------------------- */ -#ifndef OP_GIMME_REVERSE -STATIC U8 su_op_gimme_reverse(U8 gimme) { - switch (gimme) { - case G_VOID: - return OPf_WANT_VOID; - case G_ARRAY: - return OPf_WANT_LIST; - default: - break; - } - - return OPf_WANT_SCALAR; -} -#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) -#endif - #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END -STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) { -#define su_uplevel_storage_new() su_uplevel_storage_new(aTHX) +STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { +#define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I)) su_uplevel_ud *sud; + UV depth; dMY_CXT; sud = MY_CXT.uplevel_storage.root; @@ -983,6 +1122,11 @@ STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) { sud->next = MY_CXT.uplevel_storage.top; MY_CXT.uplevel_storage.top = sud; + depth = su_uid_depth(cxix); + su_uid_storage_dup(&sud->tmp_uid_storage, &MY_CXT.uid_storage, depth); + sud->old_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->tmp_uid_storage; + return sud; } @@ -990,6 +1134,18 @@ STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S)) dMY_CXT; + sud->tmp_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->old_uid_storage; + { + su_uid **map; + UV i, alloc; + map = sud->tmp_uid_storage.map; + alloc = sud->tmp_uid_storage.alloc; + for (i = 0; i < alloc; ++i) { + if (map[i]) + map[i]->flags &= SU_UID_ACTIVE; + } + } MY_CXT.uplevel_storage.top = sud->next; if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) { @@ -1015,7 +1171,7 @@ STATIC int su_uplevel_goto_static(const OP *o) { case OP_GOTO: return 1; default: - if (su_uplevel_goto_static(cUNOPo->op_first)) + if (su_uplevel_goto_static(((const UNOP *) o)->op_first)) return 1; break; } @@ -1084,7 +1240,7 @@ done: #endif /* SU_UPLEVEL_HIJACKS_RUNOPS */ -#define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] +#define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] STATIC void su_uplevel_restore(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; @@ -1233,6 +1389,9 @@ found_it: { dMY_CXT; + sud->tmp_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->old_uid_storage; + MY_CXT.uplevel_storage.top = sud->next; sud->next = MY_CXT.uplevel_storage.root; MY_CXT.uplevel_storage.root = sud; @@ -1324,7 +1483,7 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base; SPAGAIN; - sud = su_uplevel_storage_new(); + sud = su_uplevel_storage_new(cxix); sud->cxix = cxix; sud->died = 1; @@ -1480,12 +1639,247 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { return ret; } +/* --- Unique context ID --------------------------------------------------- */ + +STATIC su_uid *su_uid_storage_fetch(pTHX_ UV depth) { +#define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D)) + su_uid **map, *uid; + STRLEN alloc; + dMY_CXT; + + map = MY_CXT.uid_storage.map; + alloc = MY_CXT.uid_storage.alloc; + + if (depth >= alloc) { + STRLEN i; + + Renew(map, depth + 1, su_uid *); + for (i = alloc; i <= depth; ++i) + map[i] = NULL; + + MY_CXT.uid_storage.map = map; + MY_CXT.uid_storage.alloc = depth + 1; + } + + uid = map[depth]; + + if (!uid) { + Newx(uid, 1, su_uid); + uid->seq = 0; + uid->flags = 0; + map[depth] = uid; + } + + if (depth >= MY_CXT.uid_storage.used) + MY_CXT.uid_storage.used = depth + 1; + + return uid; +} + +STATIC int su_uid_storage_check(pTHX_ UV depth, UV seq) { +#define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S)) + su_uid *uid; + dMY_CXT; + + if (depth >= MY_CXT.uid_storage.used) + return 0; + + uid = MY_CXT.uid_storage.map[depth]; + + return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); +} + +STATIC void su_uid_drop(pTHX_ void *ud_) { + su_uid *uid = ud_; + + uid->flags &= ~SU_UID_ACTIVE; +} + +STATIC void su_uid_bump(pTHX_ void *ud_) { + su_ud_reap *ud = ud_; + + SAVEDESTRUCTOR_X(su_uid_drop, ud->cb); +} + +STATIC SV *su_uid_get(pTHX_ I32 cxix) { +#define su_uid_get(I) su_uid_get(aTHX_ (I)) + su_uid *uid; + SV *uid_sv; + UV depth; + + depth = su_uid_depth(cxix); + uid = su_uid_storage_fetch(depth); + + if (!(uid->flags & SU_UID_ACTIVE)) { + su_ud_reap *ud; + + uid->seq = su_uid_seq_next(depth); + uid->flags |= SU_UID_ACTIVE; + + Newx(ud, 1, su_ud_reap); + SU_UD_ORIGIN(ud) = NULL; + SU_UD_HANDLER(ud) = su_uid_bump; + ud->cb = (SV *) uid; + su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); + } + + uid_sv = sv_newmortal(); + sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq); + return uid_sv; +} + +#ifdef grok_number + +#define su_grok_number(S, L, VP) grok_number((S), (L), (VP)) + +#else /* grok_number */ + +#define IS_NUMBER_IN_UV 0x1 + +STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { +#define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP)) + STRLEN i; + SV *tmpsv; + + /* This crude check should be good enough for a fallback implementation. + * Better be too strict than too lax. */ + for (i = 0; i < len; ++i) { + if (!isDIGIT(s[i])) + return 0; + } + + tmpsv = sv_newmortal(); + sv_setpvn(tmpsv, s, len); + *valuep = sv_2uv(tmpsv); + + return IS_NUMBER_IN_UV; +} + +#endif /* !grok_number */ + +STATIC int su_uid_validate(pTHX_ SV *uid) { +#define su_uid_validate(U) su_uid_validate(aTHX_ (U)) + const char *s; + STRLEN len, p = 0; + UV depth, seq; + int type; + + s = SvPV_const(uid, len); + + while (p < len && s[p] != '-') + ++p; + if (p >= len) + croak("UID contains only one part"); + + type = su_grok_number(s, p, &depth); + if (type != IS_NUMBER_IN_UV) + croak("First UID part is not an unsigned integer"); + + ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */ + + type = su_grok_number(s + p, len - p, &seq); + if (type != IS_NUMBER_IN_UV) + croak("Second UID part is not an unsigned integer"); + + return su_uid_storage_check(depth, seq); +} + +/* --- Context operations -------------------------------------------------- */ + +/* Remove sequences of BLOCKs having DB for stash, followed by a SUB context + * for the debugger callback. */ + +STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { +#define su_context_skip_db(C) su_context_skip_db(aTHX_ (C)) + I32 i; + + if (!PL_DBsub) + return cxix; + + for (i = cxix; i > 0; --i) { + PERL_CONTEXT *cx = cxstack + i; + + switch (CxTYPE(cx)) { + case CXt_BLOCK: + if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv)) + continue; + break; + case CXt_SUB: + if (cx->blk_sub.cv == GvCV(PL_DBsub)) { + cxix = i - 1; + continue; + } + break; + default: + break; + } + + break; + } + + return cxix; +} + +STATIC I32 su_context_up(pTHX_ I32 cxix) { +#define su_context_up(C) su_context_up(aTHX_ (C)) + PERL_CONTEXT *cx; + + if (cxix <= 0) + return 0; + + cx = cxstack + cxix; + if (CxTYPE(cx) == CXt_BLOCK) { + PERL_CONTEXT *prev = cx - 1; + + switch (CxTYPE(prev)) { +#if SU_HAS_PERL(5, 10, 0) + case CXt_GIVEN: + case CXt_WHEN: +#endif +#if SU_HAS_PERL(5, 11, 0) + /* That's the only subcategory that can cause an extra BLOCK context */ + case CXt_LOOP_PLAIN: +#else + case CXt_LOOP: +#endif + if (cx->blk_oldcop == prev->blk_oldcop) + cxix -= 2; + else + --cxix; + break; + case CXt_SUBST: + if (cx->blk_oldcop && cx->blk_oldcop->op_sibling + && cx->blk_oldcop->op_sibling->op_type == OP_SUBST) + cxix -= 2; + else + --cxix; + break; + default: + --cxix; + break; + } + } else { + --cxix; + } + + return cxix; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { su_uplevel_ud *cur; + su_uid **map; dMY_CXT; + map = MY_CXT.uid_storage.map; + if (map) { + STRLEN i; + for (i = 0; i < MY_CXT.uid_storage.used; ++i) + Safefree(map[i]); + Safefree(map); + } + cur = MY_CXT.uplevel_storage.root; if (cur) { su_uplevel_ud *prev; @@ -1518,6 +1912,10 @@ STATIC void su_setup(pTHX) { MY_CXT.uplevel_storage.root = NULL; MY_CXT.uplevel_storage.count = 0; + MY_CXT.uid_storage.map = NULL; + MY_CXT.uid_storage.used = 0; + MY_CXT.uid_storage.alloc = 0; + call_atexit(su_teardown, NULL); return; @@ -1525,34 +1923,6 @@ STATIC void su_setup(pTHX) { /* --- XS ------------------------------------------------------------------ */ -#if SU_HAS_PERL(5, 8, 9) -# define SU_SKIP_DB_MAX 2 -#else -# define SU_SKIP_DB_MAX 3 -#endif - -/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts - * followed by a DB sub */ - -#define SU_SKIP_DB(C) \ - STMT_START { \ - I32 skipped = 0; \ - PERL_CONTEXT *base = cxstack; \ - PERL_CONTEXT *cx = base + (C); \ - while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \ - --cx, ++skipped; \ - if (cx >= base && (C) > skipped) { \ - switch (CxTYPE(cx)) { \ - case CXt_SUB: \ - if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \ - (C) -= skipped + 1; \ - break; \ - default: \ - break; \ - } \ - } \ - } STMT_END - #define SU_GET_CONTEXT(A, B) \ STMT_START { \ if (items > A) { \ @@ -1567,8 +1937,6 @@ STATIC void su_setup(pTHX) { } else { \ default_cx: \ cxix = cxstack_ix; \ - if (PL_DBsub) \ - SU_SKIP_DB(cxix); \ } \ } STMT_END @@ -1600,6 +1968,7 @@ XS(XS_Scope__Upper_unwind) { PERL_UNUSED_VAR(ax); /* -Wall */ SU_GET_CONTEXT(0, items - 1); + cxix = su_context_skip_db(cxix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -1636,6 +2005,11 @@ BOOT: { HV *stash; + MUTEX_INIT(&su_uid_seq_counter_mutex); + + su_uid_seq_counter.seqs = NULL; + su_uid_seq_counter.size = 0; + stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "TOP", newSViv(0)); newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); @@ -1650,12 +2024,22 @@ BOOT: void CLONE(...) PROTOTYPE: DISABLE +PREINIT: + su_uid_storage new_cxt; PPCODE: + { + dMY_CXT; + new_cxt.map = NULL; + new_cxt.used = 0; + new_cxt.alloc = 0; + su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used); + } { MY_CXT_CLONE; MY_CXT.uplevel_storage.top = NULL; MY_CXT.uplevel_storage.root = NULL; MY_CXT.uplevel_storage.count = 0; + MY_CXT.uid_storage = new_cxt; } XSRETURN(0); @@ -1665,10 +2049,9 @@ void HERE() PROTOTYPE: PREINIT: - I32 cxix = cxstack_ix; + I32 cxix; PPCODE: - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_skip_db(cxstack_ix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -1680,10 +2063,9 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); - if (--cxix < 0) - cxix = 0; - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_skip_db(cxix); + cxix = su_context_up(cxix); + cxix = su_context_skip_db(cxix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -1737,19 +2119,10 @@ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); - cxix = cxstack_ix; - if (PL_DBsub) { - SU_SKIP_DB(cxix); - while (cxix > 0) { - if (--level < 0) - break; - --cxix; - SU_SKIP_DB(cxix); - } - } else { - cxix -= level; - if (cxix < 0) - cxix = 0; + cxix = su_context_skip_db(cxstack_ix); + while (--level >= 0) { + cxix = su_context_up(cxix); + cxix = su_context_skip_db(cxix); } EXTEND(SP, 1); mPUSHi(cxix); @@ -1792,6 +2165,8 @@ PPCODE: PERL_CONTEXT *cx = cxstack + cxix--; switch (CxTYPE(cx)) { case CXt_SUB: + if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) + continue; case CXt_EVAL: case CXt_FORMAT: { I32 gimme = cx->blk_gimme; @@ -1814,6 +2189,7 @@ PREINIT: su_ud_reap *ud; CODE: SU_GET_CONTEXT(1, 1); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_reap); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_reap; @@ -1829,6 +2205,7 @@ PREINIT: su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -1847,6 +2224,7 @@ CODE: croak("Can't infer the element localization type from a glob and the value"); SU_GET_CONTEXT(3, 3); Newx(ud, 1, su_ud_localize); + cxix = su_context_skip_db(cxix); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; size = su_ud_localize_init(ud, sv, val, elem); @@ -1865,6 +2243,7 @@ PREINIT: su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -1904,3 +2283,28 @@ PPCODE: } } while (--cxix >= 0); croak("Can't uplevel outside a subroutine"); + +void +uid(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix; + SV *uid; +PPCODE: + SU_GET_CONTEXT(0, 0); + cxix = su_context_skip_db(cxix); + uid = su_uid_get(cxix); + EXTEND(SP, 1); + PUSHs(uid); + XSRETURN(1); + +void +validate_uid(SV *uid) +PROTOTYPE: $ +PREINIT: + SV *ret; +PPCODE: + ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no; + EXTEND(SP, 1); + PUSHs(ret); + XSRETURN(1);