#include "perl.h"
#include "XSUB.h"
-#include "Plugin.h"
-
#define __PACKAGE__ "re::engine::Plugin"
#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
/* ... Thread safety and multiplicity ...................................... */
+/* 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
SV *comp;
SV *exec;
#if REP_WORKAROUND_REQUIRE_PROPAGATION
- IV cxreq;
+ IV require_tag;
#endif
} rep_hint_t;
START_MY_CXT
-STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) {
-#define rep_clone(S, O) rep_clone(aTHX_ (S), (O))
- CLONE_PARAMS param;
- AV *stashes = NULL;
- SV *dupsv;
-
- if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
- stashes = newAV();
-
- param.stashes = stashes;
- param.flags = 0;
- param.proto_perl = owner;
-
- dupsv = sv_dup(sv, ¶m);
-
- if (stashes) {
- av_undef(stashes);
- SvREFCNT_dec(stashes);
- }
-
- return SvREFCNT_inc_simple(dupsv);
-}
+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_) {
- my_cxt_t *ud = ud_;
+ rep_ptable_clone_ud *ud = ud_;
rep_hint_t *h1 = ent->val;
rep_hint_t *h2;
- if (ud->owner == aTHX)
- return;
-
- h2 = PerlMemShared_malloc(sizeof *h2);
- h2->comp = rep_clone(h1->comp, ud->owner);
- SvREFCNT_inc_simple_void(h2->comp);
- h2->exec = rep_clone(h1->exec, ud->owner);
- SvREFCNT_inc_simple_void(h2->exec);
+ 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->cxreq = h1->cxreq;
+ h2->require_tag = PTR2IV(rep_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
#endif
ptable_store(ud->tbl, ent->key, h2);
}
-#include "reap.h"
-
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 */
STATIC SV *rep_validate_callback(SV *code) {
#if REP_WORKAROUND_REQUIRE_PROPAGATION
STATIC IV rep_require_tag(pTHX) {
#define rep_require_tag() rep_require_tag(aTHX)
- 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;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
- return PTR2IV(cx);
+ 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;
+ }
+ }
}
+
+ cv = PL_main_cv;
}
- return PTR2IV(NULL);
+get_enclosing_cv:
+ for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
+ cv = outside;
+
+ 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;
- dMY_CXT;
- h = PerlMemShared_malloc(sizeof *h);
- h->comp = rep_validate_callback(comp);
- h->exec = rep_validate_callback(exec);
+ h = PerlMemShared_malloc(sizeof *h);
+ h->comp = rep_validate_callback(comp);
+ h->exec = rep_validate_callback(exec);
#if REP_WORKAROUND_REQUIRE_PROPAGATION
- h->cxreq = rep_require_tag();
+ h->require_tag = rep_require_tag();
#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
#if REP_THREADSAFE
- /* 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);
+ {
+ 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 const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
#define rep_detag(H) rep_detag(aTHX_ (H))
rep_hint_t *h;
- dMY_CXT;
if (!(hint && SvIOK(hint)))
return NULL;
h = INT2PTR(rep_hint_t *, SvIVX(hint));
#if REP_THREADSAFE
- h = ptable_fetch(MY_CXT.tbl, h);
+ {
+ dMY_CXT;
+ h = ptable_fetch(MY_CXT.tbl, h);
+ }
#endif /* REP_THREADSAFE */
#if REP_WORKAROUND_REQUIRE_PROPAGATION
- if (rep_require_tag() != h->cxreq)
+ if (rep_require_tag() != h->require_tag)
return NULL;
#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
return rep_detag(hint);
}
-REGEXP *
-#if PERL_VERSION <= 10
-Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
+/* --- Custom regexp engine ------------------------------------------------ */
+
+#define GET_SELF_FROM_PPRIVATE(pprivate) \
+ re__engine__Plugin self; \
+ SELF_FROM_PPRIVATE(self,pprivate);
+
+/* re__engine__Plugin self; SELF_FROM_PPRIVATE(self,rx->pprivate) */
+#define SELF_FROM_PPRIVATE(self, pprivate) \
+ if (sv_isobject(pprivate)) { \
+ SV * ref = SvRV((SV*)pprivate); \
+ IV tmp = SvIV((SV*)ref); \
+ self = INT2PTR(re__engine__Plugin,tmp); \
+ } else { \
+ Perl_croak(aTHX_ "Not an object"); \
+ }
+
+#if REP_HAS_PERL(5, 19, 4)
+# define REP_ENG_EXEC_MINEND_TYPE SSize_t
+#else
+# define REP_ENG_EXEC_MINEND_TYPE I32
+#endif
+
+START_EXTERN_C
+EXTERN_C const regexp_engine engine_plugin;
+#if REP_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)
+EXTERN_C char * Plugin_intuit(pTHX_ REGEXP * const, SV *, const char * const,
+ char *, char *, U32, re_scream_pos_data *);
+#else
+EXTERN_C char * Plugin_intuit(pTHX_ REGEXP * const, SV *, char *,
+ char *, U32, re_scream_pos_data *);
+#endif
+EXTERN_C SV * Plugin_checkstr(pTHX_ REGEXP * const);
+EXTERN_C void Plugin_free(pTHX_ REGEXP * const);
+EXTERN_C void * Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
+EXTERN_C void Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const,
+ const I32, SV * const);
+EXTERN_C void Plugin_numbered_buff_STORE(pTHX_ REGEXP * const,
+ const I32, SV const * const);
+EXTERN_C I32 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const,
+ const SV * const, const I32);
+EXTERN_C SV * Plugin_named_buff (pTHX_ REGEXP * const, SV * const,
+ SV * const, const U32);
+EXTERN_C SV * Plugin_named_buff_iter (pTHX_ REGEXP * const, const SV * const,
+ const U32);
+EXTERN_C SV * Plugin_package(pTHX_ REGEXP * const);
+#ifdef USE_ITHREADS
+EXTERN_C void * Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
+#endif
+
+EXTERN_C const regexp_engine engine_plugin;
+END_EXTERN_C
+
+#define RE_ENGINE_PLUGIN (&engine_plugin)
+const regexp_engine engine_plugin = {
+ Plugin_comp,
+ Plugin_exec,
+ Plugin_intuit,
+ Plugin_checkstr,
+ Plugin_free,
+ Plugin_numbered_buff_FETCH,
+ Plugin_numbered_buff_STORE,
+ Plugin_numbered_buff_LENGTH,
+ Plugin_named_buff,
+ Plugin_named_buff_iter,
+ Plugin_package
+#if defined(USE_ITHREADS)
+ , Plugin_dupe
+#endif
+#if REP_HAS_PERL(5, 17, 0)
+ , 0
+#endif
+};
+
+typedef struct replug {
+ /* Pointer back to the containing regexp struct so that accessors
+ * can modify nparens, gofs etc. */
+ struct regexp * rx;
+
+ /* A copy of the pattern given to comp, for ->pattern */
+ SV * pattern;
+
+ /* A copy of the string being matched against, for ->str */
+ SV * str;
+
+ /* The ->stash */
+ SV * stash;
+
+ /* Callbacks */
+ SV * cb_exec;
+ SV * cb_free;
+
+ /* ->num_captures */
+ SV * cb_num_capture_buff_FETCH;
+ SV * cb_num_capture_buff_STORE;
+ SV * cb_num_capture_buff_LENGTH;
+} *re__engine__Plugin;
+
+#if REP_HAS_PERL(5, 11, 0)
+# define rxREGEXP(RX) (SvANY(RX))
+# define newREGEXP(RX) ((RX) = ((REGEXP*) newSV_type(SVt_REGEXP)))
#else
+# define rxREGEXP(RX) (RX)
+# define newREGEXP(RX) (Newxz((RX), 1, struct regexp))
+#endif
+
+REGEXP *
+#if REP_HAS_PERL(5, 11, 0)
Plugin_comp(pTHX_ SV * const pattern, U32 flags)
+#else
+Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
#endif
{
dSP;
rx->extflags = flags; /* Flags for perl to use */
rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
-#if PERL_VERSION <= 10
+#if !REP_HAS_PERL(5, 11, 0)
rx->refcnt = 1; /* Refcount so we won't be destroyed */
/* Precompiled pattern for pp_regcomp to use */
* already set up all the stuff we're going to to need for
* subsequent exec and other calls */
if (h->comp) {
- ENTER;
+ ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(obj);
PUTBACK;
I32
Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
- char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
+ char *strbeg, REP_ENG_EXEC_MINEND_TYPE minend,
+ SV *sv, void *data, U32 flags)
{
dSP;
I32 matched;
ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(rx->pprivate);
XPUSHs(sv);
PUTBACK;
call_sv(self->cb_exec, G_SCALAR);
-
+
SPAGAIN;
ret = POPs;
}
char *
+#if REP_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
Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
- char *strend, U32 flags, re_scream_pos_data *data)
+ char *strend, U32 flags, re_scream_pos_data *data)
+#endif
{
PERL_UNUSED_ARG(RX);
PERL_UNUSED_ARG(sv);
+#if REP_HAS_PERL(5, 19, 1)
+ PERL_UNUSED_ARG(strbeg);
+#endif
PERL_UNUSED_ARG(strpos);
PERL_UNUSED_ARG(strend);
PERL_UNUSED_ARG(flags);
void
Plugin_free(pTHX_ REGEXP * const RX)
{
- struct regexp *rx = rxREGEXP(RX);
- GET_SELF_FROM_PPRIVATE(rx->pprivate);
+ struct regexp *rx;
+ re__engine__Plugin self;
+
+ if (PL_dirty)
+ return;
+
+ rx = rxREGEXP(RX);
+ SELF_FROM_PPRIVATE(self, rx->pprivate);
SvREFCNT_dec(self->pattern);
SvREFCNT_dec(self->str);
if (callback) {
ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(rx->pprivate);
PUTBACK;
if (callback) {
ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(rx->pprivate);
XPUSHs(sv_2mortal(newSViv(paren)));
PUTBACK;
items = call_sv(callback, G_SCALAR);
-
+
if (items == 1) {
SV *ret;
if (callback) {
ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(rx->pprivate);
XPUSHs(sv_2mortal(newSViv(paren)));
ENTER;
SAVETMPS;
-
+
PUSHMARK(SP);
XPUSHs(rx->pprivate);
XPUSHs(sv_2mortal(newSViv(paren)));
STATIC U32 rep_initialized = 0;
STATIC void rep_teardown(pTHX_ void *root) {
- dMY_CXT;
-
if (!rep_initialized || aTHX != root)
return;
- ptable_free(MY_CXT.tbl);
+ {
+ dMY_CXT;
+ ptable_free(MY_CXT.tbl);
+ }
rep_initialized = 0;
}
if (rep_initialized)
return;
- MY_CXT_INIT;
- MY_CXT.tbl = ptable_new();
- MY_CXT.owner = aTHX;
+ {
+ MY_CXT_INIT;
+ MY_CXT.tbl = ptable_new();
+ MY_CXT.owner = aTHX;
+ }
call_atexit(rep_teardown, aTHX);
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();
CLONE(...)
PREINIT:
ptable *t;
+ GV *gv;
PPCODE:
{
- my_cxt_t ud;
+ rep_ptable_clone_ud ud;
dMY_CXT;
- ud.tbl = t = ptable_new();
- ud.owner = MY_CXT.owner;
+
+ 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;
}
- reap(3, rep_thread_cleanup, NULL);
+ 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);
XSRETURN(0);
#endif /* REP_THREADSAFE */
projects / perl / modules / re-engine-Plugin.git / blobdiff