X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=f90f31917886f4c1eef471e1da9f72e3b5bbd3b5;hb=7c2b31131b09869b8021b94eb18d14b0df4b356c;hp=fd2e00e6a7bedcc2797e373ece6cfcecb475f9f0;hpb=91e5283b10139b952dd22a6478166edf430cfcce;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index fd2e00e..f90f319 100644 --- a/Upper.xs +++ b/Upper.xs @@ -133,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 @@ -893,9 +909,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 @@ -908,7 +924,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]) ); @@ -979,19 +995,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: @@ -1100,22 +1103,6 @@ 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 @@ -1798,6 +1785,87 @@ STATIC int su_uid_validate(pTHX_ SV *uid) { 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) { @@ -1856,34 +1924,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) { \ @@ -1898,8 +1938,6 @@ STATIC void su_setup(pTHX) { } else { \ default_cx: \ cxix = cxstack_ix; \ - if (PL_DBsub) \ - SU_SKIP_DB(cxix); \ } \ } STMT_END @@ -1931,6 +1969,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)) { @@ -2011,10 +2050,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); @@ -2026,10 +2064,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); @@ -2083,19 +2120,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); @@ -2138,6 +2166,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; @@ -2160,6 +2190,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; @@ -2175,6 +2206,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; @@ -2193,6 +2225,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); @@ -2211,6 +2244,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; @@ -2259,7 +2293,8 @@ PREINIT: SV *uid; PPCODE: SU_GET_CONTEXT(0, 0); - uid = su_uid_get(cxix); + cxix = su_context_skip_db(cxix); + uid = su_uid_get(cxix); EXTEND(SP, 1); PUSHs(uid); XSRETURN(1);