X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=blobdiff_plain;f=Plugin.xs;h=d19fc465f31af2b55c40028725d9db82f2b6dd14;hp=b4db0bd724ac2553ef2711c7d2da51df88437209;hb=4c4a1920feccc332a57cea1bdf42ed240fb65deb;hpb=e02ec00bb493de1c7edf6bd1ebeb4c8fd2a40213

diff --git a/Plugin.xs b/Plugin.xs
index b4db0bd..d19fc46 100644
--- a/Plugin.xs
+++ b/Plugin.xs
@@ -6,166 +6,19 @@
 #include "perl.h"
 #include "XSUB.h"
 
-#define __PACKAGE__     "re::engine::Plugin"
-#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
-
-#define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+/* --- Helpers ------------------------------------------------------------- */
 
-#ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
-# define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
-#endif
+#define XSH_PACKAGE "re::engine::Plugin"
 
-/* ... Thread safety and multiplicity ...................................... */
+#include "xsh/caps.h"
+#include "xsh/util.h"
 
-/* Safe unless stated otherwise in Makefile.PL */
-#ifndef REP_FORKSAFE
-# define REP_FORKSAFE 1
-#endif
-
-#ifndef REP_MULTIPLICITY
-# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
-#  define REP_MULTIPLICITY 1
-# else
-#  define REP_MULTIPLICITY 0
-# endif
-#endif
-#if REP_MULTIPLICITY && !defined(tTHX)
-# define tTHX PerlInterpreter*
-#endif
-
-#if REP_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
-# define REP_THREADSAFE 1
-# ifndef MY_CXT_CLONE
-#  define MY_CXT_CLONE \
-    dMY_CXT_SV;                                                      \
-    my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
-    Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
-    sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
-# endif
-#else
-# define REP_THREADSAFE 0
-# undef  dMY_CXT
-# define dMY_CXT      dNOOP
-# undef  MY_CXT
-# define MY_CXT       rep_globaldata
-# undef  START_MY_CXT
-# define START_MY_CXT STATIC my_cxt_t MY_CXT;
-# undef  MY_CXT_INIT
-# define MY_CXT_INIT  NOOP
-# undef  MY_CXT_CLONE
-# define MY_CXT_CLONE NOOP
-#endif
-
-/* --- Helpers ------------------------------------------------------------- */
-
-/* ... Thread-safe hints ................................................... */
+/* ... Lexical hints ....................................................... */
 
 typedef struct {
  SV *comp;
  SV *exec;
-#if REP_WORKAROUND_REQUIRE_PROPAGATION
- IV  require_tag;
-#endif
-} rep_hint_t;
-
-#if REP_THREADSAFE
-
-#define PTABLE_VAL_FREE(V) { \
- rep_hint_t *h = (V);        \
- SvREFCNT_dec(h->comp);      \
- SvREFCNT_dec(h->exec);      \
- PerlMemShared_free(h);      \
-}
-
-#define pPTBL  pTHX
-#define pPTBL_ pTHX_
-#define aPTBL  aTHX
-#define aPTBL_ aTHX_
-
-#include "ptable.h"
-
-#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
-#define ptable_free(T)        ptable_free(aTHX_ (T))
-
-#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
-
-typedef struct {
- ptable *tbl;
- tTHX    owner;
-} my_cxt_t;
-
-START_MY_CXT
-
-typedef struct {
- ptable *tbl;
-#if REP_HAS_PERL(5, 13, 2)
- CLONE_PARAMS *params;
-#else
- CLONE_PARAMS params;
-#endif
-} rep_ptable_clone_ud;
-
-#if REP_HAS_PERL(5, 13, 2)
-# define rep_ptable_clone_ud_init(U, T, O) \
-   (U).tbl    = (T); \
-   (U).params = Perl_clone_params_new((O), aTHX)
-# define rep_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
-# define rep_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
-#else
-# define rep_ptable_clone_ud_init(U, T, O) \
-   (U).tbl               = (T);     \
-   (U).params.stashes    = newAV(); \
-   (U).params.flags      = 0;       \
-   (U).params.proto_perl = (O)
-# define rep_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
-# define rep_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
-#endif
-
-STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
- rep_ptable_clone_ud *ud = ud_;
- rep_hint_t *h1 = ent->val;
- rep_hint_t *h2;
-
- h2              = PerlMemShared_malloc(sizeof *h2);
- h2->comp        = rep_dup_inc(h1->comp, ud);
- h2->exec        = rep_dup_inc(h1->exec, ud);
-#if REP_WORKAROUND_REQUIRE_PROPAGATION
- h2->require_tag = PTR2IV(rep_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
-#endif
-
- ptable_store(ud->tbl, ent->key, h2);
-}
-
-STATIC void rep_thread_cleanup(pTHX_ void *ud) {
- dMY_CXT;
-
- ptable_free(MY_CXT.tbl);
-}
-
-STATIC int rep_endav_free(pTHX_ SV *sv, MAGIC *mg) {
- SAVEDESTRUCTOR_X(rep_thread_cleanup, NULL);
-
- return 0;
-}
-
-STATIC MGVTBL rep_endav_vtbl = {
- 0,
- 0,
- 0,
- 0,
- rep_endav_free
-#if MGf_COPY
- , 0
-#endif
-#if MGf_DUP
- , 0
-#endif
-#if MGf_LOCAL
- , 0
-#endif
-};
-
-#endif /* REP_THREADSAFE */
+} xsh_hints_user_t;
 
 STATIC SV *rep_validate_callback(SV *code) {
  if (!SvROK(code))
@@ -178,119 +31,47 @@ STATIC SV *rep_validate_callback(SV *code) {
  return SvREFCNT_inc_simple_NN(code);
 }
 
-#if REP_WORKAROUND_REQUIRE_PROPAGATION
-STATIC IV rep_require_tag(pTHX) {
-#define rep_require_tag() rep_require_tag(aTHX)
- const CV *cv, *outside;
-
- cv = PL_compcv;
-
- if (!cv) {
-  /* If for some reason the pragma is operational at run-time, try to discover
-   * the current cv in use. */
-  const PERL_SI *si;
-
-  for (si = PL_curstackinfo; si; si = si->si_prev) {
-   I32 cxix;
-
-   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
-    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
-    switch (CxTYPE(cx)) {
-     case CXt_SUB:
-     case CXt_FORMAT:
-      /* The propagation workaround is only needed up to 5.10.0 and at that
-       * time format and sub contexts were still identical. And even later the
-       * cv members offsets should have been kept the same. */
-      cv = cx->blk_sub.cv;
-      goto get_enclosing_cv;
-     case CXt_EVAL:
-      cv = cx->blk_eval.cv;
-      goto get_enclosing_cv;
-     default:
-      break;
-    }
-   }
-  }
+static void xsh_hints_user_init(pTHX_ xsh_hints_user_t *hv, xsh_hints_user_t *v) {
+ hv->comp = rep_validate_callback(v->comp);
+ hv->exec = rep_validate_callback(v->exec);
 
-  cv = PL_main_cv;
- }
+ return;
+}
 
-get_enclosing_cv:
- for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
-  cv = outside;
+#if XSH_THREADSAFE
 
- return PTR2IV(cv);
-}
-#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
-
-STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
-#define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
- rep_hint_t *h;
-
- h              = PerlMemShared_malloc(sizeof *h);
- h->comp        = rep_validate_callback(comp);
- h->exec        = rep_validate_callback(exec);
-#if REP_WORKAROUND_REQUIRE_PROPAGATION
- h->require_tag = rep_require_tag();
-#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
-
-#if REP_THREADSAFE
- {
-  dMY_CXT;
-  /* We only need for the key to be an unique tag for looking up the value later
-   * Allocated memory provides convenient unique identifiers, so that's why we
-   * use the hint as the key itself. */
-  ptable_store(MY_CXT.tbl, h, h);
- }
-#endif /* REP_THREADSAFE */
-
- return newSViv(PTR2IV(h));
+static void xsh_hints_user_clone(pTHX_ xsh_hints_user_t *nv, xsh_hints_user_t *ov, CLONE_PARAMS *params) {
+ nv->comp = xsh_dup_inc(ov->comp, params);
+ nv->exec = xsh_dup_inc(ov->exec, params);
+
+ return;
 }
 
-STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
-#define rep_detag(H) rep_detag(aTHX_ (H))
- rep_hint_t *h;
+#endif /* XSH_THREADSAFE */
 
- if (!(hint && SvIOK(hint)))
-  return NULL;
+static void xsh_hints_user_deinit(pTHX_ xsh_hints_user_t *hv) {
+ SvREFCNT_dec(hv->comp);
+ SvREFCNT_dec(hv->exec);
 
- h = INT2PTR(rep_hint_t *, SvIVX(hint));
-#if REP_THREADSAFE
- {
-  dMY_CXT;
-  h = ptable_fetch(MY_CXT.tbl, h);
- }
-#endif /* REP_THREADSAFE */
+ return;
+}
 
-#if REP_WORKAROUND_REQUIRE_PROPAGATION
- if (rep_require_tag() != h->require_tag)
-  return NULL;
-#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
+#define rep_hint() xsh_hints_detag(xsh_hints_fetch())
 
- return h;
-}
+#define XSH_HINTS_TYPE_USER         1
+#define XSH_HINTS_ONLY_COMPILE_TIME 0
 
-STATIC U32 rep_hash = 0;
+#include "xsh/hints.h"
 
-STATIC const rep_hint_t *rep_hint(pTHX) {
-#define rep_hint() rep_hint(aTHX)
- SV *hint;
+/* ... Thread-local storage ................................................ */
 
-#ifdef cop_hints_fetch_pvn
- hint = cop_hints_fetch_pvn(PL_curcop,
-                            __PACKAGE__, __PACKAGE_LEN__, rep_hash, 0);
-#else
- /* We already require 5.9.5 for the regexp engine API. */
- hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
-                                       NULL,
-                                       __PACKAGE__, __PACKAGE_LEN__,
-                                       0,
-                                       rep_hash);
-#endif
+#define XSH_THREADS_USER_CONTEXT            0
+#define XSH_THREADS_USER_LOCAL_SETUP        0
+#define XSH_THREADS_USER_LOCAL_TEARDOWN     0
+#define XSH_THREADS_USER_GLOBAL_TEARDOWN    0
+#define XSH_THREADS_COMPILE_TIME_PROTECTION 0
 
- return rep_detag(hint);
-}
+#include "xsh/threads.h"
 
 /* --- Custom regexp engine ------------------------------------------------ */
 
@@ -308,7 +89,7 @@ STATIC const rep_hint_t *rep_hint(pTHX) {
         Perl_croak(aTHX_ "Not an object");                   \
     }
 
-#if REP_HAS_PERL(5, 19, 4)
+#if XSH_HAS_PERL(5, 19, 4)
 # define REP_ENG_EXEC_MINEND_TYPE SSize_t
 #else
 # define REP_ENG_EXEC_MINEND_TYPE I32
@@ -316,14 +97,14 @@ STATIC const rep_hint_t *rep_hint(pTHX) {
 
 START_EXTERN_C
 EXTERN_C const regexp_engine engine_plugin;
-#if REP_HAS_PERL(5, 11, 0)
+#if XSH_HAS_PERL(5, 11, 0)
 EXTERN_C REGEXP * Plugin_comp(pTHX_ SV * const, U32);
 #else
 EXTERN_C REGEXP * Plugin_comp(pTHX_ const SV * const, const U32);
 #endif
 EXTERN_C I32      Plugin_exec(pTHX_ REGEXP * const, char *, char *,
                               char *, REP_ENG_EXEC_MINEND_TYPE, SV *, void *, U32);
-#if REP_HAS_PERL(5, 19, 1)
+#if XSH_HAS_PERL(5, 19, 1)
 EXTERN_C char *   Plugin_intuit(pTHX_ REGEXP * const, SV *, const char * const,
                                 char *, char *, U32, re_scream_pos_data *);
 #else
@@ -367,7 +148,7 @@ const regexp_engine engine_plugin = {
 #if defined(USE_ITHREADS)
     , Plugin_dupe
 #endif
-#if REP_HAS_PERL(5, 17, 0)
+#if XSH_HAS_PERL(5, 17, 0)
     , 0
 #endif
 };
@@ -396,7 +177,7 @@ typedef struct replug {
     SV * cb_num_capture_buff_LENGTH;
 } *re__engine__Plugin;
 
-#if REP_HAS_PERL(5, 11, 0)
+#if XSH_HAS_PERL(5, 11, 0)
 # define rxREGEXP(RX)  (SvANY(RX))
 # define newREGEXP(RX) ((RX) = ((REGEXP*) newSV_type(SVt_REGEXP)))
 #else
@@ -405,7 +186,7 @@ typedef struct replug {
 #endif
 
 REGEXP *
-#if REP_HAS_PERL(5, 11, 0)
+#if XSH_HAS_PERL(5, 11, 0)
 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
 #else
 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
@@ -416,7 +197,7 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
     REGEXP *RX;
 
     re__engine__Plugin re;
-    const rep_hint_t *h;
+    const xsh_hints_user_t *h;
 
     STRLEN plen;
     char *pbuf;
@@ -444,7 +225,7 @@ Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
     rx->extflags = flags;          /* Flags for perl to use */
     rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
 
-#if !REP_HAS_PERL(5, 11, 0)
+#if !XSH_HAS_PERL(5, 11, 0)
     rx->refcnt = 1;                /* Refcount so we won't be destroyed */
 
     /* Precompiled pattern for pp_regcomp to use */
@@ -551,7 +332,7 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
 }
 
 char *
-#if REP_HAS_PERL(5, 19, 1)
+#if XSH_HAS_PERL(5, 19, 1)
 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, const char * const strbeg,
               char *strpos, char *strend, U32 flags, re_scream_pos_data *data)
 #else
@@ -561,7 +342,7 @@ Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
 {
     PERL_UNUSED_ARG(RX);
     PERL_UNUSED_ARG(sv);
-#if REP_HAS_PERL(5, 19, 1)
+#if XSH_HAS_PERL(5, 19, 1)
     PERL_UNUSED_ARG(strbeg);
 #endif
     PERL_UNUSED_ARG(strpos);
@@ -766,46 +547,16 @@ Plugin_package(pTHX_ REGEXP * const RX)
     return newSVpvs("re::engine::Plugin");
 }
 
-#if REP_THREADSAFE
-
-STATIC U32 rep_initialized = 0;
-
-STATIC void rep_teardown(pTHX_ void *root) {
- if (!rep_initialized || aTHX != root)
-  return;
-
- {
-  dMY_CXT;
-  ptable_free(MY_CXT.tbl);
- }
-
- rep_initialized = 0;
-}
+static void xsh_user_global_setup(pTHX) {
+     HV *stash;
 
-STATIC void rep_setup(pTHX) {
-#define rep_setup() rep_setup(aTHX)
- if (rep_initialized)
-  return;
+     stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
+     newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(XSH_THREADSAFE));
+     newCONSTSUB(stash, "REP_FORKSAFE",   newSVuv(XSH_FORKSAFE));
 
- {
-  MY_CXT_INIT;
-  MY_CXT.tbl   = ptable_new();
-  MY_CXT.owner = aTHX;
- }
-
- call_atexit(rep_teardown, aTHX);
-
- rep_initialized = 1;
+    return;
 }
 
-#else  /*  REP_THREADSAFE */
-
-#define rep_setup()
-
-#endif /* !REP_THREADSAFE */
-
-STATIC U32 rep_booted = 0;
-
 /* --- XS ------------------------------------------------------------------ */
 
 MODULE = re::engine::Plugin       PACKAGE = re::engine::Plugin
@@ -814,61 +565,18 @@ PROTOTYPES: DISABLE
 
 BOOT:
 {
-    if (!rep_booted++) {
-        HV *stash;
-
-        PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
-
-        stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
-        newCONSTSUB(stash, "REP_THREADSAFE",  newSVuv(REP_THREADSAFE));
-        newCONSTSUB(stash, "REP_FORKSAFE",    newSVuv(REP_FORKSAFE));
-    }
-
-    rep_setup();
+    xsh_setup();
 }
 
-#if REP_THREADSAFE
+#if XSH_THREADSAFE
 
 void
 CLONE(...)
-PREINIT:
-    ptable *t;
-    GV     *gv;
-PPCODE:
-    {
-        rep_ptable_clone_ud ud;
-        dMY_CXT;
-
-        t = ptable_new();
-        rep_ptable_clone_ud_init(ud, t, MY_CXT.owner);
-        ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
-        rep_ptable_clone_ud_deinit(ud);
-    }
-    {
-        MY_CXT_CLONE;
-        MY_CXT.tbl   = t;
-        MY_CXT.owner = aTHX;
-    }
-    gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
-    if (gv) {
-        CV *cv = GvCV(gv);
-        if (!PL_endav)
-            PL_endav = newAV();
-        SvREFCNT_inc(cv);
-        if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
-            SvREFCNT_dec(cv);
-        sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &rep_endav_vtbl, NULL, 0);
-    }
-    XSRETURN(0);
-
-void
-_THREAD_CLEANUP(...)
-PROTOTYPE: DISABLE
 PPCODE:
-    rep_thread_cleanup(aTHX_ NULL);
+    xsh_clone();
     XSRETURN(0);
 
-#endif /* REP_THREADSAFE */
+#endif /* XSH_THREADSAFE */
 
 void
 pattern(re::engine::Plugin self, ...)
@@ -998,8 +706,12 @@ PPCODE:
 
 SV *
 _tag(SV *comp, SV *exec)
+PREINIT:
+    xsh_hints_user_t arg;
 CODE:
-    RETVAL = rep_tag(comp, exec);
+    arg.comp = comp;
+    arg.exec = exec;
+    RETVAL = xsh_hints_tag(&arg);
 OUTPUT:
     RETVAL