X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=blobdiff_plain;f=Plugin.xs;h=ec8c0fe3094a19a2cd8d5dd0e5f83555c031ccf3;hp=04557561946bfad91e7bce3bef0cd3bbd72849a9;hb=8841074697e50dc9be0faf100e25e540968a2d9a;hpb=24c4ef9bba54bcbaecc3cc15bbc6b3fe866a1c63 diff --git a/Plugin.xs b/Plugin.xs index 0455756..ec8c0fe 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -19,6 +19,11 @@ /* ... Thread safety and multiplicity ...................................... */ +/* Safe unless stated otherwise in Makefile.PL */ +#ifndef REP_FORKSAFE +# define REP_FORKSAFE 1 +#endif + #ifndef REP_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define REP_MULTIPLICITY 1 @@ -61,7 +66,7 @@ typedef struct { SV *comp; SV *exec; #if REP_WORKAROUND_REQUIRE_PROPAGATION - IV cxreq; + IV require_tag; #endif } rep_hint_t; @@ -93,44 +98,41 @@ typedef struct { START_MY_CXT -STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) { -#define rep_clone(S, O) rep_clone(aTHX_ (S), (O)) - CLONE_PARAMS param; - AV *stashes = NULL; - SV *dupsv; - - if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) - stashes = newAV(); - - param.stashes = stashes; - param.flags = 0; - param.proto_perl = owner; - - dupsv = sv_dup(sv, ¶m); - - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } - - return SvREFCNT_inc_simple(dupsv); -} +typedef struct { + ptable *tbl; +#if REP_HAS_PERL(5, 13, 2) + CLONE_PARAMS *params; +#else + CLONE_PARAMS params; +#endif +} rep_ptable_clone_ud; + +#if REP_HAS_PERL(5, 13, 2) +# define rep_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params = Perl_clone_params_new((O), aTHX) +# define rep_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) +# define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) +#else +# define rep_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params.stashes = newAV(); \ + (U).params.flags = 0; \ + (U).params.proto_perl = (O) +# define rep_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) +# define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) +#endif STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { - my_cxt_t *ud = ud_; + rep_ptable_clone_ud *ud = ud_; rep_hint_t *h1 = ent->val; rep_hint_t *h2; - if (ud->owner == aTHX) - return; - - h2 = PerlMemShared_malloc(sizeof *h2); - h2->comp = rep_clone(h1->comp, ud->owner); - SvREFCNT_inc_simple_void(h2->comp); - h2->exec = rep_clone(h1->exec, ud->owner); - SvREFCNT_inc_simple_void(h2->exec); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->comp = rep_dup_inc(h1->comp, ud); + h2->exec = rep_dup_inc(h1->exec, ud); #if REP_WORKAROUND_REQUIRE_PROPAGATION - h2->cxreq = h1->cxreq; + h2->require_tag = PTR2IV(rep_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); #endif ptable_store(ud->tbl, ent->key, h2); @@ -160,40 +162,68 @@ STATIC SV *rep_validate_callback(SV *code) { #if REP_WORKAROUND_REQUIRE_PROPAGATION STATIC IV rep_require_tag(pTHX) { #define rep_require_tag() rep_require_tag(aTHX) - const PERL_SI *si; - - for (si = PL_curstackinfo; si; si = si->si_prev) { - I32 cxix; - - for (cxix = si->si_cxix; cxix >= 0; --cxix) { - const PERL_CONTEXT *cx = si->si_cxstack + cxix; - - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) - return PTR2IV(cx); + const CV *cv, *outside; + + cv = PL_compcv; + + if (!cv) { + /* If for some reason the pragma is operational at run-time, try to discover + * the current cv in use. */ + const PERL_SI *si; + + for (si = PL_curstackinfo; si; si = si->si_prev) { + I32 cxix; + + for (cxix = si->si_cxix; cxix >= 0; --cxix) { + const PERL_CONTEXT *cx = si->si_cxstack + cxix; + + switch (CxTYPE(cx)) { + case CXt_SUB: + case CXt_FORMAT: + /* The propagation workaround is only needed up to 5.10.0 and at that + * time format and sub contexts were still identical. And even later the + * cv members offsets should have been kept the same. */ + cv = cx->blk_sub.cv; + goto get_enclosing_cv; + case CXt_EVAL: + cv = cx->blk_eval.cv; + goto get_enclosing_cv; + default: + break; + } + } } + + cv = PL_main_cv; } - return PTR2IV(NULL); +get_enclosing_cv: + for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) + cv = outside; + + return PTR2IV(cv); } #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */ STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) { #define rep_tag(C, E) rep_tag(aTHX_ (C), (E)) rep_hint_t *h; - dMY_CXT; - h = PerlMemShared_malloc(sizeof *h); - h->comp = rep_validate_callback(comp); - h->exec = rep_validate_callback(exec); + h = PerlMemShared_malloc(sizeof *h); + h->comp = rep_validate_callback(comp); + h->exec = rep_validate_callback(exec); #if REP_WORKAROUND_REQUIRE_PROPAGATION - h->cxreq = rep_require_tag(); + h->require_tag = rep_require_tag(); #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */ #if REP_THREADSAFE - /* We only need for the key to be an unique tag for looking up the value later. - * Allocated memory provides convenient unique identifiers, so that's why we - * use the hint as the key itself. */ - ptable_store(MY_CXT.tbl, h, h); + { + dMY_CXT; + /* We only need for the key to be an unique tag for looking up the value later + * Allocated memory provides convenient unique identifiers, so that's why we + * use the hint as the key itself. */ + ptable_store(MY_CXT.tbl, h, h); + } #endif /* REP_THREADSAFE */ return newSViv(PTR2IV(h)); @@ -202,18 +232,20 @@ STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) { STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) { #define rep_detag(H) rep_detag(aTHX_ (H)) rep_hint_t *h; - dMY_CXT; if (!(hint && SvIOK(hint))) return NULL; h = INT2PTR(rep_hint_t *, SvIVX(hint)); #if REP_THREADSAFE - h = ptable_fetch(MY_CXT.tbl, h); + { + dMY_CXT; + h = ptable_fetch(MY_CXT.tbl, h); + } #endif /* REP_THREADSAFE */ #if REP_WORKAROUND_REQUIRE_PROPAGATION - if (rep_require_tag() != h->cxreq) + if (rep_require_tag() != h->require_tag) return NULL; #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */ @@ -319,9 +351,9 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) * already set up all the stuff we're going to to need for * subsequent exec and other calls */ if (h->comp) { - ENTER; + ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(obj); PUTBACK; @@ -360,14 +392,14 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv); PUTBACK; call_sv(self->cb_exec, G_SCALAR); - + SPAGAIN; ret = POPs; @@ -409,8 +441,14 @@ Plugin_checkstr(pTHX_ REGEXP * const RX) void Plugin_free(pTHX_ REGEXP * const RX) { - struct regexp *rx = rxREGEXP(RX); - GET_SELF_FROM_PPRIVATE(rx->pprivate); + struct regexp *rx; + re__engine__Plugin self; + + if (PL_dirty) + return; + + rx = rxREGEXP(RX); + SELF_FROM_PPRIVATE(self, rx->pprivate); SvREFCNT_dec(self->pattern); SvREFCNT_dec(self->str); @@ -433,7 +471,7 @@ Plugin_free(pTHX_ REGEXP * const RX) if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); PUTBACK; @@ -472,14 +510,14 @@ Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren, if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); PUTBACK; items = call_sv(callback, G_SCALAR); - + if (items == 1) { SV *ret; @@ -512,7 +550,7 @@ Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren, if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); @@ -543,7 +581,7 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv, ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); @@ -593,12 +631,13 @@ Plugin_package(pTHX_ REGEXP * const RX) STATIC U32 rep_initialized = 0; STATIC void rep_teardown(pTHX_ void *root) { - dMY_CXT; - if (!rep_initialized || aTHX != root) return; - ptable_free(MY_CXT.tbl); + { + dMY_CXT; + ptable_free(MY_CXT.tbl); + } rep_initialized = 0; } @@ -608,9 +647,11 @@ STATIC void rep_setup(pTHX) { if (rep_initialized) return; - MY_CXT_INIT; - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + { + MY_CXT_INIT; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; + } call_atexit(rep_teardown, aTHX); @@ -634,7 +675,13 @@ PROTOTYPES: DISABLE BOOT: { if (!rep_booted++) { + HV *stash; + PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__); + + stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); + newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(REP_THREADSAFE)); + newCONSTSUB(stash, "REP_FORKSAFE", newSVuv(REP_FORKSAFE)); } rep_setup(); @@ -648,11 +695,13 @@ PREINIT: ptable *t; PPCODE: { - my_cxt_t ud; + rep_ptable_clone_ud ud; dMY_CXT; - ud.tbl = t = ptable_new(); - ud.owner = MY_CXT.owner; + + t = ptable_new(); + rep_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud); + rep_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE;