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