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);