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 /* Safe unless stated otherwise in Makefile.PL */
24 # define REP_FORKSAFE 1
27 #ifndef REP_MULTIPLICITY
28 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
29 # define REP_MULTIPLICITY 1
31 # define REP_MULTIPLICITY 0
34 #if REP_MULTIPLICITY && !defined(tTHX)
35 # define tTHX PerlInterpreter*
38 #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))
39 # define REP_THREADSAFE 1
41 # define MY_CXT_CLONE \
43 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
44 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
45 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
48 # define REP_THREADSAFE 0
50 # define dMY_CXT dNOOP
52 # define MY_CXT rep_globaldata
54 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
56 # define MY_CXT_INIT NOOP
58 # define MY_CXT_CLONE NOOP
61 /* --- Helpers ------------------------------------------------------------- */
63 /* ... Thread-safe hints ................................................... */
68 #if REP_WORKAROUND_REQUIRE_PROPAGATION
75 #define PTABLE_VAL_FREE(V) { \
76 rep_hint_t *h = (V); \
77 SvREFCNT_dec(h->comp); \
78 SvREFCNT_dec(h->exec); \
79 PerlMemShared_free(h); \
89 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
90 #define ptable_free(T) ptable_free(aTHX_ (T))
92 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
103 #if REP_HAS_PERL(5, 13, 2)
104 CLONE_PARAMS *params;
108 } rep_ptable_clone_ud;
110 #if REP_HAS_PERL(5, 13, 2)
111 # define rep_ptable_clone_ud_init(U, T, O) \
113 (U).params = Perl_clone_params_new((O), aTHX)
114 # define rep_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
115 # define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
117 # define rep_ptable_clone_ud_init(U, T, O) \
119 (U).params.stashes = newAV(); \
120 (U).params.flags = 0; \
121 (U).params.proto_perl = (O)
122 # define rep_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
123 # define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
126 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
127 rep_ptable_clone_ud *ud = ud_;
128 rep_hint_t *h1 = ent->val;
131 h2 = PerlMemShared_malloc(sizeof *h2);
132 h2->comp = rep_dup_inc(h1->comp, ud);
133 h2->exec = rep_dup_inc(h1->exec, ud);
134 #if REP_WORKAROUND_REQUIRE_PROPAGATION
135 h2->require_tag = PTR2IV(rep_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
138 ptable_store(ud->tbl, ent->key, h2);
141 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
144 ptable_free(MY_CXT.tbl);
147 STATIC int rep_endav_free(pTHX_ SV *sv, MAGIC *mg) {
148 SAVEDESTRUCTOR_X(rep_thread_cleanup, NULL);
153 STATIC MGVTBL rep_endav_vtbl = {
170 #endif /* REP_THREADSAFE */
172 STATIC SV *rep_validate_callback(SV *code) {
177 if (SvTYPE(code) < SVt_PVCV)
180 return SvREFCNT_inc_simple_NN(code);
183 #if REP_WORKAROUND_REQUIRE_PROPAGATION
184 STATIC IV rep_require_tag(pTHX) {
185 #define rep_require_tag() rep_require_tag(aTHX)
186 const CV *cv, *outside;
191 /* If for some reason the pragma is operational at run-time, try to discover
192 * the current cv in use. */
195 for (si = PL_curstackinfo; si; si = si->si_prev) {
198 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
199 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
201 switch (CxTYPE(cx)) {
204 /* The propagation workaround is only needed up to 5.10.0 and at that
205 * time format and sub contexts were still identical. And even later the
206 * cv members offsets should have been kept the same. */
208 goto get_enclosing_cv;
210 cv = cx->blk_eval.cv;
211 goto get_enclosing_cv;
222 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
227 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
229 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
230 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
233 h = PerlMemShared_malloc(sizeof *h);
234 h->comp = rep_validate_callback(comp);
235 h->exec = rep_validate_callback(exec);
236 #if REP_WORKAROUND_REQUIRE_PROPAGATION
237 h->require_tag = rep_require_tag();
238 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
243 /* We only need for the key to be an unique tag for looking up the value later
244 * Allocated memory provides convenient unique identifiers, so that's why we
245 * use the hint as the key itself. */
246 ptable_store(MY_CXT.tbl, h, h);
248 #endif /* REP_THREADSAFE */
250 return newSViv(PTR2IV(h));
253 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
254 #define rep_detag(H) rep_detag(aTHX_ (H))
257 if (!(hint && SvIOK(hint)))
260 h = INT2PTR(rep_hint_t *, SvIVX(hint));
264 h = ptable_fetch(MY_CXT.tbl, h);
266 #endif /* REP_THREADSAFE */
268 #if REP_WORKAROUND_REQUIRE_PROPAGATION
269 if (rep_require_tag() != h->require_tag)
271 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
276 STATIC U32 rep_hash = 0;
278 STATIC const rep_hint_t *rep_hint(pTHX) {
279 #define rep_hint() rep_hint(aTHX)
282 #ifdef cop_hints_fetch_pvn
283 hint = cop_hints_fetch_pvn(PL_curcop,
284 __PACKAGE__, __PACKAGE_LEN__, rep_hash, 0);
286 /* We already require 5.9.5 for the regexp engine API. */
287 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
289 __PACKAGE__, __PACKAGE_LEN__,
294 return rep_detag(hint);
298 #if PERL_VERSION <= 10
299 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
301 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
308 re__engine__Plugin re;
317 if (!h) /* This looks like a pragma leak. Apply the default behaviour */
318 return re_compile(pattern, flags);
320 /* exp/xend version of the pattern & length */
321 pbuf = SvPV((SV*)pattern, plen);
323 /* Our blessed object */
325 SvREFCNT_inc_simple_void_NN(obj);
326 Newxz(re, 1, struct replug);
327 sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
332 re->rx = rx; /* Make the rx accessible from self->rx */
333 rx->intflags = flags; /* Flags for internal use */
334 rx->extflags = flags; /* Flags for perl to use */
335 rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
337 #if PERL_VERSION <= 10
338 rx->refcnt = 1; /* Refcount so we won't be destroyed */
340 /* Precompiled pattern for pp_regcomp to use */
342 rx->precomp = savepvn(pbuf, rx->prelen);
344 /* Set up qr// stringification to be equivalent to the supplied
345 * pattern, this should be done via overload eventually.
347 rx->wraplen = rx->prelen;
348 Newx(rx->wrapped, rx->wraplen, char);
349 Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
352 /* Store our private object */
355 /* Store the pattern for ->pattern */
356 re->pattern = (SV*)pattern;
357 SvREFCNT_inc_simple_void(re->pattern);
359 /* If there's an exec callback, store it into the private object so
360 * that it will be the one to be called, even if the engine changes
363 re->cb_exec = h->exec;
364 SvREFCNT_inc_simple_void_NN(h->exec);
367 re->cb_num_capture_buff_FETCH = NULL;
368 re->cb_num_capture_buff_STORE = NULL;
369 re->cb_num_capture_buff_LENGTH = NULL;
371 /* Call our callback function if one was defined, if not we've
372 * already set up all the stuff we're going to to need for
373 * subsequent exec and other calls */
382 call_sv(h->comp, G_DISCARD);
388 /* If any of the comp-time accessors were called we'll have to
389 * update the regexp struct with the new info.
392 Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair);
398 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
399 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
403 struct regexp *rx = rxREGEXP(RX);
404 GET_SELF_FROM_PPRIVATE(rx->pprivate);
409 /* Store the current str for ->str */
410 SvREFCNT_dec(self->str);
412 SvREFCNT_inc_simple_void(self->str);
418 XPUSHs(rx->pprivate);
422 call_sv(self->cb_exec, G_SCALAR);
443 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
444 char *strend, U32 flags, re_scream_pos_data *data)
448 PERL_UNUSED_ARG(strpos);
449 PERL_UNUSED_ARG(strend);
450 PERL_UNUSED_ARG(flags);
451 PERL_UNUSED_ARG(data);
456 Plugin_checkstr(pTHX_ REGEXP * const RX)
463 Plugin_free(pTHX_ REGEXP * const RX)
466 re__engine__Plugin self;
472 SELF_FROM_PPRIVATE(self, rx->pprivate);
474 SvREFCNT_dec(self->pattern);
475 SvREFCNT_dec(self->str);
477 SvREFCNT_dec(self->cb_exec);
479 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
480 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
481 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
490 callback = self->cb_free;
497 XPUSHs(rx->pprivate);
500 call_sv(callback, G_DISCARD);
511 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
513 struct regexp *rx = rxREGEXP(RX);
514 Perl_croak(aTHX_ "dupe not supported yet");
520 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
526 struct regexp *rx = rxREGEXP(RX);
527 GET_SELF_FROM_PPRIVATE(rx->pprivate);
529 callback = self->cb_num_capture_buff_FETCH;
536 XPUSHs(rx->pprivate);
537 XPUSHs(sv_2mortal(newSViv(paren)));
540 items = call_sv(callback, G_SCALAR);
549 sv_setsv(sv, &PL_sv_undef);
556 sv_setsv(sv, &PL_sv_undef);
561 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
562 SV const * const value)
566 struct regexp *rx = rxREGEXP(RX);
567 GET_SELF_FROM_PPRIVATE(rx->pprivate);
569 callback = self->cb_num_capture_buff_STORE;
576 XPUSHs(rx->pprivate);
577 XPUSHs(sv_2mortal(newSViv(paren)));
578 XPUSHs((SV *) value);
581 call_sv(callback, G_DISCARD);
590 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
595 struct regexp *rx = rxREGEXP(RX);
596 GET_SELF_FROM_PPRIVATE(rx->pprivate);
598 callback = self->cb_num_capture_buff_LENGTH;
607 XPUSHs(rx->pprivate);
608 XPUSHs(sv_2mortal(newSViv(paren)));
611 call_sv(callback, G_SCALAR);
623 /* TODO: call FETCH and get the length on that value */
630 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
637 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
644 Plugin_package(pTHX_ REGEXP * const RX)
647 return newSVpvs("re::engine::Plugin");
652 STATIC U32 rep_initialized = 0;
654 STATIC void rep_teardown(pTHX_ void *root) {
655 if (!rep_initialized || aTHX != root)
660 ptable_free(MY_CXT.tbl);
666 STATIC void rep_setup(pTHX) {
667 #define rep_setup() rep_setup(aTHX)
673 MY_CXT.tbl = ptable_new();
677 call_atexit(rep_teardown, aTHX);
682 #else /* REP_THREADSAFE */
686 #endif /* !REP_THREADSAFE */
688 STATIC U32 rep_booted = 0;
690 /* --- XS ------------------------------------------------------------------ */
692 MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin
701 PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
703 stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
704 newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(REP_THREADSAFE));
705 newCONSTSUB(stash, "REP_FORKSAFE", newSVuv(REP_FORKSAFE));
720 rep_ptable_clone_ud ud;
724 rep_ptable_clone_ud_init(ud, t, MY_CXT.owner);
725 ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
726 rep_ptable_clone_ud_deinit(ud);
733 gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
739 if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
741 sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &rep_endav_vtbl, NULL, 0);
749 rep_thread_cleanup(aTHX_ NULL);
752 #endif /* REP_THREADSAFE */
755 pattern(re::engine::Plugin self, ...)
757 XPUSHs(self->pattern);
760 str(re::engine::Plugin self, ...)
765 mod(re::engine::Plugin self)
771 flags = self->rx->intflags;
772 if (flags & PMf_FOLD) /* /i */
774 if (flags & PMf_MULTILINE) /* /m */
776 if (flags & PMf_SINGLELINE) /* /s */
778 if (flags & PMf_EXTENDED) /* /x */
780 if (flags & RXf_PMf_KEEPCOPY) /* /p */
784 for (i = 0; i < n; ++i) {
791 stash(re::engine::Plugin self, ...)
794 SvREFCNT_dec(self->stash);
796 SvREFCNT_inc_simple_void(self->stash);
803 minlen(re::engine::Plugin self, ...)
806 self->rx->minlen = (I32)SvIV(ST(1));
809 if (self->rx->minlen) {
810 XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
812 XPUSHs(sv_2mortal(&PL_sv_undef));
817 gofs(re::engine::Plugin self, ...)
820 self->rx->gofs = (U32)SvIV(ST(1));
823 if (self->rx->gofs) {
824 XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
826 XPUSHs(sv_2mortal(&PL_sv_undef));
831 nparens(re::engine::Plugin self, ...)
834 self->rx->nparens = (U32)SvIV(ST(1));
837 if (self->rx->nparens) {
838 XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
840 XPUSHs(sv_2mortal(&PL_sv_undef));
845 _exec(re::engine::Plugin self, ...)
848 SvREFCNT_dec(self->cb_exec);
849 self->cb_exec = ST(1);
850 SvREFCNT_inc_simple_void(self->cb_exec);
854 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
857 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
858 self->cb_num_capture_buff_FETCH = ST(1);
859 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH);
863 _num_capture_buff_STORE(re::engine::Plugin self, ...)
866 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
867 self->cb_num_capture_buff_STORE = ST(1);
868 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE);
872 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
875 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
876 self->cb_num_capture_buff_LENGTH = ST(1);
877 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH);
881 _tag(SV *comp, SV *exec)
883 RETVAL = rep_tag(comp, exec);
890 XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));