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 /* --- XS helpers ---------------------------------------------------------- */
  10
  11 #define XSH_PACKAGE "re::engine::Hooks"
  12
  13 #include "xsh/caps.h"
  14 #include "xsh/util.h"
  15
  16 /* ... Lexical hints ....................................................... */
  17
  18 #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5)
  19 # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \
  20    Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \
  21                                   (PKG), (PKGLEN), (FLAGS), (PKGHASH))
  22 #endif
  23
  24 STATIC U32 reh_hash = 0;
  25
  26 STATIC SV *reh_hint(pTHX) {
  27 #define reh_hint() reh_hint(aTHX)
  28  SV *hint;
  29
  30 #ifdef cop_hints_fetch_pvn
  31  hint = cop_hints_fetch_pvn(PL_curcop, XSH_PACKAGE, XSH_PACKAGE_LEN,
  32                                        reh_hash, 0);
  33 #else
  34  SV **val = hv_fetch(GvHV(PL_hintgv), XSH_PACKAGE, XSH_PACKAGE_LEN, 0);
  35  hint = val ? *val : NULL;
  36 #endif
  37
  38  return hint;
  39 }
  40
  41 /* ... Thread-local storage ................................................ */
  42
  43 #define XSH_THREADS_USER_CONTEXT        0
  44 #define XSH_THREADS_USER_LOCAL_SETUP    0
  45 #define XSH_THREADS_USER_LOCAL_TEARDOWN 0
  46
  47 #include "xsh/threads.h"
  48
  49 /* --- Compatibility wrappers ---------------------------------------------- */
  50
  51 #ifndef SvPV_const
  52 # define SvPV_const(S, L) SvPV(S, L)
  53 #endif
  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  XSH_LOCK(&reh_action_list_mutex);
  94  a->next         = reh_action_list;
  95  reh_action_list = a;
  96  XSH_UNLOCK(&reh_action_list_mutex);
  97
  98  return;
  99 }
 100
 101 /* --- Custom regexp engine ------------------------------------------------ */
 102
 103 #if PERL_VERSION <= 10
 104 # define rxREGEXP(RX)  (RX)
 105 #else
 106 # define rxREGEXP(RX)  (SvANY(RX))
 107 #endif
 108
 109 #if PERL_VERSION <= 10
 110 EXTERN_C REGEXP *reh_re_compile(pTHX_ const SV * const, const U32);
 111 #else
 112 EXTERN_C REGEXP *reh_re_compile(pTHX_ SV * const, U32);
 113 #endif
 114 #if XSH_HAS_PERL(5, 19, 4)
 115 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, SSize_t, SV *, void *, U32);
 116 #else
 117 EXTERN_C I32     reh_regexec_flags(pTHX_ REGEXP * const, char *, char *, char *, I32, SV *, void *, U32);
 118 #endif
 119 #if XSH_HAS_PERL(5, 19, 1)
 120 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, const char * const, char *, char *, U32, re_scream_pos_data *);
 121 #else
 122 EXTERN_C char *  reh_re_intuit_start(pTHX_ REGEXP * const, SV *, char *, char *, U32, re_scream_pos_data *);
 123 #endif
 124 EXTERN_C SV *    reh_re_intuit_string(pTHX_ REGEXP * const);
 125 EXTERN_C void    reh_re_free(pTHX_ REGEXP * const);
 126 EXTERN_C void    reh_reg_numbered_buff_fetch(pTHX_ REGEXP * const,
 127                                                    const I32, SV * const);
 128 EXTERN_C void    reh_reg_numbered_buff_store(pTHX_ REGEXP * const,
 129                                                    const I32, SV const * const);
 130 EXTERN_C I32     reh_reg_numbered_buff_length(pTHX_ REGEXP * const,
 131                                                    const SV * const, const I32);
 132 EXTERN_C SV *    reh_reg_named_buff(pTHX_ REGEXP * const, SV * const,
 133                                           SV * const, const U32);
 134 EXTERN_C SV *    reh_reg_named_buff_iter(pTHX_ REGEXP * const,
 135                                                const SV * const, const U32);
 136 EXTERN_C SV *    reh_reg_qr_package(pTHX_ REGEXP * const);
 137 #ifdef USE_ITHREADS
 138 EXTERN_C void *  reh_re_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
 139 #endif
 140 #if XSH_HAS_PERL(5, 17, 1)
 141 EXTERN_C REGEXP *reh_re_op_compile(pTHX_ SV ** const, int, OP *, const regexp_engine*, REGEXP *VOL, bool *, U32, U32);
 142 #endif
 143
 144 const struct regexp_engine reh_regexp_engine = {
 145  reh_re_compile,
 146  reh_regexec_flags,
 147  reh_re_intuit_start,
 148  reh_re_intuit_string,
 149  reh_re_free,
 150  reh_reg_numbered_buff_fetch,
 151  reh_reg_numbered_buff_store,
 152  reh_reg_numbered_buff_length,
 153  reh_reg_named_buff,
 154  reh_reg_named_buff_iter,
 155  reh_reg_qr_package
 156 #if defined(USE_ITHREADS)
 157  , reh_re_dupe
 158 #endif
 159 #if XSH_HAS_PERL(5, 17, 1)
 160  , reh_re_op_compile
 161 #endif
 162 };
 163
 164 /* --- Internal regexp structure -> hook list inside-out mapping ----------- */
 165
 166 typedef struct {
 167  size_t            count;
 168  const reh_config *cbs;
 169  U32               refcount;
 170 } reh_private;
 171
 172 STATIC void reh_private_free(pPMS_ reh_private *priv) {
 173 #define reh_private_free(P) reh_private_free(aPMS_ (P))
 174  if (!priv)
 175   return;
 176
 177  if (priv->refcount <= 1) {
 178   PerlMemShared_free((void *) priv->cbs);
 179   PerlMemShared_free(priv);
 180  } else {
 181   --priv->refcount;
 182  }
 183 }
 184
 185 #define PTABLE_NAME             ptable_private
 186 #define PTABLE_VAL_FREE(V)      reh_private_free(V)
 187 #define PTABLE_VAL_NEED_CONTEXT 0
 188
 189 #include "xsh/ptable.h"
 190
 191 #define ptable_private_store(T, K, V) ptable_private_store(aPMS_ (T), (K), (V))
 192 #define ptable_private_delete(T, K)   ptable_private_delete(aPMS_ (T), (K))
 193 #define ptable_private_clear(T)       ptable_private_clear(aPMS_ (T))
 194 #define ptable_private_free(T)        ptable_private_free(aPMS_ (T))
 195
 196 STATIC ptable *reh_private_map;
 197
 198 #ifdef USE_ITHREADS
 199
 200 STATIC perl_mutex reh_private_map_mutex;
 201
 202 #endif /* USE_ITHREADS */
 203
 204 #define REH_PRIVATE_MAP_FOREACH(C) STMT_START {      \
 205  reh_private *priv;                                  \
 206  XSH_LOCK(&reh_private_map_mutex);                   \
 207  priv = ptable_fetch(reh_private_map, rx->pprivate); \
 208  if (priv) {                                         \
 209   const reh_config *cbs = priv->cbs;                 \
 210   if (cbs) {                                         \
 211    const reh_config *end = cbs + priv->count;        \
 212    for (; cbs < end; ++cbs) {                        \
 213     (C);                                             \
 214    }                                                 \
 215   }                                                  \
 216  }                                                   \
 217  XSH_UNLOCK(&reh_private_map_mutex);                 \
 218 } STMT_END
 219
 220 STATIC void reh_private_map_store(pTHX_ void *ri, reh_private *priv) {
 221 #define reh_private_map_store(R, P) reh_private_map_store(aTHX_ (R), (P))
 222  XSH_LOCK(&reh_private_map_mutex);
 223  ptable_private_store(reh_private_map, ri, priv);
 224  XSH_UNLOCK(&reh_private_map_mutex);
 225
 226  return;
 227 }
 228
 229 STATIC void reh_private_map_copy(pTHX_ void *ri_from, void *ri_to) {
 230 #define reh_private_map_copy(F, T) reh_private_map_copy(aTHX_ (F), (T))
 231  reh_private *priv;
 232
 233  XSH_LOCK(&reh_private_map_mutex);
 234  priv = ptable_fetch(reh_private_map, ri_from);
 235  if (priv) {
 236   ++priv->refcount;
 237   ptable_private_store(reh_private_map, ri_to, priv);
 238  }
 239  XSH_UNLOCK(&reh_private_map_mutex);
 240 }
 241
 242 STATIC void reh_private_map_delete(pTHX_ void *ri) {
 243 #define reh_private_map_delete(R) reh_private_map_delete(aTHX_ (R))
 244  XSH_LOCK(&reh_private_map_mutex);
 245  ptable_private_delete(reh_private_map, ri);
 246  XSH_UNLOCK(&reh_private_map_mutex);
 247
 248  return;
 249 }
 250
 251 /* --- Private API --------------------------------------------------------- */
 252
 253 void reh_call_comp_begin_hook(pTHX_ regexp *rx) {
 254  SV *hint = reh_hint();
 255
 256  if (hint && SvPOK(hint)) {
 257   STRLEN      len;
 258   const char *keys  = SvPV_const(hint, len);
 259   size_t      count = 0;
 260
 261   reh_private *priv;
 262   reh_config  *cbs = NULL;
 263   reh_action  *a, *root;
 264
 265   XSH_LOCK(&reh_action_list_mutex);
 266   root = reh_action_list;
 267   XSH_UNLOCK(&reh_action_list_mutex);
 268
 269   for (a = root; a; a = a->next) {
 270    char *p = strstr(keys, a->key);
 271
 272    if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
 273     ++count;
 274   }
 275
 276   if (count) {
 277    size_t i = 0;
 278
 279    cbs = PerlMemShared_malloc(count * sizeof *cbs);
 280
 281    for (a = root; a; a = a->next) {
 282     char *p = strstr(keys, a->key);
 283
 284     if (p && (p + a->klen <= keys + len) && p[a->klen] == ' ')
 285      cbs[i++] = a->cbs;
 286    }
 287   }
 288
 289   priv = PerlMemShared_malloc(sizeof *priv);
 290   priv->count    = count;
 291   priv->cbs      = cbs;
 292   priv->refcount = 1;
 293
 294   rx->engine = &reh_regexp_engine;
 295
 296   reh_private_map_store(rx->pprivate, priv);
 297  }
 298 }
 299
 300 void reh_call_comp_node_hook(pTHX_ regexp *rx, regnode *node) {
 301  REH_PRIVATE_MAP_FOREACH(cbs->comp_node(aTHX_ rx, node));
 302 }
 303
 304 void reh_call_exec_node_hook(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
 305  REH_PRIVATE_MAP_FOREACH(cbs->exec_node(aTHX_ rx, node, reginfo, st));
 306 }
 307
 308 EXTERN_C void reh_regfree_internal(pTHX_ REGEXP * const);
 309
 310 void reh_re_free(pTHX_ REGEXP * const RX) {
 311  regexp *rx = rxREGEXP(RX);
 312
 313  reh_private_map_delete(rx->pprivate);
 314
 315  reh_regfree_internal(aTHX_ RX);
 316 }
 317
 318 #ifdef USE_ITHREADS
 319
 320 EXTERN_C void *reh_regdupe_internal(pTHX_ REGEXP * const, CLONE_PARAMS *);
 321
 322 void *reh_re_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) {
 323  regexp *rx = rxREGEXP(RX);
 324  void   *new_ri;
 325
 326  new_ri = reh_regdupe_internal(aTHX_ RX, param);
 327
 328  reh_private_map_copy(rx->pprivate, new_ri);
 329
 330  return new_ri;
 331 }
 332
 333 #endif
 334
 335 /* --- Module setup/teardown ----------------------------------------------- */
 336
 337 STATIC void xsh_user_global_setup(pTHX) {
 338  PERL_HASH(reh_hash, XSH_PACKAGE, XSH_PACKAGE_LEN);
 339
 340  reh_private_map = ptable_new(8);
 341
 342 #ifdef USE_ITHREADS
 343  MUTEX_INIT(&reh_action_list_mutex);
 344  MUTEX_INIT(&reh_private_map_mutex);
 345 #endif
 346
 347  return;
 348 }
 349
 350 STATIC void xsh_user_global_teardown(pTHX) {
 351  ptable_private_free(reh_private_map);
 352
 353 #ifdef USE_ITHREADS
 354  MUTEX_DESTROY(&reh_private_map_mutex);
 355  MUTEX_DESTROY(&reh_action_list_mutex);
 356 #endif
 357
 358  return;
 359 }
 360
 361 /* --- XS ------------------------------------------------------------------ */
 362
 363 MODULE = re::engine::Hooks          PACKAGE = re::engine::Hooks
 364
 365 PROTOTYPES: ENABLE
 366
 367 BOOT:
 368 {
 369  xsh_setup();
 370 }
 371
 372 void
 373 _ENGINE()
 374 PROTOTYPE:
 375 PPCODE:
 376  XPUSHs(sv_2mortal(newSViv(PTR2IV(&reh_regexp_engine))));
 377
 378 void
 379 _registered(SV *key)
 380 PROTOTYPE: $
 381 PREINIT:
 382  SV         *ret = NULL;
 383  reh_action *a;
 384  STRLEN      len;
 385  const char *s;
 386 PPCODE:
 387  XSH_LOCK(&reh_action_list_mutex);
 388  a = reh_action_list;
 389  XSH_UNLOCK(&reh_action_list_mutex);
 390  s = SvPV_const(key, len);
 391  while (a && !ret) {
 392   if (a->klen == len && memcmp(a->key, s, len) == 0)
 393    ret = &PL_sv_yes;
 394   a = a->next;
 395  }
 396  if (!ret)
 397   ret = &PL_sv_no;
 398  EXTEND(SP, 1);
 399  PUSHs(ret);
 400  XSRETURN(1);