X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=69ad981a726d862427de4e88d96de34b3a689432;hb=670e590caf3db942b5e7feddc1e86669f9f46294;hp=44d4c89331b76978793645243ff53e31afe4f2d7;hpb=3b3cd1c3a8f372f441f38bddbd09fee34919b391;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/Magic.xs b/Magic.xs index 44d4c89..69ad981 100644 --- a/Magic.xs +++ b/Magic.xs @@ -49,15 +49,22 @@ #endif #ifndef VMG_MULTIPLICITY -# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# if defined(MULTIPLICITY) # define VMG_MULTIPLICITY 1 # else # define VMG_MULTIPLICITY 0 # endif #endif +#if VMG_MULTIPLICITY +# ifndef PERL_IMPLICIT_CONTEXT +# error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT +# endif +#endif #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 VMG_THREADSAFE +# define VMG_THREADSAFE 1 +# endif # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ @@ -66,6 +73,7 @@ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else +# undef VMG_THREADSAFE # define VMG_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP @@ -125,6 +133,20 @@ # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif +#ifndef OP_NAME +# define OP_NAME(O) (PL_op_name[(O)->op_type]) +#endif + +#ifndef OP_CLASS +# define OP_CLASS(O) (PL_opargs[(O)->op_type] & OA_CLASS_MASK) +#endif + +#ifdef DEBUGGING +# define VMG_ASSERT(C) assert(C) +#else +# define VMG_ASSERT(C) +#endif + /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only * enable them on 5.10 */ #if VMG_HAS_PERL(5, 10, 0) @@ -377,6 +399,9 @@ typedef enum { OPc_COP, #if VMG_HAS_PERL(5, 21, 5) OPc_METHOP, +#endif +#if VMG_HAS_PERL(5, 21, 7) + OPc_UNOP_AUX, #endif OPc_MAX } opclass; @@ -396,18 +421,27 @@ static const char *const vmg_opclassnames[] = { "B::COP", #if VMG_HAS_PERL(5, 21, 5) "B::METHOP", +#endif +#if VMG_HAS_PERL(5, 21, 7) + "B::UNOP_AUX", #endif NULL }; -static opclass vmg_opclass(const OP *o) { +static opclass vmg_opclass(pTHX_ const OP *o) { +#define vmg_opclass(O) vmg_opclass(aTHX_ (O)) #if 0 if (!o) return OPc_NULL; #endif - if (o->op_type == 0) + if (o->op_type == 0) { +#if VMG_HAS_PERL(5, 21, 7) + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + return OPc_COP; +#endif return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; + } if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); @@ -430,7 +464,7 @@ static opclass vmg_opclass(const OP *o) { return OPc_PADOP; #endif - switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { + switch (OP_CLASS(o)) { case OA_BASEOP: return OPc_BASEOP; case OA_UNOP: @@ -448,7 +482,16 @@ static opclass vmg_opclass(const OP *o) { case OA_PADOP: return OPc_PADOP; case OA_PVOP_OR_SVOP: - return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP; + return ( +#if VMG_HAS_PERL(5, 13, 7) + (o->op_type != OP_CUSTOM) && +#endif + (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))) +#if defined(USE_ITHREADS) && VMG_HAS_PERL(5, 8, 9) + ? OPc_PADOP : OPc_PVOP; +#else + ? OPc_SVOP : OPc_PVOP; +#endif case OA_LOOP: return OPc_LOOP; case OA_COP: @@ -472,6 +515,10 @@ static opclass vmg_opclass(const OP *o) { #if VMG_HAS_PERL(5, 21, 5) case OA_METHOP: return OPc_METHOP; +#endif +#if VMG_HAS_PERL(5, 21, 7) + case OA_UNOP_AUX: + return OPc_UNOP_AUX; #endif } @@ -480,9 +527,8 @@ static opclass vmg_opclass(const OP *o) { /* --- Error messages ------------------------------------------------------ */ -static const char vmg_invalid_wiz[] = "Invalid wizard object"; -static const char vmg_wrongargnum[] = "Wrong number of arguments"; -static const char vmg_argstorefailed[] = "Error while storing arguments"; +static const char vmg_invalid_wiz[] = "Invalid wizard object"; +static const char vmg_wrongargnum[] = "Wrong number of arguments"; /* --- Context-safe global data -------------------------------------------- */ @@ -1110,8 +1156,12 @@ static SV *vmg_op_info(pTHX_ unsigned int opinfo) { switch (opinfo) { case VMG_OP_INFO_NAME: { - OPCODE t = PL_op->op_type; - return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t])); + const char *name; + STRLEN name_len; + OPCODE t = PL_op->op_type; + name = OP_NAME(PL_op); + name_len = (t == OP_CUSTOM) ? strlen(name) : vmg_op_name_len[t]; + return sv_2mortal(newSVpvn(name, name_len)); } case VMG_OP_INFO_OBJECT: { dMY_CXT; @@ -1238,11 +1288,18 @@ static int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); + if (SvROK(svr)) + SvREFCNT_inc(svr); + else + svr = NULL; PUTBACK; FREETMPS; LEAVE; + if (svr && !SvTEMP(svr)) + sv_2mortal(svr); + if (chain) { vmg_dispell_guard_new(*chain); *chain = NULL; @@ -1740,68 +1797,155 @@ static I32 vmg_svt_val(pTHX_ IV action, SV *sv) { #endif /* VMG_UVAR */ -/* --- Macros for the XS section ------------------------------------------- */ +/* --- Module setup/teardown ----------------------------------------------- */ -#ifdef CvISXSUB -# define VMG_CVOK(C) \ - ((CvISXSUB(C) ? (void *) CvXSUB(C) : (void *) CvROOT(C)) ? 1 : 0) -#else -# define VMG_CVOK(C) (CvROOT(C) || CvXSUB(C)) -#endif +#if VMG_THREADSAFE -#define VMG_CBOK(S) ((SvTYPE(S) == SVt_PVCV) ? VMG_CVOK(S) : SvOK(S)) +static I32 vmg_loaded = 0; -#define VMG_SET_CB(S, N) { \ - SV *cb = (S); \ - if (SvOK(cb) && SvROK(cb)) { \ - cb = SvRV(cb); \ - if (VMG_CBOK(cb)) \ - SvREFCNT_inc_simple_void(cb); \ - else \ - cb = NULL; \ - } else { \ - cb = NULL; \ - } \ - w->cb_ ## N = cb; \ +/* We must use preexistent global mutexes or we will never be able to destroy + * them. */ +# if VMG_HAS_PERL(5, 9, 3) +# define VMG_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) +# define VMG_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) +# else +# define VMG_LOADED_LOCK OP_REFCNT_LOCK +# define VMG_LOADED_UNLOCK OP_REFCNT_UNLOCK +# endif + +static void vmg_global_teardown_late_locked(pTHX) { +#define vmg_global_teardown_late_locked() vmg_global_teardown_late_locked(aTHX) + MUTEX_DESTROY(&vmg_op_name_init_mutex); + MUTEX_DESTROY(&vmg_vtable_refcount_mutex); + + return; } -#define VMG_SET_SVT_CB(S, N) { \ - SV *cb = (S); \ - if (SvOK(cb) && SvROK(cb)) { \ - cb = SvRV(cb); \ - if (VMG_CBOK(cb)) { \ - t->svt_ ## N = vmg_svt_ ## N; \ - SvREFCNT_inc_simple_void(cb); \ - } else { \ - t->svt_ ## N = vmg_svt_ ## N ## _noop; \ - cb = NULL; \ - } \ - } else { \ - t->svt_ ## N = NULL; \ - cb = NULL; \ - } \ - w->cb_ ## N = cb; \ +static int vmg_global_teardown_free(pTHX_ SV *sv, MAGIC *mg) { + VMG_LOADED_LOCK; + + if (vmg_loaded == 0) + vmg_global_teardown_late_locked(); + + VMG_LOADED_UNLOCK; + + return 0; } -/* --- XS ------------------------------------------------------------------ */ +static MGVTBL vmg_global_teardown_vtbl = { + 0, + 0, + 0, + 0, + vmg_global_teardown_free +#if MGf_COPY + , 0 +#endif +#if MGf_DUP + , 0 +#endif +#if MGf_LOCAL + , 0 +#endif +}; -MODULE = Variable::Magic PACKAGE = Variable::Magic +static signed char vmg_destruct_level(pTHX) { +#define vmg_destruct_level() vmg_destruct_level(aTHX) + signed char lvl; -PROTOTYPES: ENABLE + lvl = PL_perl_destruct_level; -BOOT: -{ +#ifdef DEBUGGING + { + const char *s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { + int i; +#if VMG_HAS_PERL(5, 21, 3) + if (strEQ(s, "-1")) { + i = -1; + } else { +# if VMG_HAS_PERL(5, 21, 10) + UV uv; + if (Perl_grok_atoUV(s, &uv, NULL) && uv <= INT_MAX) + i = (int) uv; + else + i = 0; +# else /* VMG_HAS_PERL(5, 21, 3) && !VMG_HAS_PERL(5, 21, 10) */ + i = Perl_grok_atou(s, NULL); +# endif + } +#else /* !VMG_HAS_PERL(5, 21, 3) */ + i = atoi(s); +#endif + if (lvl < i) + lvl = i; + } + } +#endif + + return lvl; +} + +#endif /* VMG_THREADSAFE */ + +static void vmg_teardown(pTHX_ void *param) { + dMY_CXT; + +#if VMG_THREADSAFE + VMG_LOADED_LOCK; + + if (vmg_loaded == 1) { + vmg_loaded = 0; + if (vmg_destruct_level() == 0) { + vmg_global_teardown_late_locked(); + } else { + if (!PL_strtab) + PL_strtab = newHV(); + vmg_sv_magicext((SV *) PL_strtab, NULL, &vmg_global_teardown_vtbl, NULL, 0); + } + } else { + VMG_ASSERT(vmg_loaded > 1); + --vmg_loaded; + } + + VMG_LOADED_UNLOCK; +#endif + + if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { + vmg_magic_chain_free(MY_CXT.freed_tokens, NULL); + MY_CXT.freed_tokens = NULL; + } + + return; +} + +static void vmg_setup(pTHX) { +#define vmg_setup() vmg_setup(aTHX) HV *stash; int c; - MY_CXT_INIT; + +#if VMG_THREADSAFE + VMG_LOADED_LOCK; + + if (vmg_loaded == 0) { + MUTEX_INIT(&vmg_vtable_refcount_mutex); + MUTEX_INIT(&vmg_op_name_init_mutex); + vmg_loaded = 1; + } else { + VMG_ASSERT(vmg_loaded > 0); + ++vmg_loaded; + } + + VMG_LOADED_UNLOCK; +#endif + for (c = OPc_NULL; c < OPc_MAX; ++c) MY_CXT.b__op_stashes[c] = NULL; MY_CXT.depth = 0; MY_CXT.freed_tokens = NULL; - /* XS doesn't like a blank line here */ #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE vmg_trampoline_init(&MY_CXT.propagate_errsv, vmg_pp_propagate_errsv); #endif @@ -1809,12 +1953,6 @@ BOOT: vmg_trampoline_init(&MY_CXT.reset_rmg, vmg_pp_reset_rmg); #endif - /* XS doesn't like a blank line here */ -#if VMG_THREADSAFE - MUTEX_INIT(&vmg_vtable_refcount_mutex); - MUTEX_INIT(&vmg_op_name_init_mutex); -#endif - stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY)); newCONSTSUB(stash, "MGf_DUP", newSVuv(MGf_DUP)); @@ -1842,6 +1980,64 @@ BOOT: newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE)); newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME)); newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT)); + + call_atexit(vmg_teardown, NULL); + + return; +} + +/* --- Macros for the XS section ------------------------------------------- */ + +#ifdef CvISXSUB +# define VMG_CVOK(C) \ + ((CvISXSUB(C) ? (void *) CvXSUB(C) : (void *) CvROOT(C)) ? 1 : 0) +#else +# define VMG_CVOK(C) (CvROOT(C) || CvXSUB(C)) +#endif + +#define VMG_CBOK(S) ((SvTYPE(S) == SVt_PVCV) ? VMG_CVOK(S) : SvOK(S)) + +#define VMG_SET_CB(S, N) { \ + SV *cb = (S); \ + if (SvOK(cb) && SvROK(cb)) { \ + cb = SvRV(cb); \ + if (VMG_CBOK(cb)) \ + SvREFCNT_inc_simple_void(cb); \ + else \ + cb = NULL; \ + } else { \ + cb = NULL; \ + } \ + w->cb_ ## N = cb; \ +} + +#define VMG_SET_SVT_CB(S, N) { \ + SV *cb = (S); \ + if (SvOK(cb) && SvROK(cb)) { \ + cb = SvRV(cb); \ + if (VMG_CBOK(cb)) { \ + t->svt_ ## N = vmg_svt_ ## N; \ + SvREFCNT_inc_simple_void(cb); \ + } else { \ + t->svt_ ## N = vmg_svt_ ## N ## _noop; \ + cb = NULL; \ + } \ + } else { \ + t->svt_ ## N = NULL; \ + cb = NULL; \ + } \ + w->cb_ ## N = cb; \ +} + +/* --- XS ------------------------------------------------------------------ */ + +MODULE = Variable::Magic PACKAGE = Variable::Magic + +PROTOTYPES: ENABLE + +BOOT: +{ + vmg_setup(); } #if VMG_THREADSAFE @@ -1870,6 +2066,10 @@ PPCODE: } MY_CXT.depth = old_depth; MY_CXT.freed_tokens = NULL; + VMG_LOADED_LOCK; + VMG_ASSERT(vmg_loaded > 0); + ++vmg_loaded; + VMG_LOADED_UNLOCK; } XSRETURN(0);