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)
21 # define REH_LOCK(M) MUTEX_LOCK(M)
22 # define REH_UNLOCK(M) MUTEX_UNLOCK(M)
24 # define REH_LOCK(M) NOOP
25 # define REH_UNLOCK(M) NOOP
28 /* --- Lexical hints ------------------------------------------------------- */
30 STATIC U32 reh_hash = 0;
32 STATIC SV *reh_hint(pTHX) {
33 #define reh_hint() reh_hint(aTHX)
36 #ifdef cop_hints_fetch_pvn
37 hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
39 #elif REH_HAS_PERL(5, 9, 5)
40 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
42 __PACKAGE__, __PACKAGE_LEN__,
46 SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
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 REH_LOCK(&reh_action_list_mutex);
94 a->next = reh_action_list;
96 REH_UNLOCK(&reh_action_list_mutex);
101 /* --- Private API --------------------------------------------------------- */
103 void reh_call_comp_hook(pTHX_ regexp *rx, regnode *node) {
104 SV *hint = reh_hint();
106 if (hint && SvPOK(hint)) {
108 const char *keys = SvPV_const(hint, len);
111 REH_LOCK(&reh_action_list_mutex);
113 REH_UNLOCK(&reh_action_list_mutex);
115 for (; a; a = a->next) {
117 char *p = strstr(keys, a->key);
119 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
120 a->cbs.comp(aTHX_ rx, node);
126 void reh_call_exec_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
127 SV *hint = reh_hint();
129 if (hint && SvPOK(hint)) {
131 const char *keys = SvPV_const(hint, len);
134 REH_LOCK(&reh_action_list_mutex);
136 REH_UNLOCK(&reh_action_list_mutex);
138 for (; a; a = a->next) {
140 char *p = strstr(keys, a->key);
142 if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
143 a->cbs.exec(aTHX_ rx, node, reginfo, st);
149 /* --- Custom regexp engine ------------------------------------------------ */
151 #if PERL_VERSION <= 10
152 # define rxREGEXP(RX) (RX)
154 # define rxREGEXP(RX) (SvANY(RX))
157 #if PERL_VERSION <= 10
158 EXTERN_C REGEXP *reh_regcomp(pTHX_ const SV * const, const U32);
160 EXTERN_C REGEXP *reh_regcomp(pTHX_ SV * const, U32);
162 EXTERN_C I32 reh_regexec(pTHX_ REGEXP * const, char *, char *,
163 char *, I32, SV *, void *, U32);
164 EXTERN_C char * reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *,
165 char *, U32, re_scream_pos_data *);
166 EXTERN_C SV * reh_re_intuit_string(pTHX_ REGEXP * const);
167 EXTERN_C void reh_regfree(pTHX_ REGEXP * const);
168 EXTERN_C void reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const,
169 const I32, SV * const);
170 EXTERN_C void reh_reg_numbered_buff_store(pTHX_ REGEXP * const,
171 const I32, SV const * const);
172 EXTERN_C I32 reh_reg_numbered_buff_length(pTHX_ REGEXP * const,
173 const SV * const, const I32);
174 EXTERN_C SV * reh_reg_named_buff(pTHX_ REGEXP * const, SV * const,
175 SV * const, const U32);
176 EXTERN_C SV * reh_reg_named_buff_iter(pTHX_ REGEXP * const,
177 const SV * const, const U32);
178 EXTERN_C SV * reh_reg_qr_package(pTHX_ REGEXP * const);
180 EXTERN_C void * reh_regdupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
183 EXTERN_C const struct regexp_engine reh_regexp_engine;
186 #if PERL_VERSION <= 10
187 reh_re_compile(pTHX_ const SV * const pattern, const U32 flags)
189 reh_re_compile(pTHX_ SV * const pattern, U32 flags)
195 RX = reh_regcomp(aTHX_ pattern, flags);
198 rx->engine = &reh_regexp_engine;
203 const struct regexp_engine reh_regexp_engine = {
207 reh_re_intuit_string,
209 reh_reg_numbered_buff_fetch,
210 reh_reg_numbered_buff_store,
211 reh_reg_numbered_buff_length,
213 reh_reg_named_buff_iter,
215 #if defined(USE_ITHREADS)
220 /* --- XS ------------------------------------------------------------------ */
222 MODULE = re::engine::Hooks PACKAGE = re::engine::Hooks
229 MUTEX_INIT(&reh_action_list_mutex);
232 PERL_HASH(reh_hash, __PACKAGE__, __PACKAGE_LEN__);
239 XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
250 REH_LOCK(&reh_action_list_mutex);
252 REH_UNLOCK(&reh_action_list_mutex);
253 s = SvPV_const(key, len);
255 if (a->klen == len && memcmp(a->key, s, len) == 0)