X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Plugin.git;a=blobdiff_plain;f=Plugin.xs;h=ec8c0fe3094a19a2cd8d5dd0e5f83555c031ccf3;hp=07a73d2f2338216ffc5587b5e3384539561edde6;hb=8841074697e50dc9be0faf100e25e540968a2d9a;hpb=def98fc0d7f5e9527b28af6b90d4ddb07fbc845c diff --git a/Plugin.xs b/Plugin.xs index 07a73d2..ec8c0fe 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -1,192 +1,364 @@ +/* This file is part of the re::engine::Plugin Perl module. + * See http://search.cpan.org/dist/re-engine-Plugin/ */ + +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) +#include "Plugin.h" -START_EXTERN_C +#define __PACKAGE__ "re::engine::Plugin" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) -EXTERN_C const regexp_engine engine_plugin; +#define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) -END_EXTERN_C +#ifndef REP_WORKAROUND_REQUIRE_PROPAGATION +# define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1) +#endif -/* - * Our struct which gets initiated and used as our object - * ($re). Since we can't count on the regexp structure provided by - * perl to be alive between comp/exec etc. we pull stuff from it and - * save it in our own structure. - * - * Besides, creating Perl accessors which directly muck with perl's - * own regexp structures in different phases of regex execution would - * be a little too evil. - */ -typedef struct replug { - SV * pattern; - char flags[sizeof("ecgimsxp")]; - - I32 minlen; - U32 gofs; - - SV * stash; - - U32 nparens; - AV * captures; /* Array of SV* that'll become $1, $2, ... */ -} *re__engine__Plugin; +/* ... Thread safety and multiplicity ...................................... */ -SV* -get_H_callback(const char* key) -{ - dVAR; - dSP; +/* Safe unless stated otherwise in Makefile.PL */ +#ifndef REP_FORKSAFE +# define REP_FORKSAFE 1 +#endif - SV * callback; +#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 ................................................... */ + +typedef struct { + SV *comp; + SV *exec; +#if REP_WORKAROUND_REQUIRE_PROPAGATION + IV require_tag; +#endif +} rep_hint_t; + +#if REP_THREADSAFE - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(key, 0))); - PUTBACK; +#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" - call_pv("re::engine::Plugin::get_callback", G_SCALAR); +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_free(T) ptable_free(aTHX_ (T)) - SPAGAIN; +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - callback = POPs; - SvREFCNT_inc(callback); +typedef struct { + ptable *tbl; + tTHX owner; +} my_cxt_t; - if (!SvROK(callback)) { callback = NULL; }// croak("ret value not a ref"); } +START_MY_CXT - PUTBACK; - FREETMPS; - LEAVE; +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 - return callback; +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); } -/* just learn to use gdb you lazy bum! */ -#if 0 -void -dump_r_info(const char* id, regexp *r) -{ - warn("%s:", id); - warn("\textflags = %d", r->extflags); - warn("\tminlen = %d", r->minlen); - warn("\tminlenren = %d", r->minlenret); - warn("\tgofs = %d", r->gofs); - warn("\tnparens = %d", r->nparens); - warn("\tpprivate = %p", r->pprivate); - warn("\tsubbeg = %s", r->subbeg); - warn("\tsublen = %d", r->sublen); - warn("\tprecomp = %s", r->precomp); - warn("\tprelen = %d", r->prelen); - warn("\twrapped = %s", r->wrapped); - warn("\twraplen = %d", r->wraplen); - warn("\tseen_evals = %d", r->seen_evals); - warn("\trefcnt = %d", r->refcnt); - +#include "reap.h" + +STATIC void rep_thread_cleanup(pTHX_ void *ud) { + dMY_CXT; + + ptable_free(MY_CXT.tbl); } -#endif -regexp * -Plugin_comp(pTHX_ char *exp, char *xend, PMOP *pm) -{ - dSP; - register regexp *r; - int count; - - /* - * Allocate a new regexp struct, we must only write to the intflags, - * engine and private members and the others must be populated, - * internals expect the regex to have certain values least our code - * blow up - */ +#endif /* REP_THREADSAFE */ + +STATIC SV *rep_validate_callback(SV *code) { + if (!SvROK(code)) + return NULL; - Newxz(r,1,regexp); + code = SvRV(code); + if (SvTYPE(code) < SVt_PVCV) + return NULL; - /* Set up the regex to be handled by this plugin */ - r->engine = &engine_plugin; + return SvREFCNT_inc_simple_NN(code); +} - /* Store the initial flags */ - r->intflags = pm->op_pmflags; - r->pprivate = NULL; /* this is set to our object below */ +#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; + } + } + } - /* - * Populate the regexp members for the engine - */ + cv = PL_main_cv; + } - /* Ref count of the pattern */ - r->refcnt = 1; +get_enclosing_cv: + for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) + cv = outside; - /* Preserve a copy of the original pattern */ - r->prelen = xend - exp; - r->precomp = SAVEPVN(exp, r->prelen); + 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)); +} - /* these may be changed by accessors */ - r->minlen = 0; - r->minlenret = 0; - r->gofs = 0; - r->nparens = 0; +STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) { +#define rep_detag(H) rep_detag(aTHX_ (H)) + rep_hint_t *h; - /* Store the flags as perl expects them */ - r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; + if (!(hint && SvIOK(hint))) + return NULL; + + h = INT2PTR(rep_hint_t *, SvIVX(hint)); +#if REP_THREADSAFE + { + dMY_CXT; + h = ptable_fetch(MY_CXT.tbl, h); + } +#endif /* REP_THREADSAFE */ + +#if REP_WORKAROUND_REQUIRE_PROPAGATION + if (rep_require_tag() != h->require_tag) + return NULL; +#endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */ + + return h; +} + +STATIC U32 rep_hash = 0; + +STATIC const rep_hint_t *rep_hint(pTHX) { +#define rep_hint() rep_hint(aTHX) + SV *hint; + +#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 + + return rep_detag(hint); +} + +REGEXP * +#if PERL_VERSION <= 10 +Plugin_comp(pTHX_ const SV * const pattern, const U32 flags) +#else +Plugin_comp(pTHX_ SV * const pattern, U32 flags) +#endif +{ + dSP; + struct regexp * rx; + REGEXP *RX; - /* - * Construct a new B object that'll carry around - * our data inside C<< r->pprivate >>. The object is a blessed void* - * that points to our replug struct which holds any state we want to - * keep. - */ re__engine__Plugin re; - Newz(0, re, 1, struct replug); - - SV *obj = newSV(0); - SvREFCNT_inc(obj); + const rep_hint_t *h; - /* Bless into this package; TODO: make it subclassable */ - const char * pkg = "re::engine::Plugin"; - /* bless it */ - sv_setref_pv(obj, pkg, (void*)re); + STRLEN plen; + char *pbuf; - /* Store our private object */ - r->pprivate = obj; + SV *obj; + + h = rep_hint(); + if (!h) /* This looks like a pragma leak. Apply the default behaviour */ + return re_compile(pattern, flags); + + /* exp/xend version of the pattern & length */ + pbuf = SvPV((SV*)pattern, plen); + + /* Our blessed object */ + obj = newSV(0); + SvREFCNT_inc_simple_void_NN(obj); + Newxz(re, 1, struct replug); + sv_setref_pv(obj, "re::engine::Plugin", (void*)re); - re->pattern = newSVpvn(SAVEPVN(exp, xend - exp), xend - exp); - SvREFCNT_inc(re->pattern); + newREGEXP(RX); + rx = rxREGEXP(RX); - /* Concat [ec]gimosxp (egimosxp & cgimosxp into) the flags string as - * appropriate + re->rx = rx; /* Make the rx accessible from self->rx */ + rx->intflags = flags; /* Flags for internal use */ + rx->extflags = flags; /* Flags for perl to use */ + rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */ + +#if PERL_VERSION <= 10 + rx->refcnt = 1; /* Refcount so we won't be destroyed */ + + /* Precompiled pattern for pp_regcomp to use */ + rx->prelen = plen; + rx->precomp = savepvn(pbuf, rx->prelen); + + /* Set up qr// stringification to be equivalent to the supplied + * pattern, this should be done via overload eventually. */ - if (r->intflags & PMf_EVAL) { strcat(re->flags, "e"); } - if (r->intflags & PMf_CONTINUE) { strcat(re->flags, "c"); } - if (r->intflags & PMf_GLOBAL) { strcat(re->flags, "g"); } - if (r->intflags & PMf_FOLD) { strcat(re->flags, "i"); } - if (r->intflags & PMf_MULTILINE) { strcat(re->flags, "m"); } - if (r->intflags & PMf_ONCE) { strcat(re->flags, "o"); } - if (r->intflags & PMf_SINGLELINE) { strcat(re->flags, "s"); } - if (r->intflags & PMf_EXTENDED) { strcat(re->flags, "x"); } - if (((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY)) { - strcat(re->flags, "p"); + rx->wraplen = rx->prelen; + Newx(rx->wrapped, rx->wraplen, char); + Copy(rx->precomp, rx->wrapped, rx->wraplen, char); +#endif + + /* Store our private object */ + rx->pprivate = obj; + + /* Store the pattern for ->pattern */ + re->pattern = (SV*)pattern; + SvREFCNT_inc_simple_void(re->pattern); + + /* If there's an exec callback, store it into the private object so + * that it will be the one to be called, even if the engine changes + * in between */ + if (h->exec) { + re->cb_exec = h->exec; + SvREFCNT_inc_simple_void_NN(h->exec); } - /* - * Call our callback function if one was defined, if not we've - * already set up all the stuff we're going to to need for - * subsequent exec and other calls - */ - SV * callback = get_H_callback("comp"); + re->cb_num_capture_buff_FETCH = NULL; + re->cb_num_capture_buff_STORE = NULL; + re->cb_num_capture_buff_LENGTH = NULL; - if (callback) { - ENTER; + /* Call our callback function if one was defined, if not we've + * already set up all the stuff we're going to to need for + * subsequent exec and other calls */ + if (h->comp) { + ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(obj); - XPUSHs(sv_2mortal(newSVpv(exp, xend - exp))); - PUTBACK; - call_sv(get_H_callback("comp"), G_DISCARD); + call_sv(h->comp, G_DISCARD); FREETMPS; LEAVE; @@ -195,200 +367,486 @@ Plugin_comp(pTHX_ char *exp, char *xend, PMOP *pm) /* If any of the comp-time accessors were called we'll have to * update the regexp struct with the new info. */ - if (re->minlen) r->minlen = re->minlen; - if (re->gofs) r->gofs = re->gofs; - if (re->gofs) r->gofs = re->gofs; - if (re->nparens) r->nparens = re->nparens; - - int buffers = r->nparens; - //r->nparens = (buffers - 1); - Newxz(r->startp, buffers, I32); - Newxz(r->endp, buffers, I32); + Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair); - /* return the regexp */ - return r; + return RX; } I32 -Plugin_exec(pTHX_ register regexp *r, char *stringarg, register char *strend, - char *strbeg, I32 minend, SV *sv, void *data, U32 flags) +Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, + char *strbeg, I32 minend, SV *sv, void *data, U32 flags) { dSP; - I32 rc; - int *ovector; - I32 i; - int count; - int ret; + I32 matched; + struct regexp *rx = rxREGEXP(RX); + GET_SELF_FROM_PPRIVATE(rx->pprivate); - /*Newx(ovector,r->nparens,int);*/ + if (self->cb_exec) { + SV *ret; - SV* callback = get_H_callback("exec"); + /* Store the current str for ->str */ + SvREFCNT_dec(self->str); + self->str = sv; + SvREFCNT_inc_simple_void(self->str); - ENTER; - SAVETMPS; - - PUSHMARK(SP); - - XPUSHs(r->pprivate); - XPUSHs(sv); - - PUTBACK; + ENTER; + SAVETMPS; - count = call_sv(callback, G_ARRAY); - - SPAGAIN; + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv); + PUTBACK; - SV * SvRet = POPs; + call_sv(self->cb_exec, G_SCALAR); - if (SvTRUE(SvRet)) { - /* Match vars */ + SPAGAIN; - /* - r->sublen = strend-strbeg; - r->subbeg = savepvn(strbeg,r->sublen); - r->startp[1] = 0; - r->endp[1] = 5; - */ + ret = POPs; + if (SvTRUE(ret)) + matched = 1; + else + matched = 0; - ret = 1; + PUTBACK; + FREETMPS; + LEAVE; } else { - ret = 0; + matched = 0; } - PUTBACK; - FREETMPS; - LEAVE; - - return ret; + return matched; } char * -Plugin_intuit(pTHX_ regexp *prog, SV *sv, char *strpos, +Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos, char *strend, U32 flags, re_scream_pos_data *data) { + PERL_UNUSED_ARG(RX); + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(strpos); + PERL_UNUSED_ARG(strend); + PERL_UNUSED_ARG(flags); + PERL_UNUSED_ARG(data); return NULL; } SV * -Plugin_checkstr(pTHX_ regexp *prog) +Plugin_checkstr(pTHX_ REGEXP * const RX) { + PERL_UNUSED_ARG(RX); return NULL; } void -Plugin_free(pTHX_ struct regexp *r) +Plugin_free(pTHX_ REGEXP * const RX) { - /*sv_2mortal(r->pprivate);*/ - /*PerlMemShared_free(r->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); + + SvREFCNT_dec(self->cb_exec); + + SvREFCNT_dec(self->cb_num_capture_buff_FETCH); + SvREFCNT_dec(self->cb_num_capture_buff_STORE); + SvREFCNT_dec(self->cb_num_capture_buff_LENGTH); + + self->rx = NULL; + Safefree(self); + +/* + dSP; + SV * callback; + + callback = self->cb_free; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + PUTBACK; + + call_sv(callback, G_DISCARD); + + PUTBACK; + FREETMPS; + LEAVE; + } + return; +*/ } void * -Plugin_dupe(pTHX_ const regexp *r, CLONE_PARAMS *param) +Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param) +{ + struct regexp *rx = rxREGEXP(RX); + Perl_croak(aTHX_ "dupe not supported yet"); + return rx->pprivate; +} + + +void +Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren, + SV * const sv) +{ + dSP; + I32 items; + SV * callback; + struct regexp *rx = rxREGEXP(RX); + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_num_capture_buff_FETCH; + + 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; + + SPAGAIN; + ret = POPs; + sv_setsv(sv, ret); + } else { + sv_setsv(sv, &PL_sv_undef); + } + + PUTBACK; + FREETMPS; + LEAVE; + } else { + sv_setsv(sv, &PL_sv_undef); + } +} + +void +Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren, + SV const * const value) +{ + dSP; + SV * callback; + struct regexp *rx = rxREGEXP(RX); + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_num_capture_buff_STORE; + + if (callback) { + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv_2mortal(newSViv(paren))); + XPUSHs((SV *) value); + PUTBACK; + + call_sv(callback, G_DISCARD); + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +I32 +Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv, + const I32 paren) { - return r->pprivate; + dSP; + SV * callback; + struct regexp *rx = rxREGEXP(RX); + GET_SELF_FROM_PPRIVATE(rx->pprivate); + + callback = self->cb_num_capture_buff_LENGTH; + + if (callback) { + IV ret; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(rx->pprivate); + XPUSHs(sv_2mortal(newSViv(paren))); + PUTBACK; + + call_sv(callback, G_SCALAR); + + SPAGAIN; + + ret = POPi; + + PUTBACK; + FREETMPS; + LEAVE; + + return (I32)ret; + } else { + /* TODO: call FETCH and get the length on that value */ + return 0; + } } + SV* -Plugin_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv) +Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value, + const U32 flags) { return NULL; } SV* -Plugin_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags) +Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey, + const U32 flags) { return NULL; } -/* - * The function pointers we're telling the regex engine to use - */ -const regexp_engine engine_plugin = { - Plugin_comp, - Plugin_exec, - Plugin_intuit, - Plugin_checkstr, - Plugin_free, - Plugin_numbered_buff_get, - Plugin_named_buff_get, -#if defined(USE_ITHREADS) - Plugin_dupe, -#endif -}; +SV* +Plugin_package(pTHX_ REGEXP * const RX) +{ + PERL_UNUSED_ARG(RX); + return newSVpvs("re::engine::Plugin"); +} -MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin +#if REP_THREADSAFE -SV * +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 rep_setup(pTHX) { +#define rep_setup() rep_setup(aTHX) + if (rep_initialized) + return; + + { + MY_CXT_INIT; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; + } + + call_atexit(rep_teardown, aTHX); + + rep_initialized = 1; +} + +#else /* REP_THREADSAFE */ + +#define rep_setup() + +#endif /* !REP_THREADSAFE */ + +STATIC U32 rep_booted = 0; + +/* --- XS ------------------------------------------------------------------ */ + +MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin + +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(); +} + +#if REP_THREADSAFE + +void +CLONE(...) +PREINIT: + ptable *t; +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; + } + reap(3, rep_thread_cleanup, NULL); + XSRETURN(0); + +#endif /* REP_THREADSAFE */ + +void pattern(re::engine::Plugin self, ...) -CODE: - SvREFCNT_inc(self->pattern); - RETVAL = self->pattern; -OUTPUT: - RETVAL +PPCODE: + XPUSHs(self->pattern); -char* -flags(re::engine::Plugin self, ...) -CODE: - RETVAL = self->flags; -OUTPUT: - RETVAL +void +str(re::engine::Plugin self, ...) +PPCODE: + XPUSHs(self->str); -SV * -stash(re::engine::Plugin self, ...) +void +mod(re::engine::Plugin self) PREINIT: - SV * stash; -CODE: + U32 flags; + char mods[5 + 1]; + int n = 0, i; +PPCODE: + flags = self->rx->intflags; + if (flags & PMf_FOLD) /* /i */ + mods[n++] = 'i'; + if (flags & PMf_MULTILINE) /* /m */ + mods[n++] = 'm'; + if (flags & PMf_SINGLELINE) /* /s */ + mods[n++] = 's'; + if (flags & PMf_EXTENDED) /* /x */ + mods[n++] = 'x'; + if (flags & RXf_PMf_KEEPCOPY) /* /p */ + mods[n++] = 'p'; + mods[n] = '\0'; + EXTEND(SP, 2 * n); + for (i = 0; i < n; ++i) { + mPUSHp(mods + i, 1); + PUSHs(&PL_sv_yes); + } + XSRETURN(2 * n); + +void +stash(re::engine::Plugin self, ...) +PPCODE: if (items > 1) { - self->stash = sv_mortalcopy(ST(1)); - SvREFCNT_inc(self->stash); + SvREFCNT_dec(self->stash); + self->stash = ST(1); + SvREFCNT_inc_simple_void(self->stash); + XSRETURN_EMPTY; + } else { + XPUSHs(self->stash); } - SvREFCNT_inc(self->stash); - RETVAL = self->stash; -OUTPUT: - RETVAL -SV * +void minlen(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { - self->minlen = (I32)SvIV(ST(1)); + self->rx->minlen = (I32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->minlen) { + XPUSHs(sv_2mortal(newSViv(self->rx->minlen))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->minlen ? newSViv(self->minlen) : &PL_sv_undef; -OUTPUT: - RETVAL - -SV * +void gofs(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { - self->gofs = (U32)SvIV(ST(1)); + self->rx->gofs = (U32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->gofs) { + XPUSHs(sv_2mortal(newSVuv(self->rx->gofs))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->gofs ? newSVuv(self->gofs) : &PL_sv_undef; -OUTPUT: - RETVAL -SV * +void nparens(re::engine::Plugin self, ...) -CODE: +PPCODE: if (items > 1) { - self->nparens = (U32)SvIV(ST(1)); + self->rx->nparens = (U32)SvIV(ST(1)); + XSRETURN_EMPTY; + } else { + if (self->rx->nparens) { + XPUSHs(sv_2mortal(newSVuv(self->rx->nparens))); + } else { + XPUSHs(sv_2mortal(&PL_sv_undef)); + } } - RETVAL = self->gofs ? newSVuv(self->gofs) : &PL_sv_undef; -OUTPUT: - RETVAL void -captures(re::engine::Plugin self, ...) +_exec(re::engine::Plugin self, ...) PPCODE: if (items > 1) { - self->minlen = (I32)SvIV(ST(1)); + SvREFCNT_dec(self->cb_exec); + self->cb_exec = ST(1); + SvREFCNT_inc_simple_void(self->cb_exec); } - XPUSHs(sv_2mortal(newSViv(5))); - XPUSHs(sv_2mortal(newSViv(10))); void -get_engine_plugin() +_num_capture_buff_FETCH(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_FETCH); + self->cb_num_capture_buff_FETCH = ST(1); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH); + } + +void +_num_capture_buff_STORE(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_STORE); + self->cb_num_capture_buff_STORE = ST(1); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE); + } + +void +_num_capture_buff_LENGTH(re::engine::Plugin self, ...) +PPCODE: + if (items > 1) { + SvREFCNT_dec(self->cb_num_capture_buff_LENGTH); + self->cb_num_capture_buff_LENGTH = ST(1); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH); + } + +SV * +_tag(SV *comp, SV *exec) +CODE: + RETVAL = rep_tag(comp, exec); +OUTPUT: + RETVAL + +void +ENGINE() PPCODE: XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));