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
9 #define __PACKAGE__ "re::engine::Plugin"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
12 #define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
14 #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
15 # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
18 /* ... Thread safety and multiplicity ...................................... */
20 /* Safe unless stated otherwise in Makefile.PL */
22 # define REP_FORKSAFE 1
25 #ifndef REP_MULTIPLICITY
26 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
27 # define REP_MULTIPLICITY 1
29 # define REP_MULTIPLICITY 0
32 #if REP_MULTIPLICITY && !defined(tTHX)
33 # define tTHX PerlInterpreter*
36 #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))
37 # define REP_THREADSAFE 1
39 # define MY_CXT_CLONE \
41 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
42 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
43 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
46 # define REP_THREADSAFE 0
48 # define dMY_CXT dNOOP
50 # define MY_CXT rep_globaldata
52 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
54 # define MY_CXT_INIT NOOP
56 # define MY_CXT_CLONE NOOP
59 /* --- Helpers ------------------------------------------------------------- */
61 /* ... Thread-safe hints ................................................... */
66 #if REP_WORKAROUND_REQUIRE_PROPAGATION
73 #define PTABLE_VAL_FREE(V) { \
74 rep_hint_t *h = (V); \
75 SvREFCNT_dec(h->comp); \
76 SvREFCNT_dec(h->exec); \
77 PerlMemShared_free(h); \
87 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
88 #define ptable_free(T) ptable_free(aTHX_ (T))
90 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
101 #if REP_HAS_PERL(5, 13, 2)
102 CLONE_PARAMS *params;
106 } rep_ptable_clone_ud;
108 #if REP_HAS_PERL(5, 13, 2)
109 # define rep_ptable_clone_ud_init(U, T, O) \
111 (U).params = Perl_clone_params_new((O), aTHX)
112 # define rep_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
113 # define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
115 # define rep_ptable_clone_ud_init(U, T, O) \
117 (U).params.stashes = newAV(); \
118 (U).params.flags = 0; \
119 (U).params.proto_perl = (O)
120 # define rep_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
121 # define rep_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
124 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
125 rep_ptable_clone_ud *ud = ud_;
126 rep_hint_t *h1 = ent->val;
129 h2 = PerlMemShared_malloc(sizeof *h2);
130 h2->comp = rep_dup_inc(h1->comp, ud);
131 h2->exec = rep_dup_inc(h1->exec, ud);
132 #if REP_WORKAROUND_REQUIRE_PROPAGATION
133 h2->require_tag = PTR2IV(rep_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
136 ptable_store(ud->tbl, ent->key, h2);
139 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
142 ptable_free(MY_CXT.tbl);
145 STATIC int rep_endav_free(pTHX_ SV *sv, MAGIC *mg) {
146 SAVEDESTRUCTOR_X(rep_thread_cleanup, NULL);
151 STATIC MGVTBL rep_endav_vtbl = {
168 #endif /* REP_THREADSAFE */
170 STATIC SV *rep_validate_callback(SV *code) {
175 if (SvTYPE(code) < SVt_PVCV)
178 return SvREFCNT_inc_simple_NN(code);
181 #if REP_WORKAROUND_REQUIRE_PROPAGATION
182 STATIC IV rep_require_tag(pTHX) {
183 #define rep_require_tag() rep_require_tag(aTHX)
184 const CV *cv, *outside;
189 /* If for some reason the pragma is operational at run-time, try to discover
190 * the current cv in use. */
193 for (si = PL_curstackinfo; si; si = si->si_prev) {
196 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
197 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
199 switch (CxTYPE(cx)) {
202 /* The propagation workaround is only needed up to 5.10.0 and at that
203 * time format and sub contexts were still identical. And even later the
204 * cv members offsets should have been kept the same. */
206 goto get_enclosing_cv;
208 cv = cx->blk_eval.cv;
209 goto get_enclosing_cv;
220 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
225 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
227 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
228 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
231 h = PerlMemShared_malloc(sizeof *h);
232 h->comp = rep_validate_callback(comp);
233 h->exec = rep_validate_callback(exec);
234 #if REP_WORKAROUND_REQUIRE_PROPAGATION
235 h->require_tag = rep_require_tag();
236 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
241 /* We only need for the key to be an unique tag for looking up the value later
242 * Allocated memory provides convenient unique identifiers, so that's why we
243 * use the hint as the key itself. */
244 ptable_store(MY_CXT.tbl, h, h);
246 #endif /* REP_THREADSAFE */
248 return newSViv(PTR2IV(h));
251 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
252 #define rep_detag(H) rep_detag(aTHX_ (H))
255 if (!(hint && SvIOK(hint)))
258 h = INT2PTR(rep_hint_t *, SvIVX(hint));
262 h = ptable_fetch(MY_CXT.tbl, h);
264 #endif /* REP_THREADSAFE */
266 #if REP_WORKAROUND_REQUIRE_PROPAGATION
267 if (rep_require_tag() != h->require_tag)
269 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
274 STATIC U32 rep_hash = 0;
276 STATIC const rep_hint_t *rep_hint(pTHX) {
277 #define rep_hint() rep_hint(aTHX)
280 #ifdef cop_hints_fetch_pvn
281 hint = cop_hints_fetch_pvn(PL_curcop,
282 __PACKAGE__, __PACKAGE_LEN__, rep_hash, 0);
284 /* We already require 5.9.5 for the regexp engine API. */
285 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
287 __PACKAGE__, __PACKAGE_LEN__,
292 return rep_detag(hint);
295 /* --- Custom regexp engine ------------------------------------------------ */
297 #define GET_SELF_FROM_PPRIVATE(pprivate) \
298 re__engine__Plugin self; \
299 SELF_FROM_PPRIVATE(self,pprivate);
301 /* re__engine__Plugin self; SELF_FROM_PPRIVATE(self,rx->pprivate) */
302 #define SELF_FROM_PPRIVATE(self, pprivate) \
303 if (sv_isobject(pprivate)) { \
304 SV * ref = SvRV((SV*)pprivate); \
305 IV tmp = SvIV((SV*)ref); \
306 self = INT2PTR(re__engine__Plugin,tmp); \
308 Perl_croak(aTHX_ "Not an object"); \
311 #if REP_HAS_PERL(5, 19, 4)
312 # define REP_ENG_EXEC_MINEND_TYPE SSize_t
314 # define REP_ENG_EXEC_MINEND_TYPE I32
318 EXTERN_C const regexp_engine engine_plugin;
319 #if REP_HAS_PERL(5, 11, 0)
320 EXTERN_C REGEXP * Plugin_comp(pTHX_ SV * const, U32);
322 EXTERN_C REGEXP * Plugin_comp(pTHX_ const SV * const, const U32);
324 EXTERN_C I32 Plugin_exec(pTHX_ REGEXP * const, char *, char *,
325 char *, REP_ENG_EXEC_MINEND_TYPE, SV *, void *, U32);
326 #if REP_HAS_PERL(5, 19, 1)
327 EXTERN_C char * Plugin_intuit(pTHX_ REGEXP * const, SV *, const char * const,
328 char *, char *, U32, re_scream_pos_data *);
330 EXTERN_C char * Plugin_intuit(pTHX_ REGEXP * const, SV *, char *,
331 char *, U32, re_scream_pos_data *);
333 EXTERN_C SV * Plugin_checkstr(pTHX_ REGEXP * const);
334 EXTERN_C void Plugin_free(pTHX_ REGEXP * const);
335 EXTERN_C void * Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
336 EXTERN_C void Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const,
337 const I32, SV * const);
338 EXTERN_C void Plugin_numbered_buff_STORE(pTHX_ REGEXP * const,
339 const I32, SV const * const);
340 EXTERN_C I32 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const,
341 const SV * const, const I32);
342 EXTERN_C SV * Plugin_named_buff (pTHX_ REGEXP * const, SV * const,
343 SV * const, const U32);
344 EXTERN_C SV * Plugin_named_buff_iter (pTHX_ REGEXP * const, const SV * const,
346 EXTERN_C SV * Plugin_package(pTHX_ REGEXP * const);
348 EXTERN_C void * Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
351 EXTERN_C const regexp_engine engine_plugin;
354 #define RE_ENGINE_PLUGIN (&engine_plugin)
355 const regexp_engine engine_plugin = {
361 Plugin_numbered_buff_FETCH,
362 Plugin_numbered_buff_STORE,
363 Plugin_numbered_buff_LENGTH,
365 Plugin_named_buff_iter,
367 #if defined(USE_ITHREADS)
370 #if REP_HAS_PERL(5, 17, 0)
375 typedef struct replug {
376 /* Pointer back to the containing regexp struct so that accessors
377 * can modify nparens, gofs etc. */
380 /* A copy of the pattern given to comp, for ->pattern */
383 /* A copy of the string being matched against, for ->str */
394 SV * cb_num_capture_buff_FETCH;
395 SV * cb_num_capture_buff_STORE;
396 SV * cb_num_capture_buff_LENGTH;
397 } *re__engine__Plugin;
399 #if REP_HAS_PERL(5, 11, 0)
400 # define rxREGEXP(RX) (SvANY(RX))
401 # define newREGEXP(RX) ((RX) = ((REGEXP*) newSV_type(SVt_REGEXP)))
403 # define rxREGEXP(RX) (RX)
404 # define newREGEXP(RX) (Newxz((RX), 1, struct regexp))
408 #if REP_HAS_PERL(5, 11, 0)
409 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
411 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
418 re__engine__Plugin re;
427 if (!h) /* This looks like a pragma leak. Apply the default behaviour */
428 return re_compile(pattern, flags);
430 /* exp/xend version of the pattern & length */
431 pbuf = SvPV((SV*)pattern, plen);
433 /* Our blessed object */
435 SvREFCNT_inc_simple_void_NN(obj);
436 Newxz(re, 1, struct replug);
437 sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
442 re->rx = rx; /* Make the rx accessible from self->rx */
443 rx->intflags = flags; /* Flags for internal use */
444 rx->extflags = flags; /* Flags for perl to use */
445 rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
447 #if !REP_HAS_PERL(5, 11, 0)
448 rx->refcnt = 1; /* Refcount so we won't be destroyed */
450 /* Precompiled pattern for pp_regcomp to use */
452 rx->precomp = savepvn(pbuf, rx->prelen);
454 /* Set up qr// stringification to be equivalent to the supplied
455 * pattern, this should be done via overload eventually.
457 rx->wraplen = rx->prelen;
458 Newx(rx->wrapped, rx->wraplen, char);
459 Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
462 /* Store our private object */
465 /* Store the pattern for ->pattern */
466 re->pattern = (SV*)pattern;
467 SvREFCNT_inc_simple_void(re->pattern);
469 /* If there's an exec callback, store it into the private object so
470 * that it will be the one to be called, even if the engine changes
473 re->cb_exec = h->exec;
474 SvREFCNT_inc_simple_void_NN(h->exec);
477 re->cb_num_capture_buff_FETCH = NULL;
478 re->cb_num_capture_buff_STORE = NULL;
479 re->cb_num_capture_buff_LENGTH = NULL;
481 /* Call our callback function if one was defined, if not we've
482 * already set up all the stuff we're going to to need for
483 * subsequent exec and other calls */
492 call_sv(h->comp, G_DISCARD);
498 /* If any of the comp-time accessors were called we'll have to
499 * update the regexp struct with the new info.
502 Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair);
508 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
509 char *strbeg, REP_ENG_EXEC_MINEND_TYPE minend,
510 SV *sv, void *data, U32 flags)
514 struct regexp *rx = rxREGEXP(RX);
515 GET_SELF_FROM_PPRIVATE(rx->pprivate);
520 /* Store the current str for ->str */
521 SvREFCNT_dec(self->str);
523 SvREFCNT_inc_simple_void(self->str);
529 XPUSHs(rx->pprivate);
533 call_sv(self->cb_exec, G_SCALAR);
554 #if REP_HAS_PERL(5, 19, 1)
555 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, const char * const strbeg,
556 char *strpos, char *strend, U32 flags, re_scream_pos_data *data)
558 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
559 char *strend, U32 flags, re_scream_pos_data *data)
564 #if REP_HAS_PERL(5, 19, 1)
565 PERL_UNUSED_ARG(strbeg);
567 PERL_UNUSED_ARG(strpos);
568 PERL_UNUSED_ARG(strend);
569 PERL_UNUSED_ARG(flags);
570 PERL_UNUSED_ARG(data);
575 Plugin_checkstr(pTHX_ REGEXP * const RX)
582 Plugin_free(pTHX_ REGEXP * const RX)
585 re__engine__Plugin self;
591 SELF_FROM_PPRIVATE(self, rx->pprivate);
593 SvREFCNT_dec(self->pattern);
594 SvREFCNT_dec(self->str);
596 SvREFCNT_dec(self->cb_exec);
598 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
599 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
600 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
609 callback = self->cb_free;
616 XPUSHs(rx->pprivate);
619 call_sv(callback, G_DISCARD);
630 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
632 struct regexp *rx = rxREGEXP(RX);
633 Perl_croak(aTHX_ "dupe not supported yet");
639 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
645 struct regexp *rx = rxREGEXP(RX);
646 GET_SELF_FROM_PPRIVATE(rx->pprivate);
648 callback = self->cb_num_capture_buff_FETCH;
655 XPUSHs(rx->pprivate);
656 XPUSHs(sv_2mortal(newSViv(paren)));
659 items = call_sv(callback, G_SCALAR);
668 sv_setsv(sv, &PL_sv_undef);
675 sv_setsv(sv, &PL_sv_undef);
680 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
681 SV const * const value)
685 struct regexp *rx = rxREGEXP(RX);
686 GET_SELF_FROM_PPRIVATE(rx->pprivate);
688 callback = self->cb_num_capture_buff_STORE;
695 XPUSHs(rx->pprivate);
696 XPUSHs(sv_2mortal(newSViv(paren)));
697 XPUSHs((SV *) value);
700 call_sv(callback, G_DISCARD);
709 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
714 struct regexp *rx = rxREGEXP(RX);
715 GET_SELF_FROM_PPRIVATE(rx->pprivate);
717 callback = self->cb_num_capture_buff_LENGTH;
726 XPUSHs(rx->pprivate);
727 XPUSHs(sv_2mortal(newSViv(paren)));
730 call_sv(callback, G_SCALAR);
742 /* TODO: call FETCH and get the length on that value */
749 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
756 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
763 Plugin_package(pTHX_ REGEXP * const RX)
766 return newSVpvs("re::engine::Plugin");
771 STATIC U32 rep_initialized = 0;
773 STATIC void rep_teardown(pTHX_ void *root) {
774 if (!rep_initialized || aTHX != root)
779 ptable_free(MY_CXT.tbl);
785 STATIC void rep_setup(pTHX) {
786 #define rep_setup() rep_setup(aTHX)
792 MY_CXT.tbl = ptable_new();
796 call_atexit(rep_teardown, aTHX);
801 #else /* REP_THREADSAFE */
805 #endif /* !REP_THREADSAFE */
807 STATIC U32 rep_booted = 0;
809 /* --- XS ------------------------------------------------------------------ */
811 MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin
820 PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
822 stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
823 newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(REP_THREADSAFE));
824 newCONSTSUB(stash, "REP_FORKSAFE", newSVuv(REP_FORKSAFE));
839 rep_ptable_clone_ud ud;
843 rep_ptable_clone_ud_init(ud, t, MY_CXT.owner);
844 ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
845 rep_ptable_clone_ud_deinit(ud);
852 gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
858 if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
860 sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &rep_endav_vtbl, NULL, 0);
868 rep_thread_cleanup(aTHX_ NULL);
871 #endif /* REP_THREADSAFE */
874 pattern(re::engine::Plugin self, ...)
876 XPUSHs(self->pattern);
879 str(re::engine::Plugin self, ...)
884 mod(re::engine::Plugin self)
890 flags = self->rx->intflags;
891 if (flags & PMf_FOLD) /* /i */
893 if (flags & PMf_MULTILINE) /* /m */
895 if (flags & PMf_SINGLELINE) /* /s */
897 if (flags & PMf_EXTENDED) /* /x */
899 if (flags & RXf_PMf_KEEPCOPY) /* /p */
903 for (i = 0; i < n; ++i) {
910 stash(re::engine::Plugin self, ...)
913 SvREFCNT_dec(self->stash);
915 SvREFCNT_inc_simple_void(self->stash);
922 minlen(re::engine::Plugin self, ...)
925 self->rx->minlen = (I32)SvIV(ST(1));
928 if (self->rx->minlen) {
929 XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
931 XPUSHs(sv_2mortal(&PL_sv_undef));
936 gofs(re::engine::Plugin self, ...)
939 self->rx->gofs = (U32)SvIV(ST(1));
942 if (self->rx->gofs) {
943 XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
945 XPUSHs(sv_2mortal(&PL_sv_undef));
950 nparens(re::engine::Plugin self, ...)
953 self->rx->nparens = (U32)SvIV(ST(1));
956 if (self->rx->nparens) {
957 XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
959 XPUSHs(sv_2mortal(&PL_sv_undef));
964 _exec(re::engine::Plugin self, ...)
967 SvREFCNT_dec(self->cb_exec);
968 self->cb_exec = ST(1);
969 SvREFCNT_inc_simple_void(self->cb_exec);
973 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
976 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
977 self->cb_num_capture_buff_FETCH = ST(1);
978 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH);
982 _num_capture_buff_STORE(re::engine::Plugin self, ...)
985 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
986 self->cb_num_capture_buff_STORE = ST(1);
987 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE);
991 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
994 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
995 self->cb_num_capture_buff_LENGTH = ST(1);
996 SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH);
1000 _tag(SV *comp, SV *exec)
1002 RETVAL = rep_tag(comp, exec);
1009 XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));