X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Plugin.xs;h=b4db0bd724ac2553ef2711c7d2da51df88437209;hb=ca88f6dfd59f4794f58f0aea9c14629f5199b814;hp=1e6a73ba46ea61ac9b5a4946b2a7251b5b8b0db3;hpb=4327f8c53cab465ee6892481b01717664fb6c973;p=perl%2Fmodules%2Fre-engine-Plugin.git diff --git a/Plugin.xs b/Plugin.xs index 1e6a73b..b4db0bd 100644 --- a/Plugin.xs +++ b/Plugin.xs @@ -6,33 +6,22 @@ #include "perl.h" #include "XSUB.h" -#include "Plugin.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)))))) -#undef ENTERn -#if defined(ENTER_with_name) && !REP_HAS_PERL(5, 11, 4) -# define ENTERn(N) ENTER_with_name(N) -#else -# define ENTERn(N) ENTER -#endif - -#undef LEAVEn -#if defined(LEAVE_with_name) && !REP_HAS_PERL(5, 11, 4) -# define LEAVEn(N) LEAVE_with_name(N) -#else -# define LEAVEn(N) LEAVE -#endif - #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1) #endif /* ... 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 @@ -75,7 +64,7 @@ typedef struct { SV *comp; SV *exec; #if REP_WORKAROUND_REQUIRE_PROPAGATION - IV cxreq; + IV require_tag; #endif } rep_hint_t; @@ -107,57 +96,75 @@ typedef struct { 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(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(h2->comp); - h2->exec = rep_clone(h1->exec, ud->owner); - SvREFCNT_inc(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) { @@ -174,40 +181,68 @@ 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)); @@ -216,18 +251,20 @@ STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) { 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 */ @@ -255,31 +292,147 @@ STATIC const rep_hint_t *rep_hint(pTHX) { 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; struct regexp * rx; REGEXP *RX; - I32 buffers; + re__engine__Plugin re; const rep_hint_t *h; + STRLEN plen; + char *pbuf; + + 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 */ - STRLEN plen; - char* exp = SvPV((SV*)pattern, plen); + pbuf = SvPV((SV*)pattern, plen); /* Our blessed object */ - SV *obj = newSV(0); - SvREFCNT_inc(obj); + obj = newSV(0); + SvREFCNT_inc_simple_void_NN(obj); Newxz(re, 1, struct replug); sv_setref_pv(obj, "re::engine::Plugin", (void*)re); @@ -291,12 +444,12 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) 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 */ rx->prelen = plen; - rx->precomp = savepvn(exp, rx->prelen); + rx->precomp = savepvn(pbuf, rx->prelen); /* Set up qr// stringification to be equivalent to the supplied * pattern, this should be done via overload eventually. @@ -311,14 +464,14 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) /* Store the pattern for ->pattern */ re->pattern = (SV*)pattern; - SvREFCNT_inc(re->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); + SvREFCNT_inc_simple_void_NN(h->exec); } re->cb_num_capture_buff_FETCH = NULL; @@ -329,9 +482,9 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) * 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; @@ -346,16 +499,15 @@ Plugin_comp(pTHX_ SV * const pattern, U32 flags) * update the regexp struct with the new info. */ - buffers = rx->nparens; - - Newxz(rx->offs, buffers + 1, regexp_paren_pair); + Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair); return RX; } 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; @@ -363,24 +515,26 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, GET_SELF_FROM_PPRIVATE(rx->pprivate); if (self->cb_exec) { + SV *ret; + /* Store the current str for ->str */ - self->str = (SV*)sv; - SvREFCNT_inc(self->str); + SvREFCNT_dec(self->str); + self->str = sv; + SvREFCNT_inc_simple_void(self->str); ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv); PUTBACK; call_sv(self->cb_exec, G_SCALAR); - - SPAGAIN; - SV * ret = POPs; + SPAGAIN; + ret = POPs; if (SvTRUE(ret)) matched = 1; else @@ -397,11 +551,19 @@ Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend, } 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); @@ -419,8 +581,14 @@ Plugin_checkstr(pTHX_ REGEXP * const RX) 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); @@ -443,7 +611,7 @@ Plugin_free(pTHX_ REGEXP * const RX) if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); PUTBACK; @@ -482,18 +650,19 @@ Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren, if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); PUTBACK; items = call_sv(callback, G_SCALAR); - + if (items == 1) { - SPAGAIN; + SV *ret; - SV * ret = POPs; + SPAGAIN; + ret = POPs; sv_setsv(sv, ret); } else { sv_setsv(sv, &PL_sv_undef); @@ -521,11 +690,11 @@ Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren, if (callback) { ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); - XPUSHs(SvREFCNT_inc((SV *) value)); + XPUSHs((SV *) value); PUTBACK; call_sv(callback, G_DISCARD); @@ -548,9 +717,11 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv, callback = self->cb_num_capture_buff_LENGTH; if (callback) { + IV ret; + ENTER; SAVETMPS; - + PUSHMARK(SP); XPUSHs(rx->pprivate); XPUSHs(sv_2mortal(newSViv(paren))); @@ -560,7 +731,7 @@ Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv, SPAGAIN; - IV ret = POPi; + ret = POPi; PUTBACK; FREETMPS; @@ -600,12 +771,13 @@ Plugin_package(pTHX_ REGEXP * const RX) 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; } @@ -615,9 +787,11 @@ STATIC void rep_setup(pTHX) { 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); @@ -634,14 +808,20 @@ STATIC U32 rep_booted = 0; /* --- XS ------------------------------------------------------------------ */ -MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin +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(); @@ -653,20 +833,39 @@ void CLONE(...) PREINIT: ptable *t; + GV *gv; PPCODE: { - my_cxt_t ud; - dMY_CXT; - ud.tbl = t = ptable_new(); - ud.owner = MY_CXT.owner; - ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud); + 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; + 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 */ @@ -681,45 +880,39 @@ str(re::engine::Plugin self, ...) PPCODE: XPUSHs(self->str); -char* -mod(re::engine::Plugin self, ...) +void +mod(re::engine::Plugin self) +PREINIT: + U32 flags; + char mods[5 + 1]; + int n = 0, i; PPCODE: - /* /i */ - if (self->rx->intflags & PMf_FOLD) { - XPUSHs(sv_2mortal(newSVpvs("i"))); - XPUSHs(&PL_sv_yes); - } - - /* /m */ - if (self->rx->intflags & PMf_MULTILINE) { - XPUSHs(sv_2mortal(newSVpvs("m"))); - XPUSHs(&PL_sv_yes); - } - - /* /s */ - if (self->rx->intflags & PMf_SINGLELINE) { - XPUSHs(sv_2mortal(newSVpvs("s"))); - XPUSHs(&PL_sv_yes); - } - - /* /x */ - if (self->rx->intflags & PMf_EXTENDED) { - XPUSHs(sv_2mortal(newSVpvs("x"))); - XPUSHs(&PL_sv_yes); - } - - /* /p */ - if (self->rx->intflags & RXf_PMf_KEEPCOPY) { - XPUSHs(sv_2mortal(newSVpvs("p"))); - XPUSHs(&PL_sv_yes); + 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) { + SvREFCNT_dec(self->stash); self->stash = ST(1); - SvREFCNT_inc(self->stash); + SvREFCNT_inc_simple_void(self->stash); XSRETURN_EMPTY; } else { XPUSHs(self->stash); @@ -773,7 +966,7 @@ PPCODE: if (items > 1) { SvREFCNT_dec(self->cb_exec); self->cb_exec = ST(1); - SvREFCNT_inc(self->cb_exec); + SvREFCNT_inc_simple_void(self->cb_exec); } void @@ -782,7 +975,7 @@ PPCODE: if (items > 1) { SvREFCNT_dec(self->cb_num_capture_buff_FETCH); self->cb_num_capture_buff_FETCH = ST(1); - SvREFCNT_inc(self->cb_num_capture_buff_FETCH); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH); } void @@ -791,7 +984,7 @@ PPCODE: if (items > 1) { SvREFCNT_dec(self->cb_num_capture_buff_STORE); self->cb_num_capture_buff_STORE = ST(1); - SvREFCNT_inc(self->cb_num_capture_buff_STORE); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE); } void @@ -800,7 +993,7 @@ PPCODE: if (items > 1) { SvREFCNT_dec(self->cb_num_capture_buff_LENGTH); self->cb_num_capture_buff_LENGTH = ST(1); - SvREFCNT_inc(self->cb_num_capture_buff_LENGTH); + SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH); } SV *