X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=0ecf6933caf6975cf3b3388152a4b25b3b63cf4a;hb=6e42ee234deb79fad1c91703e5a7ec3bd8bc47f3;hp=b62d5f7b116b8b6766707cbcd1d0c6be9f74c146;hpb=b43ca6c10beabb678914eb7845fed4abda6cd852;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/Magic.xs b/Magic.xs index b62d5f7..0ecf693 100644 --- a/Magic.xs +++ b/Magic.xs @@ -12,10 +12,6 @@ #define __PACKAGE__ "Variable::Magic" -#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)))))) - #ifndef VMG_PERL_PATCHLEVEL # ifdef PERL_PATCHNUM # define VMG_PERL_PATCHLEVEL PERL_PATCHNUM @@ -24,9 +20,11 @@ # endif #endif -#define VMG_HAS_PERL_OR(P, R, V, S) ((VMG_PERL_PATCHLEVEL >= (P)) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE((R), (V), (S)))) +#define VMG_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) + +#define VMG_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) -#define VMG_HAS_PERL_AND(P, R, V, S) (PERL_VERSION_GE((R), (V), (S)) && (!VMG_PERL_PATCHLEVEL || (VMG_PERL_PATCHLEVEL >= (P)))) +#define VMG_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (VMG_PERL_PATCHLEVEL >= (P) || (!VMG_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) /* --- Threads and multiplicity -------------------------------------------- */ @@ -38,23 +36,32 @@ # define dNOOP #endif -#if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) -# define VMG_MULTIPLICITY 1 -# ifndef tTHX -# define tTHX PerlInterpreter* +#ifndef VMG_MULTIPLICITY +# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# define VMG_MULTIPLICITY 1 +# else +# define VMG_MULTIPLICITY 0 # endif -#else -# define VMG_MULTIPLICITY 0 +#endif +#if VMG_MULTIPLICITY && !defined(tTHX) +# define tTHX PerlInterpreter* #endif -#if VMG_MULTIPLICITY && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && defined(MY_CXT_CLONE) +#if VMG_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)) # define VMG_THREADSAFE 1 +# ifndef MY_CXT_CLONE +# define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +# endif #else # define VMG_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT -# define MY_CXT vmg_globaldata +# define MY_CXT vmg_globaldata # undef START_MY_CXT # define START_MY_CXT STATIC my_cxt_t MY_CXT; # undef MY_CXT_INIT @@ -63,6 +70,19 @@ # define MY_CXT_CLONE NOOP #endif +#if VMG_THREADSAFE + +STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { +#define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O)) + CLONE_PARAMS param; + param.stashes = NULL; /* don't need it unless sv is a PVHV */ + param.flags = 0; + param.proto_perl = owner; + return sv_dup(sv, ¶m); +} + +#endif /* VMG_THREADSAFE */ + /* --- Compatibility ------------------------------------------------------- */ #ifndef Newx @@ -93,27 +113,51 @@ # define MGf_LOCAL 0 #endif -/* uvar magic and Hash::Util::FieldHash were commited with p28419 */ -#if VMG_HAS_PERL_AND(28419, 5, 9, 4) +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser) +# ifndef PL_error_count +# define PL_error_count PL_parser->error_count +# endif +#else +# ifndef PL_error_count +# define PL_error_count PL_Ierror_count +# endif +#endif + +/* uvar magic and Hash::Util::FieldHash were commited with 28419 */ +#if VMG_HAS_PERL_MAINT(5, 9, 4, 28419) || VMG_HAS_PERL(5, 10, 0) # define VMG_UVAR 1 #else # define VMG_UVAR 0 #endif -#if !defined(VMG_COMPAT_ARRAY_PUSH_NOLEN) && VMG_HAS_PERL_OR(25854, 5, 9, 3) -# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1 +/* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160 */ +#ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN +# if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0) +# define VMG_COMPAT_ARRAY_PUSH_NOLEN 1 +# else +# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 +# endif +#endif + +/* Applied to dev-5.11 as 34908 */ +#if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) +# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1 #else -# define VMG_COMPAT_ARRAY_PUSH_NOLEN 0 +# define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0 #endif -/* since 5.9.5 - see #43357 */ -#if VMG_HAS_PERL_OR(31473, 5, 9, 5) +/* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */ +#if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0) # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1 #else # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0 #endif -#if VMG_HAS_PERL_OR(32969, 5, 11, 0) +#if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1 #else # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0 @@ -127,7 +171,6 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) { 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 { @@ -148,10 +191,7 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) { #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION -typedef struct { - HV *wizz; - U16 count; -} my_cxt_t; +typedef HV * my_cxt_t; START_MY_CXT @@ -172,7 +212,7 @@ STATIC U16 vmg_gensig(pTHX) { do { sig = SIG_NBR * Drand01() + SIG_MIN; - } while (hv_exists(MY_CXT.wizz, buf, sprintf(buf, "%u", sig))); + } while (hv_exists(MY_CXT, buf, sprintf(buf, "%u", sig))); return sig; } @@ -213,7 +253,6 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) { I32 i, alen = (args == NULL) ? 0 : av_len(args); dSP; - int count; ENTER; SAVETMPS; @@ -225,16 +264,15 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) { PUSHs(*av_fetch(args, i, 0)); PUTBACK; - count = call_sv(ctor, G_SCALAR); + call_sv(ctor, G_SCALAR); SPAGAIN; - if (count != 1) { croak("Callback needs to return 1 scalar\n"); } nsv = POPs; -#if PERL_VERSION_LE(5, 8, 2) - nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */ -#else +#if VMG_HAS_PERL(5, 8, 3) SvREFCNT_inc(nsv); /* Or it will be destroyed in FREETMPS */ +#else + nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */ #endif PUTBACK; @@ -299,7 +337,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { if (w->cb_copy) mg->mg_flags |= MGf_COPY; #endif /* MGf_COPY */ -#if MGf_DUP +#if 0 /* MGf_DUP */ if (w->cb_dup) mg->mg_flags |= MGf_DUP; #endif /* MGf_DUP */ @@ -432,14 +470,18 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) { /* ... svt callbacks ....................................................... */ -STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) { +#define VMG_CB_CALL_ARGS_MASK 15 +#define VMG_CB_CALL_EVAL 16 + +STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){ va_list ap; SV *svr; int ret; unsigned int i; + unsigned int args = flags & VMG_CB_CALL_ARGS_MASK; + unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0; dSP; - int count; ENTER; SAVETMPS; @@ -448,7 +490,7 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) { EXTEND(SP, args + 2); PUSHs(sv_2mortal(newRV_inc(sv))); PUSHs(data ? data : &PL_sv_undef); - va_start(ap, args); + va_start(ap, flags); for (i = 0; i < args; ++i) { SV *sva = va_arg(ap, SV *); PUSHs(sva ? sva : &PL_sv_undef); @@ -456,23 +498,24 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) { va_end(ap); PUTBACK; - count = call_sv(cb, G_SCALAR); + call_sv(cb, G_SCALAR | eval); SPAGAIN; - - if (count != 1) { croak("Callback needs to return 1 scalar\n"); } + if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV)) + ++PL_error_count; svr = POPs; ret = SvOK(svr) ? SvIV(svr) : 0; - PUTBACK; FREETMPS; LEAVE; + return ret; } #define vmg_cb_call1(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), 0) +#define vmg_cb_call1e(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL) #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)) @@ -486,12 +529,14 @@ STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) { STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { SV *svr; - I32 len; + I32 len, has_array; U32 ret; dSP; int count; + has_array = SvTYPE(sv) == SVt_PVAV; + ENTER; SAVETMPS; @@ -499,11 +544,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { EXTEND(SP, 3); PUSHs(sv_2mortal(newRV_inc(sv))); PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef); - if (SvTYPE(sv) == SVt_PVAV) { + if (has_array) { len = av_len((AV *) sv) + 1; mPUSHi(len); } else { - len = 1; + len = 0; PUSHs(&PL_sv_undef); } PUTBACK; @@ -511,17 +556,14 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) { count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR); SPAGAIN; - - if (count != 1) { croak("Callback needs to return 1 scalar\n"); } svr = POPs; ret = SvOK(svr) ? SvUV(svr) : len; - PUTBACK; FREETMPS; LEAVE; - return ret - 1; + return has_array ? ret - 1 : ret; } STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { @@ -531,14 +573,20 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { /* So that it can survive tmp cleanup in vmg_cb_call */ SvREFCNT_inc(sv); +#if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686) + /* The previous magic tokens were freed but the magic chain wasn't updated, so + * if you access the sv from the callback the old deleted magics will trigger + * and cause memory misreads. Change 32686 solved it that way : */ + SvMAGIC_set(sv, mg); +#endif /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and * mg->mg_ptr reference count */ - return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj); + return vmg_cb_call1e(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 *key, -# if VMG_HAS_PERL_AND(33256, 5, 11, 0) +# if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) I32 keylen # else int keylen @@ -624,7 +672,6 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { char buf[8]; MGWIZ *w; - dMY_CXT; if (PL_dirty) /* during global destruction, the context is already freed */ return 0; @@ -636,8 +683,10 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { w->owner = NULL; #endif /* VMG_MULTIPLICITY */ - if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) { - --MY_CXT.count; + { + dMY_CXT; + if (hv_delete(MY_CXT, buf, sprintf(buf, "%u", w->sig), 0) != wiz) + return 0; } SvFLAGS(wiz) |= SVf_BREAK; FREETMPS; @@ -651,7 +700,7 @@ STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) { #if MGf_COPY if (w->cb_copy != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); } #endif /* MGf_COPY */ -#if MGf_DUP +#if 0 /* MGf_DUP */ if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); } #endif /* MGf_DUP */ #if MGf_LOCAL @@ -688,7 +737,6 @@ STATIC MGVTBL vmg_wizard_vtbl = { }; STATIC const char vmg_invalid_wiz[] = "Invalid wizard object"; -STATIC const char vmg_invalid_sv[] = "Invalid variable"; STATIC const char vmg_invalid_sig[] = "Invalid numeric signature"; STATIC const char vmg_wrongargnum[] = "Wrong number of arguments"; STATIC const char vmg_toomanysigs[] = "Too many magic signatures used"; @@ -726,11 +774,11 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) { croak(vmg_invalid_wiz); } - dMY_CXT; - - if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) - sig = 0; - + { + dMY_CXT; + if (!hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0)) + sig = 0; + } return sig; } @@ -753,10 +801,11 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) { croak(vmg_invalid_wiz); } - dMY_CXT; - - return (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) - ? *old : NULL; + { + dMY_CXT; + return (old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0)) + ? *old : NULL; + } } #define VMG_SET_CB(S, N) \ @@ -773,20 +822,11 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) { w->cb_ ## N = NULL; \ } -#if VMG_MULTIPLICITY - -STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { -#define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O)) - CLONE_PARAMS param; - param.stashes = NULL; /* don't need it unless sv is a PVHV */ - param.flags = 0; - param.proto_perl = owner; - return sv_dup(sv, ¶m); -} +#if VMG_THREADSAFE #define VMG_CLONE_CB(N) \ - z->cb_ ## N = (w->cb_ ## N) ? newRV_noinc(vmg_clone(SvRV(w->cb_ ## N), \ - w->owner)) \ + z->cb_ ## N = (w->cb_ ## N) ? newRV_inc(vmg_clone(SvRV(w->cb_ ## N), \ + w->owner)) \ : NULL; STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) { @@ -827,7 +867,7 @@ STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) { return z; } -#endif /* VMG_MULTIPLICITY */ +#endif /* VMG_THREADSAFE */ /* --- XS ------------------------------------------------------------------ */ @@ -839,9 +879,8 @@ BOOT: { HV *stash; MY_CXT_INIT; - MY_CXT.wizz = newHV(); - hv_iterinit(MY_CXT.wizz); /* Allocate iterator */ - MY_CXT.count = 0; + MY_CXT = newHV(); + hv_iterinit(MY_CXT); /* Allocate iterator */ stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "SIG_MIN", newSVuv(SIG_MIN)); newCONSTSUB(stash, "SIG_MAX", newSVuv(SIG_MAX)); @@ -852,6 +891,8 @@ BOOT: 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_UNSHIFT_NOLEN_VOID", + newSVuv(VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID)); newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR", newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR)); newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN", @@ -865,22 +906,19 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: HV *hv; - U16 count; CODE: #if VMG_THREADSAFE { HE *key; dMY_CXT; - count = MY_CXT.count; hv = newHV(); hv_iterinit(hv); /* Allocate iterator */ - hv_iterinit(MY_CXT.wizz); - while (key = hv_iternext(MY_CXT.wizz)) { + hv_iterinit(MY_CXT); + while ((key = hv_iternext(MY_CXT))) { STRLEN len; char *sig = HePV(key, len); SV *sv; MAGIC *mg; - MGWIZ *w; sv = MGWIZ2SV(vmg_wizard_clone(SV2MGWIZ(HeVAL(key)))); mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0); mg->mg_private = SIG_WIZ; @@ -890,8 +928,7 @@ CODE: } { MY_CXT_CLONE; - MY_CXT.wizz = hv; - MY_CXT.count = count; + MY_CXT = hv; } #endif /* VMG_THREADSAFE */ @@ -929,12 +966,12 @@ 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, buf, sprintf(buf, "%u", sig), 0))) { ST(0) = sv_2mortal(newRV_inc(*old)); XSRETURN(1); } } else { - if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); } + if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); } sig = vmg_gensig(); } @@ -980,8 +1017,7 @@ CODE: mg->mg_private = SIG_WIZ; SvREADONLY_on(sv); - hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0); - ++MY_CXT.count; + hv_store(MY_CXT, buf, sprintf(buf, "%u", sig), sv, 0); RETVAL = newRV_noinc(sv); OUTPUT: @@ -991,7 +1027,7 @@ SV *gensig() PROTOTYPE: CODE: dMY_CXT; - if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); } + if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); } RETVAL = newSVuv(vmg_gensig()); OUTPUT: RETVAL