1 /* This file is part of the re::engine::Hooks Perl module.
2 * See http://search.cpan.org/dist/re-engine-Hooks/ */
4 #define PERL_NO_GET_CONTEXT
9 /* --- XS helpers ---------------------------------------------------------- */
11 #define XSH_PACKAGE "re::engine::Hooks"
16 /* ... Lexical hints ....................................................... */
18 #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
19 # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
20 Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
21 (PKG), (PKGLEN), (FLAGS), (PKGHASH))
24 STATIC U32 reh_hash = 0;
26 STATIC SV *reh_hint(pTHX) {
27 #define reh_hint() reh_hint(aTHX)
30 #ifdef cop_hints_fetch_pvn
31 hint = cop_hints_fetch_pvn(PL_curcop, XSH_PACKAGE, XSH_PACKAGE_LEN,
34 SV **val = hv_fetch(GvHV(PL_hintgv), XSH_PACKAGE, XSH_PACKAGE_LEN, 0);
35 hint = val ? *val : NULL;
41 /* ... Thread-local storage ................................................ */
43 #define XSH_THREADS_USER_CONTEXT 0
44 #define XSH_THREADS_USER_LOCAL_SETUP 0
45 #define XSH_THREADS_USER_LOCAL_TEARDOWN 0
47 #include "xsh/threads.h"
49 /* --- Compatibility wrappers ---------------------------------------------- */
52 # define SvPV_const(S, L) SvPV(S, L)
55 /* --- Public API ---------------------------------------------------------- */
57 #include "re_engine_hooks.h"
59 typedef struct reh_action {
60 struct reh_action *next;
66 STATIC reh_action *reh_action_list = 0;
70 STATIC perl_mutex reh_action_list_mutex;
72 #endif /* USE_ITHREADS */
75 void reh_register(pTHX_ const char *key, reh_config *cfg) {
81 for (i = 0; i < len; ++i)
82 if (!isALNUM(key[i]) && key[i] != ':')
84 key_dup = PerlMemShared_malloc(len + 1);
85 memcpy(key_dup, key, len);
88 a = PerlMemShared_malloc(sizeof *a);
93 XSH_LOCK(&reh_action_list_mutex);
94 a->next = reh_action_list;
96 XSH_UNLOCK(&reh_action_list_mutex);
101 /* --- Custom regexp engine ------------------------------------------------ */
103 #if PERL_VERSION <= 10
104 # define rxREGEXP(RX) (RX)
106 # define rxREGEXP(RX) (SvANY(RX))
109 #if PERL_VERSION <= 10
110 EXTERN_C REGEXP *reh_re_compile(pTHX_ const SV * const, const U32);
112 EXTERN_C REGEXP *reh_re_compile(pTHX_ SV * const, U32);
114 #if XSH_HAS_PERL(5, 19, 4)
115 EXTERN_C I32 reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, SSize_t, SV *, void *, U32);
117 EXTERN_C I32 reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, I32, SV *, void *, U32);
119 #if XSH_HAS_PERL(5, 19, 1)
120 EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, const char * const, char *, char *, U32, re_scream_pos_data *);
122 EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, char *, U32, re_scream_pos_data *);
124 EXTERN_C SV * reh_re_intuit_string(pTHX_ REGEXP * const);
125 EXTERN_C void reh_re_free(pTHX_ REGEXP * const);
126 EXTERN_C void reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const,
127 const I32, SV * const);
128 EXTERN_C void reh_reg_numbered_buff_store(pTHX_ REGEXP * const,
129 const I32, SV const * const);
130 EXTERN_C I32 reh_reg_numbered_buff_length(pTHX_ REGEXP * const,
131 const SV * const, const I32);
132 EXTERN_C SV * reh_reg_named_buff(pTHX_ REGEXP * const, SV * const,
133 SV * const, const U32);
134 EXTERN_C SV * reh_reg_named_buff_iter(pTHX_ REGEXP * const,
135 const SV * const, const U32);
136 EXTERN_C SV * reh_reg_qr_package(pTHX_ REGEXP * const);
138 EXTERN_C void * reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
140 #if XSH_HAS_PERL(5, 17, 1)
141 EXTERN_C REGEXP *reh_re_op_compile(pTHX_ SV ** const, int, OP *, const regexp_engine*, REGEXP *VOL, bool *, U32, U32);
144 const struct regexp_engine reh_regexp_engine = {
148 reh_re_intuit_string,
150 reh_reg_numbered_buff_fetch,
151 reh_reg_numbered_buff_store,
152 reh_reg_numbered_buff_length,
154 reh_reg_named_buff_iter,
156 #if defined(USE_ITHREADS)
159 #if XSH_HAS_PERL(5, 17, 1)
164 /* --- Internal regexp structure -> hook list inside-out mapping ----------- */
168 const reh_config *cbs;
172 STATIC void reh_private_free(pPMS_ reh_private *priv) {
173 #define reh_private_free(P) reh_private_free(aPMS_ (P))
177 if (priv->refcount <= 1) {
178 PerlMemShared_free((void *) priv->cbs);
179 PerlMemShared_free(priv);
185 #define PTABLE_NAME ptable_private
186 #define PTABLE_VAL_FREE(V) reh_private_free(V)
187 #define PTABLE_VAL_NEED_CONTEXT 0
189 #include "xsh/ptable.h"
191 #define ptable_private_store(T, K, V) ptable_private_store(aPMS_ (T), (K), (V))
192 #define ptable_private_delete(T, K) ptable_private_delete(aPMS_ (T), (K))
193 #define ptable_private_clear(T) ptable_private_clear(aPMS_ (T))
194 #define ptable_private_free(T) ptable_private_free(aPMS_ (T))
196 STATIC ptable *reh_private_map;
200 STATIC perl_mutex reh_private_map_mutex;
202 #endif /* USE_ITHREADS */
204 #define REH_PRIVATE_MAP_FOREACH(C) STMT_START { \
206 XSH_LOCK(&reh_private_map_mutex); \
207 priv = ptable_fetch(reh_private_map, rx->pprivate); \
209 const reh_config *cbs = priv->cbs; \
211 const reh_config *end = cbs + priv->count; \
212 for (; cbs < end; ++cbs) { \
217 XSH_UNLOCK(&reh_private_map_mutex); \
220 STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) {
221 #define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P))
222 XSH_LOCK(&reh_private_map_mutex);
223 ptable_private_store(reh_private_map, ri, priv);
224 XSH_UNLOCK(&reh_private_map_mutex);
229 STATIC void reh_private_map_copy(pTHX_ void *ri_from, void *ri_to) {
230 #define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T))
233 XSH_LOCK(&reh_private_map_mutex);
234 priv = ptable_fetch(reh_private_map, ri_from);
237 ptable_private_store(reh_private_map, ri_to, priv);
239 XSH_UNLOCK(&reh_private_map_mutex);
242 STATIC void reh_private_map_delete(pTHX_ void *ri) {
243 #define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R))
244 XSH_LOCK(&reh_private_map_mutex);
245 ptable_private_delete(reh_private_map, ri);
246 XSH_UNLOCK(&reh_private_map_mutex);
251 /* --- Private API --------------------------------------------------------- */
253 void reh_call_comp_begin_hook(pTHX_ regexp *rx) {
254 SV *hint = reh_hint();
256 if (hint && SvPOK(hint)) {
258 const char *keys = SvPV_const(hint, len);
262 reh_config *cbs = NULL;
263 reh_action *a, *root;
265 XSH_LOCK(&reh_action_list_mutex);
266 root = reh_action_list;
267 XSH_UNLOCK(&reh_action_list_mutex);
269 for (a = root; a; a = a->next) {
270 char *p = strstr(keys, a->key);
272 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
279 cbs = PerlMemShared_malloc(count * sizeof *cbs);
281 for (a = root; a; a = a->next) {
282 char *p = strstr(keys, a->key);
284 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
289 priv = PerlMemShared_malloc(sizeof *priv);
294 rx->engine = &reh_regexp_engine;
296 reh_private_map_store(rx->pprivate, priv);
300 void reh_call_comp_node_hook(pTHX_ regexp *rx, regnode *node) {
301 REH_PRIVATE_MAP_FOREACH(cbs->comp_node(aTHX_ rx, node));
304 void reh_call_exec_node_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
305 REH_PRIVATE_MAP_FOREACH(cbs->exec_node(aTHX_ rx, node, reginfo, st));
308 EXTERN_C void reh_regfree_internal(pTHX_ REGEXP * const);
310 void reh_re_free(pTHX_ REGEXP * const RX) {
311 regexp *rx = rxREGEXP(RX);
313 reh_private_map_delete(rx->pprivate);
315 reh_regfree_internal(aTHX_ RX);
320 EXTERN_C void *reh_regdupe_internal(pTHX_ REGEXP * const, CLONE_PARAMS *);
322 void *reh_re_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) {
323 regexp *rx = rxREGEXP(RX);
326 new_ri = reh_regdupe_internal(aTHX_ RX, param);
328 reh_private_map_copy(rx->pprivate, new_ri);
335 /* --- Module setup/teardown ----------------------------------------------- */
337 STATIC void xsh_user_global_setup(pTHX) {
338 PERL_HASH(reh_hash, XSH_PACKAGE, XSH_PACKAGE_LEN);
340 reh_private_map = ptable_new(8);
343 MUTEX_INIT(&reh_action_list_mutex);
344 MUTEX_INIT(&reh_private_map_mutex);
350 STATIC void xsh_user_global_teardown(pTHX) {
351 ptable_private_free(reh_private_map);
354 MUTEX_DESTROY(&reh_private_map_mutex);
355 MUTEX_DESTROY(&reh_action_list_mutex);
361 /* --- XS ------------------------------------------------------------------ */
363 MODULE = re::engine::Hooks PACKAGE = re::engine::Hooks
376 XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
387 XSH_LOCK(&reh_action_list_mutex);
389 XSH_UNLOCK(&reh_action_list_mutex);
390 s = SvPV_const(key, len);
392 if (a->klen == len && memcmp(a->key, s, len) == 0)