7 #define __PACKAGE__ "re::engine::Plugin"
8 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
10 #define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
12 #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
13 # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
16 /* ... Thread safety and multiplicity ...................................... */
18 #ifndef REP_MULTIPLICITY
19 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
20 # define REP_MULTIPLICITY 1
22 # define REP_MULTIPLICITY 0
25 #if REP_MULTIPLICITY && !defined(tTHX)
26 # define tTHX PerlInterpreter*
29 #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))
30 # define REP_THREADSAFE 1
32 # define MY_CXT_CLONE \
34 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
35 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
36 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
39 # define REP_THREADSAFE 0
41 # define dMY_CXT dNOOP
43 # define MY_CXT rep_globaldata
45 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
47 # define MY_CXT_INIT NOOP
49 # define MY_CXT_CLONE NOOP
52 /* --- Helpers ------------------------------------------------------------- */
54 /* ... Thread-safe hints ................................................... */
59 #if REP_WORKAROUND_REQUIRE_PROPAGATION
66 #define PTABLE_VAL_FREE(V) { \
67 rep_hint_t *h = (V); \
68 SvREFCNT_dec(h->comp); \
69 SvREFCNT_dec(h->exec); \
70 PerlMemShared_free(h); \
80 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
81 #define ptable_free(T) ptable_free(aTHX_ (T))
83 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
92 STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) {
93 #define rep_clone(S, O) rep_clone(aTHX_ (S), (O))
98 if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
101 param.stashes = stashes;
103 param.proto_perl = owner;
105 dupsv = sv_dup(sv, ¶m);
109 SvREFCNT_dec(stashes);
112 return SvREFCNT_inc(dupsv);
115 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
117 rep_hint_t *h1 = ent->val;
120 if (ud->owner == aTHX)
123 h2 = PerlMemShared_malloc(sizeof *h2);
124 h2->comp = rep_clone(h1->comp, ud->owner);
125 SvREFCNT_inc(h2->comp);
126 h2->exec = rep_clone(h1->exec, ud->owner);
127 SvREFCNT_inc(h2->exec);
128 #if REP_WORKAROUND_REQUIRE_PROPAGATION
129 h2->requires = h1->requires;
132 ptable_store(ud->tbl, ent->key, h2);
135 STATIC void rep_thread_cleanup(pTHX_ void *);
137 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
143 SAVEDESTRUCTOR_X(rep_thread_cleanup, level);
147 PerlMemShared_free(level);
148 ptable_free(MY_CXT.tbl);
152 #endif /* REP_THREADSAFE */
154 STATIC SV *rep_validate_callback(SV *code) {
159 if (SvTYPE(code) < SVt_PVCV)
162 return SvREFCNT_inc_simple_NN(code);
165 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
166 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
170 h = PerlMemShared_malloc(sizeof *h);
172 h->comp = rep_validate_callback(comp);
173 h->exec = rep_validate_callback(exec);
175 #if REP_WORKAROUND_REQUIRE_PROPAGATION
180 for (si = PL_curstackinfo; si; si = si->si_prev) {
183 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
184 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
186 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
191 h->requires = requires;
196 /* We only need for the key to be an unique tag for looking up the value later.
197 * Allocated memory provides convenient unique identifiers, so that's why we
198 * use the hint as the key itself. */
199 ptable_store(MY_CXT.tbl, h, h);
200 #endif /* REP_THREADSAFE */
202 return newSViv(PTR2IV(h));
205 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
206 #define rep_detag(H) rep_detag(aTHX_ (H))
210 if (!(hint && SvIOK(hint)))
213 h = INT2PTR(rep_hint_t *, SvIVX(hint));
215 h = ptable_fetch(MY_CXT.tbl, h);
216 #endif /* REP_THREADSAFE */
218 #if REP_WORKAROUND_REQUIRE_PROPAGATION
223 for (si = PL_curstackinfo; si; si = si->si_prev) {
226 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
227 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
229 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
230 && ++requires > h->requires)
240 STATIC U32 rep_hash = 0;
242 STATIC const rep_hint_t *rep_hint(pTHX) {
243 #define rep_hint() rep_hint(aTHX)
246 /* We already require 5.9.5 for the regexp engine API. */
247 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
249 __PACKAGE__, __PACKAGE_LEN__,
253 return rep_detag(hint);
257 #if PERL_VERSION <= 10
258 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
260 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
267 re__engine__Plugin re;
270 /* exp/xend version of the pattern & length */
272 char* exp = SvPV((SV*)pattern, plen);
274 /* Our blessed object */
277 Newxz(re, 1, struct replug);
278 sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
283 re->rx = rx; /* Make the rx accessible from self->rx */
284 rx->intflags = flags; /* Flags for internal use */
285 rx->extflags = flags; /* Flags for perl to use */
286 rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
288 #if PERL_VERSION <= 10
289 rx->refcnt = 1; /* Refcount so we won't be destroyed */
291 /* Precompiled pattern for pp_regcomp to use */
293 rx->precomp = savepvn(exp, rx->prelen);
295 /* Set up qr// stringification to be equivalent to the supplied
296 * pattern, this should be done via overload eventually.
298 rx->wraplen = rx->prelen;
299 Newx(rx->wrapped, rx->wraplen, char);
300 Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
303 /* Store our private object */
306 /* Store the pattern for ->pattern */
307 re->pattern = (SV*)pattern;
308 SvREFCNT_inc(re->pattern);
311 * Call our callback function if one was defined, if not we've
312 * already set up all the stuff we're going to to need for
313 * subsequent exec and other calls
324 call_sv(h->comp, G_DISCARD);
330 /* If any of the comp-time accessors were called we'll have to
331 * update the regexp struct with the new info.
334 buffers = rx->nparens;
336 Newxz(rx->offs, buffers + 1, regexp_paren_pair);
342 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
343 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
347 struct regexp *rx = rxREGEXP(RX);
349 GET_SELF_FROM_PPRIVATE(rx->pprivate);
353 /* Store the current str for ->str */
355 SvREFCNT_inc(self->str);
361 XPUSHs(rx->pprivate);
365 call_sv(h->exec, G_SCALAR);
387 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
388 char *strend, U32 flags, re_scream_pos_data *data)
392 PERL_UNUSED_ARG(strpos);
393 PERL_UNUSED_ARG(strend);
394 PERL_UNUSED_ARG(flags);
395 PERL_UNUSED_ARG(data);
400 Plugin_checkstr(pTHX_ REGEXP * const RX)
407 Plugin_free(pTHX_ REGEXP * const RX)
413 GET_SELF_FROM_PPRIVATE(rx->pprivate);
415 callback = self->cb_free;
422 XPUSHs(rx->pprivate);
425 call_sv(callback, G_DISCARD);
436 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
438 struct regexp *rx = rxREGEXP(RX);
439 Perl_croak(aTHX_ "dupe not supported yet");
445 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
451 struct regexp *rx = rxREGEXP(RX);
452 GET_SELF_FROM_PPRIVATE(rx->pprivate);
454 callback = self->cb_num_capture_buff_FETCH;
461 XPUSHs(rx->pprivate);
462 XPUSHs(sv_2mortal(newSViv(paren)));
465 items = call_sv(callback, G_SCALAR);
473 sv_setsv(sv, &PL_sv_undef);
480 sv_setsv(sv, &PL_sv_undef);
485 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
486 SV const * const value)
490 struct regexp *rx = rxREGEXP(RX);
491 GET_SELF_FROM_PPRIVATE(rx->pprivate);
493 callback = self->cb_num_capture_buff_STORE;
500 XPUSHs(rx->pprivate);
501 XPUSHs(sv_2mortal(newSViv(paren)));
502 XPUSHs(SvREFCNT_inc((SV *) value));
505 call_sv(callback, G_DISCARD);
514 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
519 struct regexp *rx = rxREGEXP(RX);
520 GET_SELF_FROM_PPRIVATE(rx->pprivate);
522 callback = self->cb_num_capture_buff_LENGTH;
529 XPUSHs(rx->pprivate);
530 XPUSHs(sv_2mortal(newSViv(paren)));
533 call_sv(callback, G_SCALAR);
545 /* TODO: call FETCH and get the length on that value */
552 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
559 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
566 Plugin_package(pTHX_ REGEXP * const RX)
569 return newSVpvs("re::engine::Plugin");
574 STATIC U32 rep_initialized = 0;
576 STATIC void rep_teardown(pTHX_ void *root) {
579 if (!rep_initialized || aTHX != root)
582 ptable_free(MY_CXT.tbl);
587 STATIC void rep_setup(pTHX) {
588 #define rep_setup() rep_setup(aTHX)
593 MY_CXT.tbl = ptable_new();
596 call_atexit(rep_teardown, aTHX);
601 #else /* REP_THREADSAFE */
605 #endif /* !REP_THREADSAFE */
607 STATIC U32 rep_booted = 0;
609 /* --- XS ------------------------------------------------------------------ */
611 MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin
618 PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
635 ud.tbl = t = ptable_new();
636 ud.owner = MY_CXT.owner;
637 ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
648 pattern(re::engine::Plugin self, ...)
650 XPUSHs(self->pattern);
653 str(re::engine::Plugin self, ...)
658 mod(re::engine::Plugin self, ...)
661 if (self->rx->intflags & PMf_FOLD) {
662 XPUSHs(sv_2mortal(newSVpvs("i")));
667 if (self->rx->intflags & PMf_MULTILINE) {
668 XPUSHs(sv_2mortal(newSVpvs("m")));
673 if (self->rx->intflags & PMf_SINGLELINE) {
674 XPUSHs(sv_2mortal(newSVpvs("s")));
679 if (self->rx->intflags & PMf_EXTENDED) {
680 XPUSHs(sv_2mortal(newSVpvs("x")));
685 if (self->rx->intflags & RXf_PMf_KEEPCOPY) {
686 XPUSHs(sv_2mortal(newSVpvs("p")));
691 stash(re::engine::Plugin self, ...)
695 SvREFCNT_inc(self->stash);
702 minlen(re::engine::Plugin self, ...)
705 self->rx->minlen = (I32)SvIV(ST(1));
708 if (self->rx->minlen) {
709 XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
711 XPUSHs(sv_2mortal(&PL_sv_undef));
716 gofs(re::engine::Plugin self, ...)
719 self->rx->gofs = (U32)SvIV(ST(1));
722 if (self->rx->gofs) {
723 XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
725 XPUSHs(sv_2mortal(&PL_sv_undef));
730 nparens(re::engine::Plugin self, ...)
733 self->rx->nparens = (U32)SvIV(ST(1));
736 if (self->rx->nparens) {
737 XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
739 XPUSHs(sv_2mortal(&PL_sv_undef));
744 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
747 self->cb_num_capture_buff_FETCH = ST(1);
748 SvREFCNT_inc(self->cb_num_capture_buff_FETCH);
752 _num_capture_buff_STORE(re::engine::Plugin self, ...)
755 self->cb_num_capture_buff_STORE = ST(1);
756 SvREFCNT_inc(self->cb_num_capture_buff_STORE);
760 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
763 self->cb_num_capture_buff_LENGTH = ST(1);
764 SvREFCNT_inc(self->cb_num_capture_buff_LENGTH);
768 _tag(SV *comp, SV *exec)
770 RETVAL = rep_tag(comp, exec);
777 XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));