X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=blobdiff_plain;f=Plugin.xs;h=d64951ea73016f3fcdc3a5dec3d0404c43246b0a;hp=cc839c73d04757161b4187e1c1c50ff960749464;hb=9cd5eb05f2a375deac583160e2f9446e5e552b49;hpb=55b1c44b39286c06a4d352826ac81345b1e0f5cd diff --git a/Plugin.xs b/Plugin.xs index cc839c7..d64951e 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -1,59 +1,285 @@ +/* This file is part of the re::engine::Plugin Perl module. + * See http://search.cpan.org/dist/re-engine-Plugin/ */ + +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + #include "Plugin.h" -SV* -get_H_callback(const char* key) -{ - dVAR; - dSP; +#define __PACKAGE__ "re::engine::Plugin" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) + +#define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) + +#undef ENTERn +#if defined(ENTER_with_name) && !REP_HAS_PERL(5, 11, 4) +# define ENTERn(N) ENTER_with_name(N) +#else +# define ENTERn(N) ENTER +#endif + +#undef LEAVEn +#if defined(LEAVE_with_name) && !REP_HAS_PERL(5, 11, 4) +# define LEAVEn(N) LEAVE_with_name(N) +#else +# define LEAVEn(N) LEAVE +#endif + +#ifndef REP_WORKAROUND_REQUIRE_PROPAGATION +# define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1) +#endif + +/* ... Thread safety and multiplicity ...................................... */ + +#ifndef REP_MULTIPLICITY +# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# define REP_MULTIPLICITY 1 +# else +# define REP_MULTIPLICITY 0 +# endif +#endif +#if REP_MULTIPLICITY && !defined(tTHX) +# define tTHX PerlInterpreter* +#endif + +#if REP_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 REP_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 REP_THREADSAFE 0 +# undef dMY_CXT +# define dMY_CXT dNOOP +# undef MY_CXT +# define MY_CXT rep_globaldata +# undef START_MY_CXT +# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# undef MY_CXT_INIT +# define MY_CXT_INIT NOOP +# undef MY_CXT_CLONE +# define MY_CXT_CLONE NOOP +#endif + +/* --- Helpers ------------------------------------------------------------- */ + +/* ... Thread-safe hints ................................................... */ + +typedef struct { + SV *comp; + SV *exec; +#if REP_WORKAROUND_REQUIRE_PROPAGATION + IV cxreq; +#endif +} rep_hint_t; + +#if REP_THREADSAFE + +#define PTABLE_VAL_FREE(V) { \ + rep_hint_t *h = (V); \ + SvREFCNT_dec(h->comp); \ + SvREFCNT_dec(h->exec); \ + PerlMemShared_free(h); \ +} - SV * callback; +#define pPTBL pTHX +#define pPTBL_ pTHX_ +#define aPTBL aTHX +#define aPTBL_ aTHX_ - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(key, 0))); - PUTBACK; +#include "ptable.h" - call_pv("re::engine::Plugin::_get_callback", G_SCALAR); +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_free(T) ptable_free(aTHX_ (T)) - SPAGAIN; +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - callback = POPs; - SvREFCNT_inc(callback); /* refcount++ or FREETMPS below will collect us */ +typedef struct { + ptable *tbl; + tTHX owner; +} my_cxt_t; - /* If we don't get a valid CODE value return a NULL callback, in - * that case the hooks won't call back into Perl space */ - if (!SvROK(callback) || SvTYPE(SvRV(callback)) != SVt_PVCV) { - callback = NULL; - } +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(dupsv); +} + +STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + my_cxt_t *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(h2->comp); + h2->exec = rep_clone(h1->exec, ud->owner); + SvREFCNT_inc(h2->exec); +#if REP_WORKAROUND_REQUIRE_PROPAGATION + h2->cxreq = h1->cxreq; +#endif + + ptable_store(ud->tbl, ent->key, h2); +} + +STATIC void rep_thread_cleanup(pTHX_ void *); + +STATIC void rep_thread_cleanup(pTHX_ void *ud) { + int *level = ud; + + if (*level) { + *level = 0; + LEAVE; + SAVEDESTRUCTOR_X(rep_thread_cleanup, level); + ENTER; + } else { + dMY_CXT; + PerlMemShared_free(level); + ptable_free(MY_CXT.tbl); + } +} + +#endif /* REP_THREADSAFE */ + +STATIC SV *rep_validate_callback(SV *code) { + if (!SvROK(code)) + return NULL; + + code = SvRV(code); + if (SvTYPE(code) < SVt_PVCV) + return NULL; - PUTBACK; - FREETMPS; - LEAVE; + return SvREFCNT_inc_simple_NN(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); + } + } + + return PTR2IV(NULL); +} +#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); +#if REP_WORKAROUND_REQUIRE_PROPAGATION + h->cxreq = 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); +#endif /* REP_THREADSAFE */ + + return newSViv(PTR2IV(h)); +} + +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); +#endif /* REP_THREADSAFE */ + +#if REP_WORKAROUND_REQUIRE_PROPAGATION + if (rep_require_tag() != h->cxreq) + return NULL; +#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */ + + return h; +} + +STATIC U32 rep_hash = 0; + +STATIC const rep_hint_t *rep_hint(pTHX) { +#define rep_hint() rep_hint(aTHX) + SV *hint; + + /* We already require 5.9.5 for the regexp engine API. */ + hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + NULL, + __PACKAGE__, __PACKAGE_LEN__, + 0, + rep_hash); - return callback; + return rep_detag(hint); } REGEXP * +#if PERL_VERSION <= 10 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) +#else +Plugin_comp(pTHX_ SV * const pattern, U32 flags) +#endif { dSP; - REGEXP * rx; - re__engine__Plugin re; - I32 count; + struct regexp * rx; + REGEXP *RX; I32 buffers; + re__engine__Plugin re; + const rep_hint_t *h; + + h = rep_hint(); + if (!h) /* This looks like a pragma leak. Apply the default behaviour */ + return re_compile(pattern, flags); /* exp/xend version of the pattern & length */ STRLEN plen; char* exp = SvPV((SV*)pattern, plen); - char* xend = exp + plen; - - /* The REGEXP structure to return to perl */ - Newxz(rx, 1, REGEXP); /* Our blessed object */ SV *obj = newSV(0); @@ -61,12 +287,17 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) Newxz(re, 1, struct replug); sv_setref_pv(obj, "re::engine::Plugin", (void*)re); + newREGEXP(RX); + rx = rxREGEXP(RX); + re->rx = rx; /* Make the rx accessible from self->rx */ - rx->refcnt = 1; /* Refcount so we won' be destroyed */ rx->intflags = flags; /* Flags for internal use */ rx->extflags = flags; /* Flags for perl to use */ rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */ +#if PERL_VERSION <= 10 + rx->refcnt = 1; /* Refcount so we won't be destroyed */ + /* Precompiled pattern for pp_regcomp to use */ rx->prelen = plen; rx->precomp = savepvn(exp, rx->prelen); @@ -77,6 +308,7 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) rx->wraplen = rx->prelen; Newx(rx->wrapped, rx->wraplen, char); Copy(rx->precomp, rx->wrapped, rx->wraplen, char); +#endif /* Store our private object */ rx->pprivate = obj; @@ -85,14 +317,22 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) re->pattern = (SV*)pattern; SvREFCNT_inc(re->pattern); - /* - * Call our callback function if one was defined, if not we've - * already set up all the stuff we're going to to need for - * subsequent exec and other calls - */ - SV * callback = get_H_callback("comp"); + /* If there's an exec callback, store it into the private object so + * that it will be the one to be called, even if the engine changes + * in between */ + if (h->exec) { + re->cb_exec = h->exec; + SvREFCNT_inc_simple_void_NN(h->exec); + } - if (callback) { + re->cb_num_capture_buff_FETCH = NULL; + re->cb_num_capture_buff_STORE = NULL; + re->cb_num_capture_buff_LENGTH = NULL; + + /* Call our callback function if one was defined, if not we've + * already set up all the stuff we're going to to need for + * subsequent exec and other calls */ + if (h->comp) { ENTER; SAVETMPS; @@ -100,7 +340,7 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) XPUSHs(obj); PUTBACK; - call_sv(callback, G_DISCARD); + call_sv(h->comp, G_DISCARD); FREETMPS; LEAVE; @@ -112,21 +352,21 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) buffers = rx->nparens; - Newxz(rx->offs, buffers, regexp_paren_pair); + Newxz(rx->offs, buffers + 1, regexp_paren_pair); - return rx; + return RX; } I32 -Plugin_exec(pTHX_ REGEXP * const rx, char *stringarg, char *strend, +Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, char *strbeg, I32 minend, SV *sv, void *data, U32 flags) { dSP; I32 matched; - SV * callback = get_H_callback("exec"); + struct regexp *rx = rxREGEXP(RX); GET_SELF_FROM_PPRIVATE(rx->pprivate); - if (callback) { + if (self->cb_exec) { /* Store the current str for ->str */ self->str = (SV*)sv; SvREFCNT_inc(self->str); @@ -139,7 +379,7 @@ Plugin_exec(pTHX_ REGEXP * const rx, char *stringarg, char *strend, XPUSHs(sv); PUTBACK; - call_sv(callback, G_SCALAR); + call_sv(self->cb_exec, G_SCALAR); SPAGAIN; @@ -161,10 +401,10 @@ Plugin_exec(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } char * -Plugin_intuit(pTHX_ REGEXP * const rx, SV *sv, char *strpos, +Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos, char *strend, U32 flags, re_scream_pos_data *data) { - PERL_UNUSED_ARG(rx); + PERL_UNUSED_ARG(RX); PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(strpos); PERL_UNUSED_ARG(strend); @@ -174,20 +414,33 @@ Plugin_intuit(pTHX_ REGEXP * const rx, SV *sv, char *strpos, } SV * -Plugin_checkstr(pTHX_ REGEXP * const rx) +Plugin_checkstr(pTHX_ REGEXP * const RX) { - PERL_UNUSED_ARG(rx); + PERL_UNUSED_ARG(RX); return NULL; } void -Plugin_free(pTHX_ REGEXP * const rx) +Plugin_free(pTHX_ REGEXP * const RX) { - PERL_UNUSED_ARG(rx); + struct regexp *rx = rxREGEXP(RX); + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + SvREFCNT_dec(self->pattern); + SvREFCNT_dec(self->str); + + SvREFCNT_dec(self->cb_exec); + + SvREFCNT_dec(self->cb_num_capture_buff_FETCH); + SvREFCNT_dec(self->cb_num_capture_buff_STORE); + SvREFCNT_dec(self->cb_num_capture_buff_LENGTH); + + self->rx = NULL; + Safefree(self); + /* dSP; SV * callback; - GET_SELF_FROM_PPRIVATE(rx->pprivate); callback = self->cb_free; @@ -210,20 +463,22 @@ Plugin_free(pTHX_ REGEXP * const rx) } void * -Plugin_dupe(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) +Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) { + struct regexp *rx = rxREGEXP(RX); Perl_croak(aTHX_ "dupe not supported yet"); return rx->pprivate; } void -Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren, +Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren, SV * const sv) { dSP; I32 items; SV * callback; + struct regexp *rx = rxREGEXP(RX); GET_SELF_FROM_PPRIVATE(rx->pprivate); callback = self->cb_num_capture_buff_FETCH; @@ -257,12 +512,12 @@ Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const rx, const I32 paren, } void -Plugin_numbered_buff_STORE(pTHX_ REGEXP * const rx, const I32 paren, +Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren, SV const * const value) { dSP; - I32 items; SV * callback; + struct regexp *rx = rxREGEXP(RX); GET_SELF_FROM_PPRIVATE(rx->pprivate); callback = self->cb_num_capture_buff_STORE; @@ -274,7 +529,7 @@ Plugin_numbered_buff_STORE(pTHX_ REGEXP * const rx, const I32 paren, PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); - XPUSHs(SvREFCNT_inc(value)); + XPUSHs(SvREFCNT_inc((SV *) value)); PUTBACK; call_sv(callback, G_DISCARD); @@ -286,12 +541,12 @@ Plugin_numbered_buff_STORE(pTHX_ REGEXP * const rx, const I32 paren, } I32 -Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const rx, const SV * const sv, +Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv, const I32 paren) { dSP; - I32 items; SV * callback; + struct regexp *rx = rxREGEXP(RX); GET_SELF_FROM_PPRIVATE(rx->pprivate); callback = self->cb_num_capture_buff_LENGTH; @@ -324,29 +579,108 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const rx, const SV * const sv, SV* -Plugin_named_buff (pTHX_ REGEXP * const rx, SV * const key, SV * const value, +Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value, const U32 flags) { return NULL; } SV* -Plugin_named_buff_iter (pTHX_ REGEXP * const rx, const SV * const lastkey, +Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey, const U32 flags) { return NULL; } SV* -Plugin_package(pTHX_ REGEXP * const rx) +Plugin_package(pTHX_ REGEXP * const RX) { - PERL_UNUSED_ARG(rx); + PERL_UNUSED_ARG(RX); return newSVpvs("re::engine::Plugin"); } +#if REP_THREADSAFE + +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); + + rep_initialized = 0; +} + +STATIC void rep_setup(pTHX) { +#define rep_setup() rep_setup(aTHX) + if (rep_initialized) + return; + + MY_CXT_INIT; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; + + call_atexit(rep_teardown, aTHX); + + rep_initialized = 1; +} + +#else /* REP_THREADSAFE */ + +#define rep_setup() + +#endif /* !REP_THREADSAFE */ + +STATIC U32 rep_booted = 0; + +/* --- XS ------------------------------------------------------------------ */ + MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin + PROTOTYPES: DISABLE +BOOT: +{ + if (!rep_booted++) { + PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__); + } + + rep_setup(); +} + +#if REP_THREADSAFE + +void +CLONE(...) +PREINIT: + ptable *t; + int *level; +CODE: + { + my_cxt_t ud; + dMY_CXT; + ud.tbl = t = ptable_new(); + ud.owner = MY_CXT.owner; + ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud); + } + { + MY_CXT_CLONE; + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + } + { + level = PerlMemShared_malloc(sizeof *level); + *level = 1; + LEAVEn("sub"); + SAVEDESTRUCTOR_X(rep_thread_cleanup, level); + ENTERn("sub"); + } + +#endif + void pattern(re::engine::Plugin self, ...) PPCODE: @@ -443,10 +777,20 @@ PPCODE: } } +void +_exec(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + SvREFCNT_dec(self->cb_exec); + self->cb_exec = ST(1); + SvREFCNT_inc(self->cb_exec); + } + void _num_capture_buff_FETCH(re::engine::Plugin self, ...) PPCODE: if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_FETCH); self->cb_num_capture_buff_FETCH = ST(1); SvREFCNT_inc(self->cb_num_capture_buff_FETCH); } @@ -455,6 +799,7 @@ void _num_capture_buff_STORE(re::engine::Plugin self, ...) PPCODE: if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_STORE); self->cb_num_capture_buff_STORE = ST(1); SvREFCNT_inc(self->cb_num_capture_buff_STORE); } @@ -463,10 +808,18 @@ void _num_capture_buff_LENGTH(re::engine::Plugin self, ...) PPCODE: if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_LENGTH); self->cb_num_capture_buff_LENGTH = ST(1); SvREFCNT_inc(self->cb_num_capture_buff_LENGTH); } +SV * +_tag(SV *comp, SV *exec) +CODE: + RETVAL = rep_tag(comp, exec); +OUTPUT: + RETVAL + void ENGINE() PPCODE: