X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=5c3dec6a65ce1913e42dc5c8bcf4f0d419bde191;hb=refs%2Fheads%2Fslice;hp=e9228f1ae9a5a675750bf6e6b4489b969ac5b039;hpb=a1bace73dbcb4d0ea1dba44209e5b51e5742409d;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index e9228f1..5c3dec6 100644 --- a/Upper.xs +++ b/Upper.xs @@ -10,6 +10,8 @@ # define SU_DEBUG 0 #endif +/* --- Compatibility ------------------------------------------------------- */ + #ifndef STMT_START # define STMT_START do #endif @@ -54,86 +56,7 @@ #define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) -typedef struct { - I32 depth; - I32 *origin; - void (*handler)(pTHX_ void *); -} su_ud_common; - -#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) -#define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin) -#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler) - -#define SU_UD_FREE(U) do { \ - if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \ - Safefree(U); \ -} while (0) - -typedef struct { - su_ud_common ci; - SV *cb; -} su_ud_reap; - -STATIC void su_call(pTHX_ void *ud_) { - su_ud_reap *ud = (su_ud_reap *) ud_; -#if SU_HAS_PERL(5, 10, 0) - I32 dieing = PL_op->op_type == OP_DIE; -#endif - - dSP; - - SU_D(PerlIO_printf(Perl_debug_log, "%p: @@@ call at %d (save is %d)\n", - ud, PL_scopestack_ix, PL_savestack_ix)); - ENTER; - SAVETMPS; - - PUSHMARK(SP); - PUTBACK; - - /* If cxstack_ix isn't incremented there, the eval context will be overwritten - * when the new sub scope will be created in call_sv. */ - -#if SU_HAS_PERL(5, 10, 0) - if (dieing) - if (cxstack_ix < cxstack_max) - ++cxstack_ix; - else - cxstack_ix = Perl_cxinc(aTHX); -#endif - - call_sv(ud->cb, G_VOID); - -#if SU_HAS_PERL(5, 10, 0) - if (dieing && cxstack_ix > 0) - --cxstack_ix; -#endif - - SPAGAIN; - PUTBACK; - - FREETMPS; - LEAVE; - - SvREFCNT_dec(ud->cb); - SU_UD_FREE(ud); -} - -STATIC void su_reap(pTHX_ void *ud) { -#define su_reap(U) su_reap(aTHX_ (U)) - SU_D(PerlIO_printf(Perl_debug_log, "%p: === reap at %d (save is %d)\n", - ud, PL_scopestack_ix, PL_savestack_ix)); - SAVEDESTRUCTOR_X(su_call, ud); - SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n", - ud, PL_savestack_ix, - PL_scopestack[PL_scopestack_ix])); -} - -typedef struct { - su_ud_common ci; - SV *sv; - SV *val; - SV *elem; -} su_ud_localize; +/* --- Stack manipulations ------------------------------------------------- */ #ifndef SvCANEXISTDELETE # define SvCANEXISTDELETE(sv) \ @@ -146,13 +69,14 @@ typedef struct { ) #endif +/* ... Saving array elements ............................................... */ + STATIC I32 su_av_preeminent(pTHX_ AV *av, I32 key) { #define su_av_preeminent(A, K) su_av_preeminent(aTHX_ (A), (K)) MAGIC *mg; HV *stash; - if (!av) - return 0; + if (!av) return 0; if (SvCANEXISTDELETE(av)) return av_exists(av, key); @@ -191,40 +115,187 @@ STATIC void su_save_adelete(pTHX_ AV *av, I32 key) { #endif /* SAVEADELETE */ -STATIC void su_save_aelem(pTHX_ AV *av, I32 key, SV **svp, I32 preeminent) { -#define su_save_aelem(A, K, S, P) su_save_aelem(aTHX_ (A), (K), (S), (P)) +STATIC void su_save_aelem(pTHX_ void *av_, SV *key, SV *val) { +#define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V)) + AV *av = av_; + I32 idx; + I32 preeminent; + SV **svp; + + idx = SvIV(key); + preeminent = su_av_preeminent(av, idx); + svp = av_fetch(av, idx, 1); + if (!*svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx); + if (preeminent) - save_aelem(av, key, svp); + save_aelem(av, idx, svp); else - SAVEADELETE(av, key); + SAVEADELETE(av, idx); + + if (val) { /* local $x[$idx] = $val; */ + SvSetMagicSV(*svp, val); + } else { /* local $x[$idx]; delete $x[$idx]; */ + av_delete(av, idx, G_DISCARD); + } } +/* ... Saving hash elements ................................................ */ + STATIC I32 su_hv_preeminent(pTHX_ HV *hv, SV *keysv) { #define su_hv_preeminent(H, K) su_hv_preeminent(aTHX_ (H), (K)) MAGIC *mg; HV *stash; - if (!hv) - return 0; + if (!hv) return 0; if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env)) return hv_exists_ent(hv, keysv, 0); return 1; } -STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV **svp, I32 preeminent) { -#define su_save_helem(H, K, S, P) su_save_helem(aTHX_ (H), (K), (S), (P)) +STATIC void su_save_helem(pTHX_ void *hv_, SV *keysv, SV *val) { +#define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V)) + HV *hv = hv_; + I32 preeminent; + HE *he; + SV **svp; + + preeminent = su_hv_preeminent(hv, keysv); + he = hv_fetch_ent(hv, keysv, 1, 0); + svp = he ? &HeVAL(he) : NULL; + if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp)); + if (HvNAME_get(hv) && isGV(*svp)) { save_gp((GV *) *svp, 0); return; } - if (!preeminent) { + + if (preeminent) + save_helem(hv, keysv, svp); + else { STRLEN keylen; const char * const key = SvPV_const(keysv, keylen); SAVEDELETE(hv, savepvn(key, keylen), SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); + } + + if (val) { /* local $x{$keysv} = $val; */ + SvSetMagicSV(*svp, val); + } else { /* local $x{$keysv}; delete $x{$keysv}; */ + hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he)); + } +} + +/* --- Actions ------------------------------------------------------------- */ + +typedef struct { + I32 depth; + I32 *origin; + void (*handler)(pTHX_ void *); +} su_ud_common; + +#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) +#define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin) +#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler) + +#define SU_UD_FREE(U) STMT_START { \ + if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \ + Safefree(U); \ +} STMT_END + +/* ... Reap ................................................................ */ + +typedef struct { + su_ud_common ci; + SV *cb; +} su_ud_reap; + +STATIC void su_call(pTHX_ void *ud_) { + su_ud_reap *ud = (su_ud_reap *) ud_; +#if SU_HAS_PERL(5, 10, 0) + I32 dieing = PL_op->op_type == OP_DIE; +#endif + + dSP; + + SU_D(PerlIO_printf(Perl_debug_log, "%p: @@@ call at %d (save is %d)\n", + ud, PL_scopestack_ix, PL_savestack_ix)); + ENTER; + SAVETMPS; + + PUSHMARK(SP); + PUTBACK; + + /* If cxstack_ix isn't incremented there, the eval context will be overwritten + * when the new sub scope will be created in call_sv. */ + +#if SU_HAS_PERL(5, 10, 0) + if (dieing) + if (cxstack_ix < cxstack_max) + ++cxstack_ix; + else + cxstack_ix = Perl_cxinc(aTHX); +#endif + + call_sv(ud->cb, G_VOID); + +#if SU_HAS_PERL(5, 10, 0) + if (dieing && cxstack_ix > 0) + --cxstack_ix; +#endif + + SPAGAIN; + PUTBACK; + + FREETMPS; + LEAVE; + + SvREFCNT_dec(ud->cb); + SU_UD_FREE(ud); +} + +STATIC void su_reap(pTHX_ void *ud) { +#define su_reap(U) su_reap(aTHX_ (U)) + SU_D(PerlIO_printf(Perl_debug_log, "%p: === reap at %d (save is %d)\n", + ud, PL_scopestack_ix, PL_savestack_ix)); + SAVEDESTRUCTOR_X(su_call, ud); + SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n", + ud, PL_savestack_ix, + PL_scopestack[PL_scopestack_ix])); +} + +/* ... Localize & localize array/hash element .............................. */ + +typedef struct { + su_ud_common ci; + SV *sv; + SV *val; + SV *elem; +} su_ud_localize; + +STATIC void su_localize_elem(pTHX_ void *obj, SV *elem, SV *val, void (*do_elem)(pTHX_ void *, SV *, SV *)) { +#define su_localize_elem(O, E, V, D) su_localize_elem(aTHX_ (O), (E), (V), (D)) + AV *aelem, *aval; + if (SvROK(elem) && (aelem = (AV *) SvRV(elem), SvTYPE(aelem) == SVt_PVAV)) { + I32 i, last = av_len(aelem); + SV **svpe, **svpv; + if (!val) { + for (i = 0; i <= last; ++i) { + svpe = av_fetch(aelem, i, 0); + if (!svpe) continue; + do_elem(aTHX_ obj, *svpe, NULL); + } + } else if (SvROK(val) && (aval = (AV *) SvRV(val), SvTYPE(aval) == SVt_PVAV)){ + for (i = 0; i <= last; ++i) { + svpe = av_fetch(aelem, i, 0); + if (!svpe) continue; + svpv = av_fetch(aval, i, 0); + if (!svpv) continue; + do_elem(aTHX_ obj, *svpe, *svpv); + } + } } else { - save_helem(hv, keysv, svp); + do_elem(aTHX_ obj, elem, val); } } @@ -240,10 +311,14 @@ STATIC void su_localize(pTHX_ void *ud_) { if (SvTYPE(sv) >= SVt_PVGV) { gv = (GV *) sv; - if (!SvROK(val)) + if (!val) { /* local *x; */ + t = SVt_PVGV; + } else if (!SvROK(val)) { /* local *x = $val; */ goto assign; - t = SvTYPE(SvRV(val)); - deref = 1; + } else { /* local *x = \$val; */ + t = SvTYPE(SvRV(val)); + deref = 1; + } } else { STRLEN len, l; const char *p = SvPV_const(sv, len), *s; @@ -259,16 +334,16 @@ STATIC void su_localize(pTHX_ void *ud_) { case '&': t = SVt_PVCV; break; case '*': t = SVt_PVGV; break; } - if (t == SVt_NULL) { + if (t != SVt_NULL) { + ++s; + --l; + } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */ if (SvROK(val) && !sv_isobject(val)) { t = SvTYPE(SvRV(val)); deref = 1; } else { t = SvTYPE(val); } - } else { - ++s; - --l; } gv = gv_fetchpvn_flags(s, l, GV_ADDMULTI, SVt_PVGV); } @@ -285,27 +360,15 @@ STATIC void su_localize(pTHX_ void *ud_) { switch (t) { case SVt_PVAV: if (elem) { - I32 idx = SvIV(elem); - AV *av = GvAV(gv); - I32 preeminent = su_av_preeminent(av, idx); - SV **svp = av_fetch(av, idx, 1); - if (!*svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx); - su_save_aelem(av, idx, svp, preeminent); - gv = (GV *) *svp; - goto maybe_deref; + su_localize_elem(GvAV(gv), elem, val, su_save_aelem); + goto done; } else save_ary(gv); break; case SVt_PVHV: if (elem) { - HV *hv = GvHV(gv); - I32 preeminent = su_hv_preeminent(hv, elem); - HE *he = hv_fetch_ent(hv, elem, 1, 0); - SV **svp = he ? &HeVAL(he) : NULL; - if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp)); - su_save_helem(hv, elem, svp, preeminent); - gv = (GV *) *svp; - goto maybe_deref; + su_localize_elem(GvHV(gv), elem, val, su_save_helem); + goto done; } else save_hash(gv); break; @@ -319,7 +382,7 @@ STATIC void su_localize(pTHX_ void *ud_) { default: gv = (GV *) save_scalar(gv); maybe_deref: - if (deref) + if (deref) /* val != NULL */ val = SvRV(val); break; } @@ -329,14 +392,18 @@ maybe_deref: PL_scopestack[PL_scopestack_ix])); assign: - SvSetMagicSV((SV *) gv, val); + if (val) + SvSetMagicSV((SV *) gv, val); +done: SvREFCNT_dec(ud->elem); SvREFCNT_dec(ud->val); SvREFCNT_dec(ud->sv); SU_UD_FREE(ud); } +/* --- Pop a context back -------------------------------------------------- */ + #if SU_DEBUG # ifdef DEBUGGING # define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])] @@ -380,11 +447,20 @@ STATIC void su_pop(pTHX_ void *ud) { } } +/* --- Initialize the stack and the action userdata ------------------------ */ + STATIC I32 su_init(pTHX_ I32 level, void *ud, I32 size) { #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S)) I32 i, depth = 0, *origin; I32 cur, last, step; + LEAVE; + + if (level <= 0) { + SU_UD_HANDLER(ud)(aTHX_ ud); + goto done; + } + SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for level %d\n", ud, level)); for (i = 0; i < level; ++i) { @@ -431,6 +507,15 @@ STATIC I32 su_init(pTHX_ I32 level, void *ud, I32 size) { SU_UD_ORIGIN(ud) = origin; SU_UD_DEPTH(ud) = depth; + + SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n", + ud, PL_savestack_ix, depth)); + + SAVEDESTRUCTOR_X(su_pop, ud); + +done: + ENTER; + return depth; } @@ -471,15 +556,7 @@ CODE: SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_reap; ud->cb = newSVsv(hook); - LEAVE; - if (level) { - I32 depth = su_init(level, ud, 3); - SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n", - ud, PL_savestack_ix, depth)); - SAVEDESTRUCTOR_X(su_pop, ud); - } else - su_reap(ud); - ENTER; + su_init(level, ud, 3); void localize(SV *sv, SV *val, ...) @@ -496,21 +573,13 @@ CODE: ud->sv = sv; ud->val = newSVsv(val); ud->elem = NULL; - LEAVE; - if (level) { - I32 depth = su_init(level, ud, 3); - SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n", - ud, PL_savestack_ix, depth)); - SAVEDESTRUCTOR_X(su_pop, ud); - } else - su_localize(ud); - ENTER; + su_init(level, ud, 3); void localize_elem(SV *sv, SV *elem, SV *val, ...) PROTOTYPE: $$$;$ PREINIT: - I32 level = 0; + I32 level = 0, slots = 1; su_ud_localize *ud; CODE: SU_GET_LEVEL(3); @@ -522,13 +591,26 @@ CODE: ud->val = newSVsv(val); SvREFCNT_inc(elem); ud->elem = elem; - LEAVE; - if (level) { - I32 depth = su_init(level, ud, 4); - SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n", - ud, PL_savestack_ix, depth)); - SAVEDESTRUCTOR_X(su_pop, ud); - } else - su_localize(ud); - ENTER; + if (SvROK(elem) && (elem = SvRV(elem), SvTYPE(elem) == SVt_PVAV)) + slots = 1 + av_len((AV *) elem); + su_init(level, ud, slots * 4); +void +localize_delete(SV *sv, SV *elem, ...) +PROTOTYPE: $$;$ +PREINIT: + I32 level = 0, slots = 1; + su_ud_localize *ud; +CODE: + SU_GET_LEVEL(2); + Newx(ud, 1, su_ud_localize); + SU_UD_ORIGIN(ud) = NULL; + SU_UD_HANDLER(ud) = su_localize; + SvREFCNT_inc(sv); + ud->sv = sv; + ud->val = NULL; + SvREFCNT_inc(elem); + ud->elem = elem; + if (SvROK(elem) && (elem = SvRV(elem), SvTYPE(elem) == SVt_PVAV)) + slots = 1 + av_len((AV *) elem); + su_init(level, ud, slots * 3);