1 /* This file is part of the re::engine::Plugin Perl module.
2 * See http://search.cpan.org/dist/re-engine-Plugin/ */
4 #define PERL_NO_GET_CONTEXT
11 #define __PACKAGE__ "re::engine::Plugin"
12 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
14 #define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
16 #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
17 # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
20 /* ... Thread safety and multiplicity ...................................... */
22 #ifndef REP_MULTIPLICITY
23 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
24 # define REP_MULTIPLICITY 1
26 # define REP_MULTIPLICITY 0
29 #if REP_MULTIPLICITY && !defined(tTHX)
30 # define tTHX PerlInterpreter*
33 #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))
34 # define REP_THREADSAFE 1
36 # define MY_CXT_CLONE \
38 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
39 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
40 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
43 # define REP_THREADSAFE 0
45 # define dMY_CXT dNOOP
47 # define MY_CXT rep_globaldata
49 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
51 # define MY_CXT_INIT NOOP
53 # define MY_CXT_CLONE NOOP
56 /* --- Helpers ------------------------------------------------------------- */
58 /* ... Thread-safe hints ................................................... */
63 #if REP_WORKAROUND_REQUIRE_PROPAGATION
70 #define PTABLE_VAL_FREE(V) { \
71 rep_hint_t *h = (V); \
72 SvREFCNT_dec(h->comp); \
73 SvREFCNT_dec(h->exec); \
74 PerlMemShared_free(h); \
84 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
85 #define ptable_free(T) ptable_free(aTHX_ (T))
87 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
96 STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) {
97 #define rep_clone(S, O) rep_clone(aTHX_ (S), (O))
102 if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
105 param.stashes = stashes;
107 param.proto_perl = owner;
109 dupsv = sv_dup(sv, ¶m);
113 SvREFCNT_dec(stashes);
116 return SvREFCNT_inc_simple(dupsv);
119 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
121 rep_hint_t *h1 = ent->val;
124 if (ud->owner == aTHX)
127 h2 = PerlMemShared_malloc(sizeof *h2);
128 h2->comp = rep_clone(h1->comp, ud->owner);
129 SvREFCNT_inc_simple_void(h2->comp);
130 h2->exec = rep_clone(h1->exec, ud->owner);
131 SvREFCNT_inc_simple_void(h2->exec);
132 #if REP_WORKAROUND_REQUIRE_PROPAGATION
133 h2->require_tag = PTR2IV(rep_clone(INT2PTR(SV *, h1->require_tag), ud->owner));
136 ptable_store(ud->tbl, ent->key, h2);
141 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
144 ptable_free(MY_CXT.tbl);
147 #endif /* REP_THREADSAFE */
149 STATIC SV *rep_validate_callback(SV *code) {
154 if (SvTYPE(code) < SVt_PVCV)
157 return SvREFCNT_inc_simple_NN(code);
160 #if REP_WORKAROUND_REQUIRE_PROPAGATION
161 STATIC IV rep_require_tag(pTHX) {
162 #define rep_require_tag() rep_require_tag(aTHX)
163 const CV *cv, *outside;
168 /* If for some reason the pragma is operational at run-time, try to discover
169 * the current cv in use. */
172 for (si = PL_curstackinfo; si; si = si->si_prev) {
175 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
176 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
178 switch (CxTYPE(cx)) {
181 /* The propagation workaround is only needed up to 5.10.0 and at that
182 * time format and sub contexts were still identical. And even later the
183 * cv members offsets should have been kept the same. */
185 goto get_enclosing_cv;
187 cv = cx->blk_eval.cv;
188 goto get_enclosing_cv;
199 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
204 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
206 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
207 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
211 h = PerlMemShared_malloc(sizeof *h);
212 h->comp = rep_validate_callback(comp);
213 h->exec = rep_validate_callback(exec);
214 #if REP_WORKAROUND_REQUIRE_PROPAGATION
215 h->require_tag = rep_require_tag();
216 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
219 /* We only need for the key to be an unique tag for looking up the value later.
220 * Allocated memory provides convenient unique identifiers, so that's why we
221 * use the hint as the key itself. */
222 ptable_store(MY_CXT.tbl, h, h);
223 #endif /* REP_THREADSAFE */
225 return newSViv(PTR2IV(h));
228 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
229 #define rep_detag(H) rep_detag(aTHX_ (H))
233 if (!(hint && SvIOK(hint)))
236 h = INT2PTR(rep_hint_t *, SvIVX(hint));
238 h = ptable_fetch(MY_CXT.tbl, h);
239 #endif /* REP_THREADSAFE */
241 #if REP_WORKAROUND_REQUIRE_PROPAGATION
242 if (rep_require_tag() != h->require_tag)
244 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
249 STATIC U32 rep_hash = 0;
251 STATIC const rep_hint_t *rep_hint(pTHX) {
252 #define rep_hint() rep_hint(aTHX)
255 #ifdef cop_hints_fetch_pvn
256 hint = cop_hints_fetch_pvn(PL_curcop,
257 __PACKAGE__, __PACKAGE_LEN__, rep_hash, 0);
259 /* We already require 5.9.5 for the regexp engine API. */
260 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
262 __PACKAGE__, __PACKAGE_LEN__,
267 return rep_detag(hint);
271 #if PERL_VERSION <= 10
272 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
274 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
281 re__engine__Plugin re;
290 if (!h) /* This looks like a pragma leak. Apply the default behaviour */
291 return re_compile(pattern, flags);
293 /* exp/xend version of the pattern & length */
294 pbuf = SvPV((SV*)pattern, plen);
296 /* Our blessed object */
298 SvREFCNT_inc_simple_void_NN(obj);
299 Newxz(re, 1, struct replug);
300 sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
305 re->rx = rx; /* Make the rx accessible from self->rx */
306 rx->intflags = flags; /* Flags for internal use */
307 rx->extflags = flags; /* Flags for perl to use */
308 rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
310 #if PERL_VERSION <= 10
311 rx->refcnt = 1; /* Refcount so we won't be destroyed */
313 /* Precompiled pattern for pp_regcomp to use */
315 rx->precomp = savepvn(pbuf, rx->prelen);
317 /* Set up qr// stringification to be equivalent to the supplied
318 * pattern, this should be done via overload eventually.
320 rx->wraplen = rx->prelen;
321 Newx(rx->wrapped, rx->wraplen, char);
322 Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
325 /* Store our private object */
328 /* Store the pattern for ->pattern */
329 re->pattern = (SV*)pattern;
330 SvREFCNT_inc_simple_void(re->pattern);
332 /* If there's an exec callback, store it into the private object so
333 * that it will be the one to be called, even if the engine changes
336 re->cb_exec = h->exec;
337 SvREFCNT_inc_simple_void_NN(h->exec);
340 re->cb_num_capture_buff_FETCH = NULL;
341 re->cb_num_capture_buff_STORE = NULL;
342 re->cb_num_capture_buff_LENGTH = NULL;
344 /* Call our callback function if one was defined, if not we've
345 * already set up all the stuff we're going to to need for
346 * subsequent exec and other calls */
355 call_sv(h->comp, G_DISCARD);
361 /* If any of the comp-time accessors were called we'll have to
362 * update the regexp struct with the new info.
365 Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair);
371 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
372 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
376 struct regexp *rx = rxREGEXP(RX);
377 GET_SELF_FROM_PPRIVATE(rx->pprivate);
382 /* Store the current str for ->str */
383 SvREFCNT_dec(self->str);
385 SvREFCNT_inc_simple_void(self->str);
391 XPUSHs(rx->pprivate);
395 call_sv(self->cb_exec, G_SCALAR);
416 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
417 char *strend, U32 flags, re_scream_pos_data *data)
421 PERL_UNUSED_ARG(strpos);
422 PERL_UNUSED_ARG(strend);
423 PERL_UNUSED_ARG(flags);
424 PERL_UNUSED_ARG(data);
429 Plugin_checkstr(pTHX_ REGEXP * const RX)
436 Plugin_free(pTHX_ REGEXP * const RX)
438 struct regexp *rx = rxREGEXP(RX);
439 GET_SELF_FROM_PPRIVATE(rx->pprivate);
441 SvREFCNT_dec(self->pattern);
442 SvREFCNT_dec(self->str);
444 SvREFCNT_dec(self->cb_exec);
446 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
447 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
448 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
457 callback = self->cb_free;
464 XPUSHs(rx->pprivate);
467 call_sv(callback, G_DISCARD);
478 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
480 struct regexp *rx = rxREGEXP(RX);
481 Perl_croak(aTHX_ "dupe not supported yet");
487 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
493 struct regexp *rx = rxREGEXP(RX);
494 GET_SELF_FROM_PPRIVATE(rx->pprivate);
496 callback = self->cb_num_capture_buff_FETCH;
503 XPUSHs(rx->pprivate);
504 XPUSHs(sv_2mortal(newSViv(paren)));
507 items = call_sv(callback, G_SCALAR);
516 sv_setsv(sv, &PL_sv_undef);
523 sv_setsv(sv, &PL_sv_undef);
528 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
529 SV const * const value)
533 struct regexp *rx = rxREGEXP(RX);
534 GET_SELF_FROM_PPRIVATE(rx->pprivate);
536 callback = self->cb_num_capture_buff_STORE;
543 XPUSHs(rx->pprivate);
544 XPUSHs(sv_2mortal(newSViv(paren)));
545 XPUSHs((SV *) value);
548 call_sv(callback, G_DISCARD);
557 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
562 struct regexp *rx = rxREGEXP(RX);
563 GET_SELF_FROM_PPRIVATE(rx->pprivate);
565 callback = self->cb_num_capture_buff_LENGTH;
574 XPUSHs(rx->pprivate);
575 XPUSHs(sv_2mortal(newSViv(paren)));
578 call_sv(callback, G_SCALAR);
590 /* TODO: call FETCH and get the length on that value */
597 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
604 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
611 Plugin_package(pTHX_ REGEXP * const RX)
614 return newSVpvs("re::engine::Plugin");
619 STATIC U32 rep_initialized = 0;
621 STATIC void rep_teardown(pTHX_ void *root) {
624 if (!rep_initialized || aTHX != root)
627 ptable_free(MY_CXT.tbl);
632 STATIC void rep_setup(pTHX) {
633 #define rep_setup() rep_setup(aTHX)
638 MY_CXT.tbl = ptable_new();
641 call_atexit(rep_teardown, aTHX);
646 #else /* REP_THREADSAFE */
650 #endif /* !REP_THREADSAFE */
652 STATIC U32 rep_booted = 0;
654 /* --- XS ------------------------------------------------------------------ */
656 MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin
663 PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
679 ud.tbl = t = ptable_new();
680 ud.owner = MY_CXT.owner;
681 ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
688 reap(3, rep_thread_cleanup, NULL);
691 #endif /* REP_THREADSAFE */
694 pattern(re::engine::Plugin self, ...)
696 XPUSHs(self->pattern);
699 str(re::engine::Plugin self, ...)
704 mod(re::engine::Plugin self)
710 flags = self->rx->intflags;
711 if (flags & PMf_FOLD) /* /i */
713 if (flags & PMf_MULTILINE) /* /m */
715 if (flags & PMf_SINGLELINE) /* /s */
717 if (flags & PMf_EXTENDED) /* /x */
719 if (flags & RXf_PMf_KEEPCOPY) /* /p */
723 for (i = 0; i < n; ++i) {
730 stash(re::engine::Plugin self, ...)
733 SvREFCNT_dec(self->stash);
735 SvREFCNT_inc_simple_void(self->stash);
742 minlen(re::engine::Plugin self, ...)
745 self->rx->minlen = (I32)SvIV(ST(1));
748 if (self->rx->minlen) {
749 XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
751 XPUSHs(sv_2mortal(&PL_sv_undef));
756 gofs(re::engine::Plugin self, ...)
759 self->rx->gofs = (U32)SvIV(ST(1));
762 if (self->rx->gofs) {
763 XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
765 XPUSHs(sv_2mortal(&PL_sv_undef));
770 nparens(re::engine::Plugin self, ...)
773 self->rx->nparens = (U32)SvIV(ST(1));
776 if (self->rx->nparens) {
777 XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
779 XPUSHs(sv_2mortal(&PL_sv_undef));
784 _exec(re::engine::Plugin self, ...)
787 SvREFCNT_dec(self->cb_exec);
788 self->cb_exec = ST(1);
789 SvREFCNT_inc_simple_void(self->cb_exec);
793 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
796 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
797 self->cb_num_capture_buff_FETCH = ST(1);
798 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH);
802 _num_capture_buff_STORE(re::engine::Plugin self, ...)
805 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
806 self->cb_num_capture_buff_STORE = ST(1);
807 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE);
811 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
814 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
815 self->cb_num_capture_buff_LENGTH = ST(1);
816 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH);
820 _tag(SV *comp, SV *exec)
822 RETVAL = rep_tag(comp, exec);
829 XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));