X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Hooks.git;a=blobdiff_plain;f=Hooks.xs;h=3f9ce3e1a6039198d6f880c6ce60f97afce73585;hp=30ee8ca4cdf9c31a4c3840962eff71f24ea59682;hb=HEAD;hpb=7b88eb9cbb0c1342a6480820450644708aed019c diff --git a/Hooks.xs b/Hooks.xs index 30ee8ca..3f9ce3e 100644 --- a/Hooks.xs +++ b/Hooks.xs @@ -6,18 +6,20 @@ #include "perl.h" #include "XSUB.h" -#define __PACKAGE__ "re::engine::Hooks" -#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) +/* --- XS helpers ---------------------------------------------------------- */ -/* --- Compatibility wrappers ---------------------------------------------- */ +#define XSH_PACKAGE "re::engine::Hooks" -#define REH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) +#include "xsh/caps.h" +#include "xsh/util.h" -#ifndef SvPV_const -# define SvPV_const(S, L) SvPV(S, L) -#endif +/* ... Lexical hints ....................................................... */ -/* --- Lexical hints ------------------------------------------------------- */ +#if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5) +# define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \ + Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \ + (PKG), (PKGLEN), (FLAGS), (PKGHASH)) +#endif STATIC U32 reh_hash = 0; @@ -26,40 +28,51 @@ STATIC SV *reh_hint(pTHX) { SV *hint; #ifdef cop_hints_fetch_pvn - hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, + hint = cop_hints_fetch_pvn(PL_curcop, XSH_PACKAGE, XSH_PACKAGE_LEN, reh_hash, 0); -#elif REH_HAS_PERL(5, 9, 5) - hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - NULL, - __PACKAGE__, __PACKAGE_LEN__, - 0, - reh_hash); #else - SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); - if (!val) - return 0; - hint = *val; + SV **val = hv_fetch(GvHV(PL_hintgv), XSH_PACKAGE, XSH_PACKAGE_LEN, 0); + hint = val ? *val : NULL; #endif return hint; } +/* ... Thread-local storage ................................................ */ + +#define XSH_THREADS_USER_CONTEXT 0 +#define XSH_THREADS_USER_LOCAL_SETUP 0 +#define XSH_THREADS_USER_LOCAL_TEARDOWN 0 + +#include "xsh/threads.h" + +/* --- Compatibility wrappers ---------------------------------------------- */ + +#ifndef SvPV_const +# define SvPV_const(S, L) SvPV(S, L) +#endif + /* --- Public API ---------------------------------------------------------- */ #include "re_engine_hooks.h" typedef struct reh_action { struct reh_action *next; - reh_comp_hook comp; - reh_exec_hook exec; + reh_config cbs; const char *key; STRLEN klen; } reh_action; STATIC reh_action *reh_action_list = 0; +#ifdef USE_ITHREADS + +STATIC perl_mutex reh_action_list_mutex; + +#endif /* USE_ITHREADS */ + #undef reh_register -void reh_register(pTHX_ const char *key, reh_comp_hook comp, reh_exec_hook exec) { +void reh_register(pTHX_ const char *key, reh_config *cfg) { reh_action *a; char *key_dup; STRLEN i, len; @@ -73,57 +86,18 @@ void reh_register(pTHX_ const char *key, reh_comp_hook comp, reh_exec_hook exec) key_dup[len] = '\0'; a = PerlMemShared_malloc(sizeof *a); - a->next = reh_action_list; - a->comp = comp; - a->exec = exec; + a->cbs = *cfg; a->key = key_dup; a->klen = len; + XSH_LOCK(&reh_action_list_mutex); + a->next = reh_action_list; reh_action_list = a; + XSH_UNLOCK(&reh_action_list_mutex); return; } -/* --- Private API --------------------------------------------------------- */ - -void reh_call_comp_hook(pTHX_ regexp *rx, regnode *node) { - SV *hint = reh_hint(); - - if (hint && SvPOK(hint)) { - STRLEN len; - const char *keys = SvPV_const(hint, len); - reh_action *a; - - for (a = reh_action_list; a; a = a->next) { - if (a->comp) { - char *p = strstr(keys, a->key); - - if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ') - a->comp(aTHX_ rx, node); - } - } - } -} - -void reh_call_exec_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) { - SV *hint = reh_hint(); - - if (hint && SvPOK(hint)) { - STRLEN len; - const char *keys = SvPV_const(hint, len); - reh_action *a; - - for (a = reh_action_list; a; a = a->next) { - if (a->exec) { - char *p = strstr(keys, a->key); - - if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ') - a->exec(aTHX_ rx, node, reginfo, st); - } - } - } -} - /* --- Custom regexp engine ------------------------------------------------ */ #if PERL_VERSION <= 10 @@ -133,16 +107,22 @@ void reh_call_exec_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, #endif #if PERL_VERSION <= 10 -EXTERN_C REGEXP *reh_regcomp(pTHX_ const SV * const, const U32); +EXTERN_C REGEXP *reh_re_compile(pTHX_ const SV * const, const U32); #else -EXTERN_C REGEXP *reh_regcomp(pTHX_ SV * const, U32); +EXTERN_C REGEXP *reh_re_compile(pTHX_ SV * const, U32); +#endif +#if XSH_HAS_PERL(5, 19, 4) +EXTERN_C I32 reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, SSize_t, SV *, void *, U32); +#else +EXTERN_C I32 reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, I32, SV *, void *, U32); +#endif +#if XSH_HAS_PERL(5, 19, 1) +EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, const char * const, char *, char *, U32, re_scream_pos_data *); +#else +EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, char *, U32, re_scream_pos_data *); #endif -EXTERN_C I32 reh_regexec(pTHX_ REGEXP * const, char *, char *, - char *, I32, SV *, void *, U32); -EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, - char *, U32, re_scream_pos_data *); EXTERN_C SV * reh_re_intuit_string(pTHX_ REGEXP * const); -EXTERN_C void reh_regfree(pTHX_ REGEXP * const); +EXTERN_C void reh_re_free(pTHX_ REGEXP * const); EXTERN_C void reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const, const I32, SV * const); EXTERN_C void reh_reg_numbered_buff_store(pTHX_ REGEXP * const, @@ -155,52 +135,240 @@ EXTERN_C SV * reh_reg_named_buff_iter(pTHX_ REGEXP * const, const SV * const, const U32); EXTERN_C SV * reh_reg_qr_package(pTHX_ REGEXP * const); #ifdef USE_ITHREADS -EXTERN_C void * reh_regdupe(pTHX_ REGEXP * const, CLONE_PARAMS *); +EXTERN_C void * reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *); #endif - -EXTERN_C const struct regexp_engine reh_regexp_engine; - -REGEXP * -#if PERL_VERSION <= 10 -reh_re_compile(pTHX_ const SV * const pattern, const U32 flags) -#else -reh_re_compile(pTHX_ SV * const pattern, U32 flags) +#if XSH_HAS_PERL(5, 17, 1) +EXTERN_C REGEXP *reh_re_op_compile(pTHX_ SV ** const, int, OP *, const regexp_engine*, REGEXP *VOL, bool *, U32, U32); #endif -{ - struct regexp *rx; - REGEXP *RX; - - RX = reh_regcomp(aTHX_ pattern, flags); - rx = rxREGEXP(RX); - rx->engine = &reh_regexp_engine; - - return RX; -} - -const struct regexp_engine reh_regexp_engine = { - reh_re_compile, - reh_regexec, - reh_re_intuit_start, - reh_re_intuit_string, - reh_regfree, +const struct regexp_engine reh_regexp_engine = { + reh_re_compile, + reh_regexec_flags, + reh_re_intuit_start, + reh_re_intuit_string, + reh_re_free, reh_reg_numbered_buff_fetch, reh_reg_numbered_buff_store, reh_reg_numbered_buff_length, reh_reg_named_buff, reh_reg_named_buff_iter, - reh_reg_qr_package, + reh_reg_qr_package #if defined(USE_ITHREADS) - reh_regdupe + , reh_re_dupe +#endif +#if XSH_HAS_PERL(5, 17, 1) + , reh_re_op_compile #endif }; +/* --- Internal regexp structure -> hook list inside-out mapping ----------- */ + +typedef struct { + size_t count; + const reh_config *cbs; + U32 refcount; +} reh_private; + +STATIC void reh_private_free(pPMS_ reh_private *priv) { +#define reh_private_free(P) reh_private_free(aPMS_ (P)) + if (!priv) + return; + + if (priv->refcount <= 1) { + PerlMemShared_free((void *) priv->cbs); + PerlMemShared_free(priv); + } else { + --priv->refcount; + } +} + +#define PTABLE_NAME ptable_private +#define PTABLE_VAL_FREE(V) reh_private_free(V) +#define PTABLE_VAL_NEED_CONTEXT 0 + +#include "xsh/ptable.h" + +#define ptable_private_store(T, K, V) ptable_private_store(aPMS_ (T), (K), (V)) +#define ptable_private_delete(T, K) ptable_private_delete(aPMS_ (T), (K)) +#define ptable_private_clear(T) ptable_private_clear(aPMS_ (T)) +#define ptable_private_free(T) ptable_private_free(aPMS_ (T)) + +STATIC ptable *reh_private_map; + +#ifdef USE_ITHREADS + +STATIC perl_mutex reh_private_map_mutex; + +#endif /* USE_ITHREADS */ + +#define REH_PRIVATE_MAP_FOREACH(C) STMT_START { \ + reh_private *priv; \ + XSH_LOCK(&reh_private_map_mutex); \ + priv = ptable_fetch(reh_private_map, rx->pprivate); \ + if (priv) { \ + const reh_config *cbs = priv->cbs; \ + if (cbs) { \ + const reh_config *end = cbs + priv->count; \ + for (; cbs < end; ++cbs) { \ + (C); \ + } \ + } \ + } \ + XSH_UNLOCK(&reh_private_map_mutex); \ +} STMT_END + +STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) { +#define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P)) + XSH_LOCK(&reh_private_map_mutex); + ptable_private_store(reh_private_map, ri, priv); + XSH_UNLOCK(&reh_private_map_mutex); + + return; +} + +STATIC void reh_private_map_copy(pTHX_ void *ri_from, void *ri_to) { +#define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T)) + reh_private *priv; + + XSH_LOCK(&reh_private_map_mutex); + priv = ptable_fetch(reh_private_map, ri_from); + if (priv) { + ++priv->refcount; + ptable_private_store(reh_private_map, ri_to, priv); + } + XSH_UNLOCK(&reh_private_map_mutex); +} + +STATIC void reh_private_map_delete(pTHX_ void *ri) { +#define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R)) + XSH_LOCK(&reh_private_map_mutex); + ptable_private_delete(reh_private_map, ri); + XSH_UNLOCK(&reh_private_map_mutex); + + return; +} + +/* --- Private API --------------------------------------------------------- */ + +void reh_call_comp_begin_hook(pTHX_ regexp *rx) { + SV *hint = reh_hint(); + + if (hint && SvPOK(hint)) { + STRLEN len; + const char *keys = SvPV_const(hint, len); + size_t count = 0; + + reh_private *priv; + reh_config *cbs = NULL; + reh_action *a, *root; + + XSH_LOCK(&reh_action_list_mutex); + root = reh_action_list; + XSH_UNLOCK(&reh_action_list_mutex); + + for (a = root; a; a = a->next) { + char *p = strstr(keys, a->key); + + if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ') + ++count; + } + + if (count) { + size_t i = 0; + + cbs = PerlMemShared_malloc(count * sizeof *cbs); + + for (a = root; a; a = a->next) { + char *p = strstr(keys, a->key); + + if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ') + cbs[i++] = a->cbs; + } + } + + priv = PerlMemShared_malloc(sizeof *priv); + priv->count = count; + priv->cbs = cbs; + priv->refcount = 1; + + rx->engine = &reh_regexp_engine; + + reh_private_map_store(rx->pprivate, priv); + } +} + +void reh_call_comp_node_hook(pTHX_ regexp *rx, regnode *node) { + REH_PRIVATE_MAP_FOREACH(cbs->comp_node(aTHX_ rx, node)); +} + +void reh_call_exec_node_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) { + REH_PRIVATE_MAP_FOREACH(cbs->exec_node(aTHX_ rx, node, reginfo, st)); +} + +EXTERN_C void reh_regfree_internal(pTHX_ REGEXP * const); + +void reh_re_free(pTHX_ REGEXP * const RX) { + regexp *rx = rxREGEXP(RX); + + reh_private_map_delete(rx->pprivate); + + reh_regfree_internal(aTHX_ RX); +} + +#ifdef USE_ITHREADS + +EXTERN_C void *reh_regdupe_internal(pTHX_ REGEXP * const, CLONE_PARAMS *); + +void *reh_re_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) { + regexp *rx = rxREGEXP(RX); + void *new_ri; + + new_ri = reh_regdupe_internal(aTHX_ RX, param); + + reh_private_map_copy(rx->pprivate, new_ri); + + return new_ri; +} + +#endif + +/* --- Module setup/teardown ----------------------------------------------- */ + +STATIC void xsh_user_global_setup(pTHX) { + PERL_HASH(reh_hash, XSH_PACKAGE, XSH_PACKAGE_LEN); + + reh_private_map = ptable_new(8); + +#ifdef USE_ITHREADS + MUTEX_INIT(&reh_action_list_mutex); + MUTEX_INIT(&reh_private_map_mutex); +#endif + + return; +} + +STATIC void xsh_user_global_teardown(pTHX) { + ptable_private_free(reh_private_map); + +#ifdef USE_ITHREADS + MUTEX_DESTROY(&reh_private_map_mutex); + MUTEX_DESTROY(&reh_action_list_mutex); +#endif + + return; +} + /* --- XS ------------------------------------------------------------------ */ MODULE = re::engine::Hooks PACKAGE = re::engine::Hooks PROTOTYPES: ENABLE +BOOT: +{ + xsh_setup(); +} + void _ENGINE() PROTOTYPE: @@ -212,10 +380,13 @@ _registered(SV *key) PROTOTYPE: $ PREINIT: SV *ret = NULL; - reh_action *a = reh_action_list; + reh_action *a; STRLEN len; const char *s; PPCODE: + XSH_LOCK(&reh_action_list_mutex); + a = reh_action_list; + XSH_UNLOCK(&reh_action_list_mutex); s = SvPV_const(key, len); while (a && !ret) { if (a->klen == len && memcmp(a->key, s, len) == 0)