]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - Hooks.xs
This is 0.01
[perl/modules/re-engine-Hooks.git] / Hooks.xs
1 /* This file is part of the re::engine::Hooks Perl module.
2  * See http://search.cpan.org/dist/re-engine-Hooks/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #define __PACKAGE__     "re::engine::Hooks"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
11
12 /* --- Compatibility wrappers ---------------------------------------------- */
13
14 #define REH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
15
16 #ifndef SvPV_const
17 # define SvPV_const(S, L) SvPV(S, L)
18 #endif
19
20 /* --- Lexical hints ------------------------------------------------------- */
21
22 STATIC U32 reh_hash = 0;
23
24 STATIC SV *reh_hint(pTHX) {
25 #define reh_hint() reh_hint(aTHX)
26  SV *hint;
27
28 #ifdef cop_hints_fetch_pvn
29  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
30                                        reh_hash, 0);
31 #elif REH_HAS_PERL(5, 9, 5)
32  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
33                                        NULL,
34                                        __PACKAGE__, __PACKAGE_LEN__,
35                                        0,
36                                        reh_hash);
37 #else
38  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
39  if (!val)
40   return 0;
41  hint = *val;
42 #endif
43
44  return hint;
45 }
46
47 /* --- Public API ---------------------------------------------------------- */
48
49 #include "re_engine_hooks.h"
50
51 typedef struct reh_action {
52  struct reh_action *next;
53  reh_comp_hook      comp;
54  reh_exec_hook      exec;
55  const char        *key;
56  STRLEN             klen;
57 } reh_action;
58
59 STATIC reh_action *reh_action_list = 0;
60
61 #undef reh_register
62 void reh_register(pTHX_ const char *key, reh_comp_hook comp, reh_exec_hook exec) {
63  reh_action *a;
64  char       *key_dup;
65  STRLEN      i, len;
66
67  len = strlen(key);
68  for (i = 0; i < len; ++i)
69   if (!isALNUM(key[i]) && key[i] != ':')
70    croak("Invalid key");
71  key_dup = PerlMemShared_malloc(len + 1);
72  memcpy(key_dup, key, len);
73  key_dup[len] = '\0';
74
75  a       = PerlMemShared_malloc(sizeof *a);
76  a->next = reh_action_list;
77  a->comp = comp;
78  a->exec = exec;
79  a->key  = key_dup;
80  a->klen = len;
81
82  reh_action_list = a;
83
84  return;
85 }
86
87 /* --- Private API --------------------------------------------------------- */
88
89 void reh_call_comp_hook(pTHX_ regexp *rx, regnode *node) {
90  SV *hint = reh_hint();
91
92  if (hint && SvPOK(hint)) {
93   STRLEN      len;
94   const char *keys = SvPV_const(hint, len);
95   reh_action *a;
96
97   for (a = reh_action_list; a; a = a->next) {
98    if (a->comp) {
99     char *p = strstr(keys, a->key);
100
101     if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
102      a->comp(aTHX_ rx, node);
103    }
104   }
105  }
106 }
107
108 void reh_call_exec_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
109  SV *hint = reh_hint();
110
111  if (hint && SvPOK(hint)) {
112   STRLEN      len;
113   const char *keys = SvPV_const(hint, len);
114   reh_action *a;
115
116   for (a = reh_action_list; a; a = a->next) {
117    if (a->exec) {
118     char *p = strstr(keys, a->key);
119
120     if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
121      a->exec(aTHX_ rx, node, reginfo, st);
122    }
123   }
124  }
125 }
126
127 /* --- Custom regexp engine ------------------------------------------------ */
128
129 #if PERL_VERSION <= 10
130 # define rxREGEXP(RX)  (RX)
131 #else
132 # define rxREGEXP(RX)  (SvANY(RX))
133 #endif
134
135 #if PERL_VERSION <= 10
136 EXTERN_C REGEXP *reh_regcomp(pTHX_ const SV * const, const U32);
137 #else
138 EXTERN_C REGEXP *reh_regcomp(pTHX_ SV * const, U32);
139 #endif
140 EXTERN_C I32     reh_regexec(pTHX_ REGEXP * const, char *, char *,
141                                    char *, I32, SV *, void *, U32);
142 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *,
143                                            char *, U32, re_scream_pos_data *);
144 EXTERN_C SV *    reh_re_intuit_string(pTHX_ REGEXP * const);
145 EXTERN_C void    reh_regfree(pTHX_ REGEXP * const);
146 EXTERN_C void    reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const,
147                                                    const I32, SV * const);
148 EXTERN_C void    reh_reg_numbered_buff_store(pTHX_ REGEXP * const,
149                                                    const I32, SV const * const);
150 EXTERN_C I32     reh_reg_numbered_buff_length(pTHX_ REGEXP * const,
151                                                    const SV * const, const I32);
152 EXTERN_C SV *    reh_reg_named_buff(pTHX_ REGEXP * const, SV * const,
153                                           SV * const, const U32);
154 EXTERN_C SV *    reh_reg_named_buff_iter(pTHX_ REGEXP * const,
155                                                const SV * const, const U32);
156 EXTERN_C SV *    reh_reg_qr_package(pTHX_ REGEXP * const);
157 #ifdef USE_ITHREADS
158 EXTERN_C void *  reh_regdupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
159 #endif
160
161 EXTERN_C const struct regexp_engine reh_regexp_engine;
162
163 REGEXP *
164 #if PERL_VERSION <= 10
165 reh_re_compile(pTHX_ const SV * const pattern, const U32 flags)
166 #else
167 reh_re_compile(pTHX_ SV * const pattern, U32 flags)
168 #endif
169 {
170  struct regexp *rx;
171  REGEXP        *RX;
172
173  RX = reh_regcomp(aTHX_ pattern, flags);
174  rx = rxREGEXP(RX);
175
176  rx->engine = &reh_regexp_engine;
177
178  return RX;
179 }
180
181 const struct regexp_engine reh_regexp_engine = { 
182  reh_re_compile, 
183  reh_regexec, 
184  reh_re_intuit_start, 
185  reh_re_intuit_string, 
186  reh_regfree, 
187  reh_reg_numbered_buff_fetch,
188  reh_reg_numbered_buff_store,
189  reh_reg_numbered_buff_length,
190  reh_reg_named_buff,
191  reh_reg_named_buff_iter,
192  reh_reg_qr_package,
193 #if defined(USE_ITHREADS)
194  reh_regdupe 
195 #endif
196 };
197
198 /* --- XS ------------------------------------------------------------------ */
199
200 MODULE = re::engine::Hooks          PACKAGE = re::engine::Hooks
201
202 PROTOTYPES: ENABLE
203
204 void
205 _ENGINE()
206 PROTOTYPE:
207 PPCODE:
208  XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
209
210 void
211 _registered(SV *key)
212 PROTOTYPE: $
213 PREINIT:
214  SV         *ret = NULL;
215  reh_action *a   = reh_action_list;
216  STRLEN      len;
217  const char *s;
218 PPCODE:
219  s = SvPV_const(key, len);
220  while (a && !ret) {
221   if (a->klen == len && memcmp(a->key, s, len) == 0)
222    ret = &PL_sv_yes;
223   a = a->next;
224  }
225  if (!ret)
226   ret = &PL_sv_no;
227  EXTEND(SP, 1);
228  PUSHs(ret);
229  XSRETURN(1);