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 #define __PACKAGE__ "re::engine::Hooks"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
12 /* --- Compatibility wrappers ---------------------------------------------- */
14 #define REH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
17 # define SvPV_const(S, L) SvPV(S, L)
20 /* ... Thread safety and multiplicity ...................................... */
22 #ifndef REH_MULTIPLICITY
23 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
24 # define REH_MULTIPLICITY 1
26 # define REH_MULTIPLICITY 0
31 # define REH_LOCK(M) MUTEX_LOCK(M)
32 # define REH_UNLOCK(M) MUTEX_UNLOCK(M)
34 # define REH_LOCK(M) NOOP
35 # define REH_UNLOCK(M) NOOP
38 /* --- Lexical hints ------------------------------------------------------- */
40 STATIC U32 reh_hash = 0;
42 STATIC SV *reh_hint(pTHX) {
43 #define reh_hint() reh_hint(aTHX)
46 #ifdef cop_hints_fetch_pvn
47 hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
49 #elif REH_HAS_PERL(5, 9, 5)
50 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
52 __PACKAGE__, __PACKAGE_LEN__,
56 SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
65 /* --- Public API ---------------------------------------------------------- */
67 #include "re_engine_hooks.h"
69 typedef struct reh_action {
70 struct reh_action *next;
76 STATIC reh_action *reh_action_list = 0;
80 STATIC perl_mutex reh_action_list_mutex;
82 #endif /* USE_ITHREADS */
85 void reh_register(pTHX_ const char *key, reh_config *cfg) {
91 for (i = 0; i < len; ++i)
92 if (!isALNUM(key[i]) && key[i] != ':')
94 key_dup = PerlMemShared_malloc(len + 1);
95 memcpy(key_dup, key, len);
98 a = PerlMemShared_malloc(sizeof *a);
103 REH_LOCK(&reh_action_list_mutex);
104 a->next = reh_action_list;
106 REH_UNLOCK(&reh_action_list_mutex);
111 /* --- Custom regexp engine ------------------------------------------------ */
113 #if PERL_VERSION <= 10
114 # define rxREGEXP(RX) (RX)
116 # define rxREGEXP(RX) (SvANY(RX))
119 #if PERL_VERSION <= 10
120 EXTERN_C REGEXP *reh_regcomp(pTHX_ const SV * const, const U32);
122 EXTERN_C REGEXP *reh_regcomp(pTHX_ SV * const, U32);
124 EXTERN_C I32 reh_regexec(pTHX_ REGEXP * const, char *, char *,
125 char *, I32, SV *, void *, U32);
126 EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *,
127 char *, U32, re_scream_pos_data *);
128 EXTERN_C SV * reh_re_intuit_string(pTHX_ REGEXP * const);
129 EXTERN_C void reh_regfree(pTHX_ REGEXP * const);
130 EXTERN_C void reh_re_free(pTHX_ REGEXP * const);
131 EXTERN_C void reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const,
132 const I32, SV * const);
133 EXTERN_C void reh_reg_numbered_buff_store(pTHX_ REGEXP * const,
134 const I32, SV const * const);
135 EXTERN_C I32 reh_reg_numbered_buff_length(pTHX_ REGEXP * const,
136 const SV * const, const I32);
137 EXTERN_C SV * reh_reg_named_buff(pTHX_ REGEXP * const, SV * const,
138 SV * const, const U32);
139 EXTERN_C SV * reh_reg_named_buff_iter(pTHX_ REGEXP * const,
140 const SV * const, const U32);
141 EXTERN_C SV * reh_reg_qr_package(pTHX_ REGEXP * const);
143 EXTERN_C void * reh_regdupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
144 EXTERN_C void * reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
146 #if REH_HAS_PERL(5, 17, 1)
147 EXTERN_C REGEXP *reh_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *VOL old_re, bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags);
150 const struct regexp_engine reh_regexp_engine = {
154 reh_re_intuit_string,
156 reh_reg_numbered_buff_fetch,
157 reh_reg_numbered_buff_store,
158 reh_reg_numbered_buff_length,
160 reh_reg_named_buff_iter,
162 #if defined(USE_ITHREADS)
165 #if REH_HAS_PERL(5, 17, 1)
170 /* --- Internal regexp structure -> hook list inside-out mapping ----------- */
174 const reh_config *cbs;
178 STATIC void reh_private_free(pTHX_ reh_private *priv) {
179 #define reh_private_free(P) reh_private_free(aTHX_ (P))
180 if (priv->refcount <= 1) {
181 PerlMemShared_free((void *) priv->cbs);
182 PerlMemShared_free(priv);
188 #define PTABLE_NAME ptable_private
189 #define PTABLE_VAL_FREE(V) reh_private_free(V)
198 #define ptable_private_store(T, K, V) ptable_private_store(aTHX_ (T), (K), (V))
199 #define ptable_private_delete(T, K) ptable_private_delete(aTHX_ (T), (K))
200 #define ptable_private_clear(T) ptable_private_clear(aTHX_ (T))
201 #define ptable_private_free(T) ptable_private_free(aTHX_ (T))
203 STATIC ptable *reh_private_map;
207 STATIC perl_mutex reh_private_map_mutex;
209 #endif /* USE_ITHREADS */
211 #define REH_PRIVATE_MAP_FOREACH(C) STMT_START { \
213 REH_LOCK(&reh_private_map_mutex); \
214 priv = ptable_fetch(reh_private_map, rx->pprivate); \
216 const reh_config *cbs = priv->cbs; \
218 const reh_config *end = cbs + priv->count; \
219 for (; cbs < end; ++cbs) { \
224 REH_UNLOCK(&reh_private_map_mutex); \
227 STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) {
228 #define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P))
229 REH_LOCK(&reh_private_map_mutex);
230 ptable_private_store(reh_private_map, ri, priv);
231 REH_UNLOCK(&reh_private_map_mutex);
236 STATIC void reh_private_map_copy(pTHX_ void *ri_from, void *ri_to) {
237 #define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T))
240 REH_LOCK(&reh_private_map_mutex);
241 priv = ptable_fetch(reh_private_map, ri_from);
244 ptable_private_store(reh_private_map, ri_to, priv);
246 REH_UNLOCK(&reh_private_map_mutex);
249 STATIC void reh_private_map_delete(pTHX_ void *ri) {
250 #define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R))
251 REH_LOCK(&reh_private_map_mutex);
252 ptable_private_delete(reh_private_map, ri);
253 REH_UNLOCK(&reh_private_map_mutex);
258 /* --- Private API --------------------------------------------------------- */
260 void reh_call_comp_begin_hook(pTHX_ regexp *rx) {
261 SV *hint = reh_hint();
263 if (hint && SvPOK(hint)) {
265 const char *keys = SvPV_const(hint, len);
269 reh_config *cbs = NULL;
270 reh_action *a, *root;
272 REH_LOCK(&reh_action_list_mutex);
273 root = reh_action_list;
274 REH_UNLOCK(&reh_action_list_mutex);
276 for (a = root; a; a = a->next) {
277 char *p = strstr(keys, a->key);
279 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
286 cbs = PerlMemShared_malloc(count * sizeof *cbs);
288 for (a = root; a; a = a->next) {
289 char *p = strstr(keys, a->key);
291 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
296 priv = PerlMemShared_malloc(sizeof *priv);
301 rx->engine = &reh_regexp_engine;
303 reh_private_map_store(rx->pprivate, priv);
307 void reh_call_comp_node_hook(pTHX_ regexp *rx, regnode *node) {
308 REH_PRIVATE_MAP_FOREACH(cbs->comp_node(aTHX_ rx, node));
311 void reh_call_exec_node_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
312 REH_PRIVATE_MAP_FOREACH(cbs->exec_node(aTHX_ rx, node, reginfo, st));
315 void reh_re_free(pTHX_ REGEXP * const RX) {
316 regexp *rx = rxREGEXP(RX);
318 reh_private_map_delete(rx->pprivate);
320 reh_regfree(aTHX_ RX);
325 void *reh_re_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) {
326 regexp *rx = rxREGEXP(RX);
329 new_ri = reh_regdupe(aTHX_ RX, param);
331 reh_private_map_copy(rx->pprivate, new_ri);
338 STATIC void reh_teardown(pTHX_ void *root) {
344 ptable_private_free(reh_private_map);
347 /* --- XS ------------------------------------------------------------------ */
349 MODULE = re::engine::Hooks PACKAGE = re::engine::Hooks
355 reh_private_map = ptable_new();
357 MUTEX_INIT(&reh_action_list_mutex);
358 MUTEX_INIT(&reh_private_map_mutex);
360 PERL_HASH(reh_hash, __PACKAGE__, __PACKAGE_LEN__);
362 call_atexit(reh_teardown, aTHX);
364 call_atexit(reh_teardown, NULL);
372 XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
383 REH_LOCK(&reh_action_list_mutex);
385 REH_UNLOCK(&reh_action_list_mutex);
386 s = SvPV_const(key, len);
388 if (a->klen == len && memcmp(a->key, s, len) == 0)