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 #ifdef USE_ITHREADS
  21 # define REH_LOCK(M)   MUTEX_LOCK(M)
  22 # define REH_UNLOCK(M) MUTEX_UNLOCK(M)
  23 #else
  24 # define REH_LOCK(M)   NOOP
  25 # define REH_UNLOCK(M) NOOP
  26 #endif
  27
  28 /* --- Lexical hints ------------------------------------------------------- */
  29
  30 STATIC U32 reh_hash = 0;
  31
  32 STATIC SV *reh_hint(pTHX) {
  33 #define reh_hint() reh_hint(aTHX)
  34  SV *hint;
  35
  36 #ifdef cop_hints_fetch_pvn
  37  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
  38                                        reh_hash, 0);
  39 #elif REH_HAS_PERL(5, 9, 5)
  40  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
  41                                        NULL,
  42                                        __PACKAGE__, __PACKAGE_LEN__,
  43                                        0,
  44                                        reh_hash);
  45 #else
  46  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
  47  if (!val)
  48   return 0;
  49  hint = *val;
  50 #endif
  51
  52  return hint;
  53 }
  54
  55 /* --- Public API ---------------------------------------------------------- */
  56
  57 #include "re_engine_hooks.h"
  58
  59 typedef struct reh_action {
  60  struct reh_action *next;
  61  reh_config         cbs;
  62  const char        *key;
  63  STRLEN             klen;
  64 } reh_action;
  65
  66 STATIC reh_action *reh_action_list = 0;
  67
  68 #ifdef USE_ITHREADS
  69
  70 STATIC perl_mutex reh_action_list_mutex;
  71
  72 #endif /* USE_ITHREADS */
  73
  74 #undef reh_register
  75 void reh_register(pTHX_ const char *key, reh_config *cfg) {
  76  reh_action *a;
  77  char       *key_dup;
  78  STRLEN      i, len;
  79
  80  len = strlen(key);
  81  for (i = 0; i < len; ++i)
  82   if (!isALNUM(key[i]) && key[i] != ':')
  83    croak("Invalid key");
  84  key_dup = PerlMemShared_malloc(len + 1);
  85  memcpy(key_dup, key, len);
  86  key_dup[len] = '\0';
  87
  88  a       = PerlMemShared_malloc(sizeof *a);
  89  a->cbs  = *cfg;
  90  a->key  = key_dup;
  91  a->klen = len;
  92
  93  REH_LOCK(&reh_action_list_mutex);
  94  a->next         = reh_action_list;
  95  reh_action_list = a;
  96  REH_UNLOCK(&reh_action_list_mutex);
  97
  98  return;
  99 }
 100
 101 /* --- Private API --------------------------------------------------------- */
 102
 103 void reh_call_comp_hook(pTHX_ regexp *rx, regnode *node) {
 104  SV *hint = reh_hint();
 105
 106  if (hint && SvPOK(hint)) {
 107   STRLEN      len;
 108   const char *keys = SvPV_const(hint, len);
 109   reh_action *a;
 110
 111   REH_LOCK(&reh_action_list_mutex);
 112   a = reh_action_list;
 113   REH_UNLOCK(&reh_action_list_mutex);
 114
 115   for (; a; a = a->next) {
 116    if (a->cbs.comp) {
 117     char *p = strstr(keys, a->key);
 118
 119     if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
 120      a->cbs.comp(aTHX_ rx, node);
 121    }
 122   }
 123  }
 124 }
 125
 126 void reh_call_exec_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
 127  SV *hint = reh_hint();
 128
 129  if (hint && SvPOK(hint)) {
 130   STRLEN      len;
 131   const char *keys = SvPV_const(hint, len);
 132   reh_action *a;
 133
 134   REH_LOCK(&reh_action_list_mutex);
 135   a = reh_action_list;
 136   REH_UNLOCK(&reh_action_list_mutex);
 137
 138   for (; a; a = a->next) {
 139    if (a->cbs.exec) {
 140     char *p = strstr(keys, a->key);
 141
 142     if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
 143      a->cbs.exec(aTHX_ rx, node, reginfo, st);
 144    }
 145   }
 146  }
 147 }
 148
 149 /* --- Custom regexp engine ------------------------------------------------ */
 150
 151 #if PERL_VERSION <= 10
 152 # define rxREGEXP(RX)  (RX)
 153 #else
 154 # define rxREGEXP(RX)  (SvANY(RX))
 155 #endif
 156
 157 #if PERL_VERSION <= 10
 158 EXTERN_C REGEXP *reh_regcomp(pTHX_ const SV * const, const U32);
 159 #else
 160 EXTERN_C REGEXP *reh_regcomp(pTHX_ SV * const, U32);
 161 #endif
 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);
 179 #ifdef USE_ITHREADS
 180 EXTERN_C void *  reh_regdupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
 181 #endif
 182
 183 EXTERN_C const struct regexp_engine reh_regexp_engine;
 184
 185 REGEXP *
 186 #if PERL_VERSION <= 10
 187 reh_re_compile(pTHX_ const SV * const pattern, const U32 flags)
 188 #else
 189 reh_re_compile(pTHX_ SV * const pattern, U32 flags)
 190 #endif
 191 {
 192  struct regexp *rx;
 193  REGEXP        *RX;
 194
 195  RX = reh_regcomp(aTHX_ pattern, flags);
 196  rx = rxREGEXP(RX);
 197
 198  rx->engine = &reh_regexp_engine;
 199
 200  return RX;
 201 }
 202
 203 const struct regexp_engine reh_regexp_engine = {
 204  reh_re_compile,
 205  reh_regexec,
 206  reh_re_intuit_start,
 207  reh_re_intuit_string,
 208  reh_regfree,
 209  reh_reg_numbered_buff_fetch,
 210  reh_reg_numbered_buff_store,
 211  reh_reg_numbered_buff_length,
 212  reh_reg_named_buff,
 213  reh_reg_named_buff_iter,
 214  reh_reg_qr_package,
 215 #if defined(USE_ITHREADS)
 216  reh_regdupe
 217 #endif
 218 };
 219
 220 /* --- XS ------------------------------------------------------------------ */
 221
 222 MODULE = re::engine::Hooks          PACKAGE = re::engine::Hooks
 223
 224 PROTOTYPES: ENABLE
 225
 226 BOOT:
 227 {
 228 #ifdef USE_ITHREADS
 229  MUTEX_INIT(&reh_action_list_mutex);
 230 #endif
 231
 232  PERL_HASH(reh_hash, __PACKAGE__, __PACKAGE_LEN__);
 233 }
 234
 235 void
 236 _ENGINE()
 237 PROTOTYPE:
 238 PPCODE:
 239  XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
 240
 241 void
 242 _registered(SV *key)
 243 PROTOTYPE: $
 244 PREINIT:
 245  SV         *ret = NULL;
 246  reh_action *a;
 247  STRLEN      len;
 248  const char *s;
 249 PPCODE:
 250  REH_LOCK(&reh_action_list_mutex);
 251  a = reh_action_list;
 252  REH_UNLOCK(&reh_action_list_mutex);
 253  s = SvPV_const(key, len);
 254  while (a && !ret) {
 255   if (a->klen == len && memcmp(a->key, s, len) == 0)
 256    ret = &PL_sv_yes;
 257   a = a->next;
 258  }
 259  if (!ret)
 260   ret = &PL_sv_no;
 261  EXTEND(SP, 1);
 262  PUSHs(ret);
 263  XSRETURN(1);