X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=82631169a3f7055157fd48cde7b844cd663d6dd7;hb=0da6f437954bd0e68168bc3b743b337b0f7afa05;hp=2ae40a1df5d383bea56c687e04731f2d36dbfd4f;hpb=763ba8093427f3668368fa885741618ac6289d41;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/Magic.xs b/Magic.xs index 2ae40a1..8263116 100644 --- a/Magic.xs +++ b/Magic.xs @@ -1,6 +1,8 @@ /* This file is part of the Variable::Magic Perl module. * See http://search.cpan.org/dist/Variable-Magic/ */ +#include /* , va_{start,arg,end}, ... */ + #include /* sprintf() */ #define PERL_NO_GET_CONTEXT @@ -12,10 +14,22 @@ #define R(S) fprintf(stderr, "R(" #S ") = %d\n", SvREFCNT(S)) +#define PERL_VERSION_GE(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) + #define PERL_VERSION_LE(R, V, S) (PERL_REVISION < (R) || (PERL_REVISION == (R) && (PERL_VERSION < (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION <= (S)))))) #define PERL_API_VERSION_GE(R, V, S) (PERL_API_REVISION > (R) || (PERL_API_REVISION == (R) && (PERL_API_VERSION > (V) || (PERL_API_VERSION == (V) && (PERL_API_SUBVERSION >= (S)))))) +#define PERL_API_VERSION_LE(R, V, S) (PERL_API_REVISION < (R) || (PERL_API_REVISION == (R) && (PERL_API_VERSION < (V) || (PERL_API_VERSION == (V) && (PERL_API_SUBVERSION <= (S)))))) + +#ifndef VMG_PERL_PATCHLEVEL +# ifdef PERL_PATCHNUM +# define VMG_PERL_PATCHLEVEL PERL_PATCHNUM +# else +# define VMG_PERL_PATCHLEVEL 0 +# endif +#endif + /* --- Compatibility ------------------------------------------------------- */ #ifndef Newx @@ -26,6 +40,10 @@ # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif +#ifndef mPUSHi +# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I))) +#endif + #ifndef dMY_CXT # define MY_CXT vmg_globaldata # define dMY_CXT @@ -41,7 +59,6 @@ # define MGf_COPY 0 #endif -#undef MGf_DUP /* Disable it for now. */ #ifndef MGf_DUP # define MGf_DUP 0 #endif @@ -50,34 +67,52 @@ # define MGf_LOCAL 0 #endif -#if PERL_API_VERSION_GE(5, 10, 0) +/* uvar magic and Hash::Util::FieldHash were commited with p28419 */ +#if (VMG_PERL_PATCHLEVEL >= 28419) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 4)) # define VMG_UVAR 1 #else # define VMG_UVAR 0 #endif +#if !defined(VMG_COMPAT_ARRAY_PUSH_NOLEN) && ((VMG_PERL_PATCHLEVEL >= 25854) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 3))) +# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1 +#else +# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 +#endif + +/* since 5.9.5 - see #43357 */ +#if (VMG_PERL_PATCHLEVEL >= 31473) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 9, 5)) +# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1 +#else +# define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0 +#endif + +#if (VMG_PERL_PATCHLEVEL >= 32969) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE(5, 11, 0)) +# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1 +#else +# define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0 +#endif + #if VMG_UVAR -/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */ -STATIC void vmg_mg_magical(pTHX_ SV *sv) { -#define vmg_mg_magical(S) vmg_mg_magical(aTHX_ (S)) +/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html - but specialized to our needs. */ +STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) { +#define vmg_sv_magicuvar(S, U, L) vmg_sv_magicuvar(aTHX_ (S), (U), (L)) const MAGIC* mg; + sv_magic(sv, NULL, PERL_MAGIC_uvar, uf, len); + /* uvar magic has set and get magic, hence this has set SVs_GMG and SVs_SMG. */ PERL_UNUSED_CONTEXT; if ((mg = SvMAGIC(sv))) { SvRMAGICAL_off(sv); do { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) - SvGMAGICAL_on(sv); - if (vtbl->svt_set) - SvSMAGICAL_on(sv); - if (vtbl->svt_clear) + if (vtbl->svt_clear) { SvRMAGICAL_on(sv); + break; + } } } while ((mg = mg->mg_moremagic)); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) - SvRMAGICAL_on(sv); } } @@ -97,9 +132,9 @@ START_MY_CXT /* --- Signatures ---------------------------------------------------------- */ #define SIG_MIN ((U16) (1u << 8)) -#define SIG_MAX ((U16) (1u << 16 - 1)) +#define SIG_MAX ((U16) ((1u << 16) - 1)) #define SIG_NBR (SIG_MAX - SIG_MIN + 1) -#define SIG_WIZ ((U16) (1u << 8 - 1)) +#define SIG_WIZ ((U16) ((1u << 8) - 1)) /* ... Generate signatures ................................................. */ @@ -183,7 +218,6 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) { STATIC SV *vmg_data_get(SV *sv, U16 sig) { MAGIC *mg, *moremagic; - MGWIZ *w; if (SvTYPE(sv) >= SVt_PVMG) { for (mg = SvMAGIC(sv); mg; mg = moremagic) { @@ -198,6 +232,7 @@ STATIC SV *vmg_data_get(SV *sv, U16 sig) { /* ... Magic cast/dispell .................................................. */ +#if VMG_UVAR STATIC I32 vmg_svt_val(pTHX_ IV, SV *); STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) { @@ -210,6 +245,7 @@ STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) Safefree(mg->mg_ptr); Safefree(mg); } +#endif /* VMG_UVAR */ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { #define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A)) @@ -274,8 +310,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { } if (add_uvar) { - sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &uf, sizeof(uf)); - vmg_mg_magical(sv); + vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf)); } } @@ -296,15 +331,19 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) { moremagic = mg->mg_moremagic; if (mg->mg_type == PERL_MAGIC_ext) { -#if VMG_UVAR - MGWIZ *w = SV2MGWIZ(mg->mg_ptr); - if (w->uvar) { ++uvars; } -#endif /* VMG_UVAR */ if (mg->mg_private == sig) { #if VMG_UVAR - if (!w->uvar) { uvars = 0; } /* Short-circuit uvar deletion. */ + /* If the current has no uvar, short-circuit uvar deletion. */ + uvars = (SV2MGWIZ(mg->mg_ptr)->uvar) ? (uvars + 1) : 0; #endif /* VMG_UVAR */ break; +#if VMG_UVAR + } else if ((mg->mg_private >= SIG_MIN) && + (mg->mg_private <= SIG_MAX) && + SV2MGWIZ(mg->mg_ptr)->uvar) { + ++uvars; + /* We can't break here since we need to find the ext magic to delete. */ +#endif /* VMG_UVAR */ } } } @@ -326,7 +365,10 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { /* mg was the first ext magic in the chain that had uvar */ for (mg = moremagic; mg; mg = mg->mg_moremagic) { - if ((mg->mg_type == PERL_MAGIC_ext) && SV2MGWIZ(mg->mg_ptr)->uvar) { + if ((mg->mg_type == PERL_MAGIC_ext) && + (mg->mg_private >= SIG_MIN) && + (mg->mg_private <= SIG_MAX) && + SV2MGWIZ(mg->mg_ptr)->uvar) { ++uvars; break; } @@ -345,6 +387,7 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { /* Revert the original uvar magic. */ uf[0] = uf[1]; Renew(uf, 1, struct ufuncs); + mg->mg_ptr = (char *) uf; mg->mg_len = sizeof(struct ufuncs); } else { /* Remove the uvar magic. */ @@ -359,9 +402,11 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { /* ... svt callbacks ....................................................... */ -STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) { -#define vmg_cb_call(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D)) +STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) { + va_list ap; + SV *svr; int ret; + unsigned int i; dSP; int count; @@ -370,8 +415,15 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) { SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newRV_inc(sv))); - if (data) { XPUSHs(data); } + EXTEND(SP, args + 2); + PUSHs(sv_2mortal(newRV_inc(sv))); + PUSHs(data ? data : &PL_sv_undef); + va_start(ap, args); + for (i = 0; i < args; ++i) { + SV *sva = va_arg(ap, SV *); + PUSHs(sva ? sva : &PL_sv_undef); + } + va_end(ap); PUTBACK; count = call_sv(cb, G_SCALAR); @@ -379,7 +431,8 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) { SPAGAIN; if (count != 1) { croak("Callback needs to return 1 scalar\n"); } - ret = POPi; + svr = POPs; + ret = SvOK(svr) ? SvIV(svr) : 0; PUTBACK; @@ -389,48 +442,21 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) { return ret; } -#if MGf_COPY || VMG_UVAR -STATIC int vmg_cb_call2(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2) { -#define vmg_cb_call2(I, S, D, S2) vmg_cb_call2(aTHX_ (I), (S), (D), (S2)) - int ret; - - dSP; - int count; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newRV_inc(sv))); - XPUSHs(data ? data : &PL_sv_undef); - if (sv2) { XPUSHs(sv2); } - PUTBACK; - - count = call_sv(cb, G_SCALAR); - - SPAGAIN; - - if (count != 1) { croak("Callback needs to return 1 scalar\n"); } - ret = POPi; - - PUTBACK; - - FREETMPS; - LEAVE; - - return ret; -} -#endif /* MGf_COPY || VMG_UVAR */ +#define vmg_cb_call1(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), 0) +#define vmg_cb_call2(I, S, D, S2) vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2)) +#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3)) STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj); + return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj); } STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj); + return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj); } STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { + SV *svr; + I32 len; U32 ret; dSP; @@ -440,10 +466,15 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newRV_inc(sv))); - XPUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); + EXTEND(SP, 3); + PUSHs(sv_2mortal(newRV_inc(sv))); + PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); if (SvTYPE(sv) == SVt_PVAV) { - XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1))); + len = av_len((AV *) sv) + 1; + mPUSHi(len); + } else { + len = 1; + PUSHs(&PL_sv_undef); } PUTBACK; @@ -452,7 +483,8 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SPAGAIN; if (count != 1) { croak("Callback needs to return 1 scalar\n"); } - ret = POPi; + svr = POPs; + ret = SvOK(svr) ? SvUV(svr) : len; PUTBACK; @@ -463,7 +495,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { } STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { - return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj); + return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj); } STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { @@ -471,16 +503,37 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { SvREFCNT_inc(sv); /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and * mg->mg_ptr reference count */ - return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj); + return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj); } #if MGf_COPY -STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, int namelen) { - return vmg_cb_call2(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, nsv); +STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, +# if (VMG_PERL_PATCHLEVEL >= 33256) || (!VMG_PERL_PATCHLEVEL && PERL_API_VERSION_GE(5, 11, 0)) + I32 keylen +# else + int keylen +# endif + ) { + SV *keysv; + int ret; + + if (keylen == HEf_SVKEY) { + keysv = (SV *) key; + } else { + keysv = newSVpvn(key, keylen); + } + + ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv); + + if (keylen != HEf_SVKEY) { + SvREFCNT_dec(keysv); + } + + return ret; } #endif /* MGf_COPY */ -#if MGf_DUP +#if 0 /* MGf_DUP */ STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { return 0; } @@ -488,7 +541,7 @@ STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { #if MGf_LOCAL STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { - return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj); + return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj); } #endif /* MGf_LOCAL */ @@ -513,20 +566,21 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { || (mg->mg_private < SIG_MIN) || (mg->mg_private > SIG_MAX)) { continue; } w = SV2MGWIZ(mg->mg_ptr); + if (!w->uvar) { continue; } switch (action) { case 0: - vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); + if (w->cb_fetch) { vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); } break; case HV_FETCH_ISSTORE: case HV_FETCH_LVALUE: case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE): - vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); + if (w->cb_store) { vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); } break; case HV_FETCH_ISEXISTS: - vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); + if (w->cb_exists) { vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); } break; case HV_DELETE: - vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key); + if (w->cb_delete) { vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key); } break; } } @@ -563,10 +617,10 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { #endif /* MGf_COPY */ #if MGf_DUP if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); } -#endif /* MGf_COPY */ +#endif /* MGf_DUP */ #if MGf_LOCAL if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); } -#endif /* MGf_COPY */ +#endif /* MGf_LOCAL */ #if VMG_UVAR if (w->cb_fetch != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); } if (w->cb_store != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); } @@ -593,7 +647,7 @@ STATIC MGVTBL vmg_wizard_vtbl = { #endif /* MGf_DUP */ #if MGf_LOCAL NULL, /* local */ -#endif /* MGf_DUP */ +#endif /* MGf_LOCAL */ }; STATIC const char vmg_invalid_wiz[] = "Invalid wizard object"; @@ -657,6 +711,12 @@ BOOT: newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP)); newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL)); newCONSTSUB(stash, "VMG_UVAR", newSVuv(VMG_UVAR)); + newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN", + newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN)); + newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR", + newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR)); + newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN", + newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN)); } SV *_wizard(...) @@ -693,7 +753,7 @@ CODE: if (SvOK(svsig)) { SV **old; sig = vmg_sv2sig(svsig); - if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + if ((old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0))) { ST(0) = sv_2mortal(newRV_inc(*old)); XSRETURN(1); } @@ -715,7 +775,10 @@ CODE: VMG_SET_SVT_CB(ST(i++), copy); #endif /* MGf_COPY */ #if MGf_DUP - VMG_SET_SVT_CB(ST(i++), dup); + /* VMG_SET_SVT_CB(ST(i++), dup); */ + i++; + t->svt_dup = NULL; + w->cb_dup = NULL; #endif /* MGf_DUP */ #if MGf_LOCAL VMG_SET_SVT_CB(ST(i++), local); @@ -774,7 +837,7 @@ CODE: char buf[8]; SV **old; U16 sig = vmg_sv2sig(wiz); - if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) { + if ((old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0))) { wiz = *old; } else { XSRETURN_UNDEF; @@ -818,7 +881,7 @@ CODE: } data = vmg_data_get(SvRV(sv), sig); if (!data) { XSRETURN_UNDEF; } - ST(0) = newSVsv(data); + ST(0) = data; XSRETURN(1); SV *dispell(SV *sv, SV *wiz)