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))))))
17 #if defined(ENTER_with_name) && !REP_HAS_PERL(5, 11, 4)
18 # define ENTERn(N) ENTER_with_name(N)
20 # define ENTERn(N) ENTER
24 #if defined(LEAVE_with_name) && !REP_HAS_PERL(5, 11, 4)
25 # define LEAVEn(N) LEAVE_with_name(N)
27 # define LEAVEn(N) LEAVE
30 #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
31 # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
34 /* ... Thread safety and multiplicity ...................................... */
36 #ifndef REP_MULTIPLICITY
37 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
38 # define REP_MULTIPLICITY 1
40 # define REP_MULTIPLICITY 0
43 #if REP_MULTIPLICITY && !defined(tTHX)
44 # define tTHX PerlInterpreter*
47 #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))
48 # define REP_THREADSAFE 1
50 # define MY_CXT_CLONE \
52 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
53 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
54 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
57 # define REP_THREADSAFE 0
59 # define dMY_CXT dNOOP
61 # define MY_CXT rep_globaldata
63 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
65 # define MY_CXT_INIT NOOP
67 # define MY_CXT_CLONE NOOP
70 /* --- Helpers ------------------------------------------------------------- */
72 /* ... Thread-safe hints ................................................... */
77 #if REP_WORKAROUND_REQUIRE_PROPAGATION
84 #define PTABLE_VAL_FREE(V) { \
85 rep_hint_t *h = (V); \
86 SvREFCNT_dec(h->comp); \
87 SvREFCNT_dec(h->exec); \
88 PerlMemShared_free(h); \
98 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
99 #define ptable_free(T) ptable_free(aTHX_ (T))
101 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
110 STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) {
111 #define rep_clone(S, O) rep_clone(aTHX_ (S), (O))
116 if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
119 param.stashes = stashes;
121 param.proto_perl = owner;
123 dupsv = sv_dup(sv, ¶m);
127 SvREFCNT_dec(stashes);
130 return SvREFCNT_inc(dupsv);
133 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
135 rep_hint_t *h1 = ent->val;
138 if (ud->owner == aTHX)
141 h2 = PerlMemShared_malloc(sizeof *h2);
142 h2->comp = rep_clone(h1->comp, ud->owner);
143 SvREFCNT_inc(h2->comp);
144 h2->exec = rep_clone(h1->exec, ud->owner);
145 SvREFCNT_inc(h2->exec);
146 #if REP_WORKAROUND_REQUIRE_PROPAGATION
147 h2->cxreq = h1->cxreq;
150 ptable_store(ud->tbl, ent->key, h2);
153 STATIC void rep_thread_cleanup(pTHX_ void *);
155 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
161 SAVEDESTRUCTOR_X(rep_thread_cleanup, level);
165 PerlMemShared_free(level);
166 ptable_free(MY_CXT.tbl);
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)
188 for (si = PL_curstackinfo; si; si = si->si_prev) {
191 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
192 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
194 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
201 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
203 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
204 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
208 h = PerlMemShared_malloc(sizeof *h);
209 h->comp = rep_validate_callback(comp);
210 h->exec = rep_validate_callback(exec);
211 #if REP_WORKAROUND_REQUIRE_PROPAGATION
212 h->cxreq = rep_require_tag();
213 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
216 /* We only need for the key to be an unique tag for looking up the value later.
217 * Allocated memory provides convenient unique identifiers, so that's why we
218 * use the hint as the key itself. */
219 ptable_store(MY_CXT.tbl, h, h);
220 #endif /* REP_THREADSAFE */
222 return newSViv(PTR2IV(h));
225 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
226 #define rep_detag(H) rep_detag(aTHX_ (H))
230 if (!(hint && SvIOK(hint)))
233 h = INT2PTR(rep_hint_t *, SvIVX(hint));
235 h = ptable_fetch(MY_CXT.tbl, h);
236 #endif /* REP_THREADSAFE */
238 #if REP_WORKAROUND_REQUIRE_PROPAGATION
239 if (rep_require_tag() != h->cxreq)
241 #endif /* REP_WORKAROUND_REQUIRE_PROPAGATION */
246 STATIC U32 rep_hash = 0;
248 STATIC const rep_hint_t *rep_hint(pTHX) {
249 #define rep_hint() rep_hint(aTHX)
252 /* We already require 5.9.5 for the regexp engine API. */
253 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
255 __PACKAGE__, __PACKAGE_LEN__,
259 return rep_detag(hint);
263 #if PERL_VERSION <= 10
264 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
266 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
273 re__engine__Plugin re;
277 if (!h) /* This looks like a pragma leak. Apply the default behaviour */
278 return re_compile(pattern, flags);
280 /* exp/xend version of the pattern & length */
282 char* exp = SvPV((SV*)pattern, plen);
284 /* Our blessed object */
287 Newxz(re, 1, struct replug);
288 sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
293 re->rx = rx; /* Make the rx accessible from self->rx */
294 rx->intflags = flags; /* Flags for internal use */
295 rx->extflags = flags; /* Flags for perl to use */
296 rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
298 #if PERL_VERSION <= 10
299 rx->refcnt = 1; /* Refcount so we won't be destroyed */
301 /* Precompiled pattern for pp_regcomp to use */
303 rx->precomp = savepvn(exp, rx->prelen);
305 /* Set up qr// stringification to be equivalent to the supplied
306 * pattern, this should be done via overload eventually.
308 rx->wraplen = rx->prelen;
309 Newx(rx->wrapped, rx->wraplen, char);
310 Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
313 /* Store our private object */
316 /* Store the pattern for ->pattern */
317 re->pattern = (SV*)pattern;
318 SvREFCNT_inc(re->pattern);
320 /* If there's an exec callback, store it into the private object so
321 * that it will be the one to be called, even if the engine changes
324 re->cb_exec = h->exec;
325 SvREFCNT_inc_simple_void_NN(h->exec);
328 re->cb_num_capture_buff_FETCH = NULL;
329 re->cb_num_capture_buff_STORE = NULL;
330 re->cb_num_capture_buff_LENGTH = NULL;
332 /* Call our callback function if one was defined, if not we've
333 * already set up all the stuff we're going to to need for
334 * subsequent exec and other calls */
343 call_sv(h->comp, G_DISCARD);
349 /* If any of the comp-time accessors were called we'll have to
350 * update the regexp struct with the new info.
353 buffers = rx->nparens;
355 Newxz(rx->offs, buffers + 1, regexp_paren_pair);
361 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
362 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
366 struct regexp *rx = rxREGEXP(RX);
367 GET_SELF_FROM_PPRIVATE(rx->pprivate);
370 /* Store the current str for ->str */
372 SvREFCNT_inc(self->str);
378 XPUSHs(rx->pprivate);
382 call_sv(self->cb_exec, G_SCALAR);
404 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
405 char *strend, U32 flags, re_scream_pos_data *data)
409 PERL_UNUSED_ARG(strpos);
410 PERL_UNUSED_ARG(strend);
411 PERL_UNUSED_ARG(flags);
412 PERL_UNUSED_ARG(data);
417 Plugin_checkstr(pTHX_ REGEXP * const RX)
424 Plugin_free(pTHX_ REGEXP * const RX)
426 struct regexp *rx = rxREGEXP(RX);
427 GET_SELF_FROM_PPRIVATE(rx->pprivate);
429 SvREFCNT_dec(self->pattern);
430 SvREFCNT_dec(self->str);
432 SvREFCNT_dec(self->cb_exec);
434 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
435 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
436 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
445 callback = self->cb_free;
452 XPUSHs(rx->pprivate);
455 call_sv(callback, G_DISCARD);
466 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
468 struct regexp *rx = rxREGEXP(RX);
469 Perl_croak(aTHX_ "dupe not supported yet");
475 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
481 struct regexp *rx = rxREGEXP(RX);
482 GET_SELF_FROM_PPRIVATE(rx->pprivate);
484 callback = self->cb_num_capture_buff_FETCH;
491 XPUSHs(rx->pprivate);
492 XPUSHs(sv_2mortal(newSViv(paren)));
495 items = call_sv(callback, G_SCALAR);
503 sv_setsv(sv, &PL_sv_undef);
510 sv_setsv(sv, &PL_sv_undef);
515 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
516 SV const * const value)
520 struct regexp *rx = rxREGEXP(RX);
521 GET_SELF_FROM_PPRIVATE(rx->pprivate);
523 callback = self->cb_num_capture_buff_STORE;
530 XPUSHs(rx->pprivate);
531 XPUSHs(sv_2mortal(newSViv(paren)));
532 XPUSHs(SvREFCNT_inc((SV *) value));
535 call_sv(callback, G_DISCARD);
544 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
549 struct regexp *rx = rxREGEXP(RX);
550 GET_SELF_FROM_PPRIVATE(rx->pprivate);
552 callback = self->cb_num_capture_buff_LENGTH;
559 XPUSHs(rx->pprivate);
560 XPUSHs(sv_2mortal(newSViv(paren)));
563 call_sv(callback, G_SCALAR);
575 /* TODO: call FETCH and get the length on that value */
582 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
589 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
596 Plugin_package(pTHX_ REGEXP * const RX)
599 return newSVpvs("re::engine::Plugin");
604 STATIC U32 rep_initialized = 0;
606 STATIC void rep_teardown(pTHX_ void *root) {
609 if (!rep_initialized || aTHX != root)
612 ptable_free(MY_CXT.tbl);
617 STATIC void rep_setup(pTHX) {
618 #define rep_setup() rep_setup(aTHX)
623 MY_CXT.tbl = ptable_new();
626 call_atexit(rep_teardown, aTHX);
631 #else /* REP_THREADSAFE */
635 #endif /* !REP_THREADSAFE */
637 STATIC U32 rep_booted = 0;
639 /* --- XS ------------------------------------------------------------------ */
641 MODULE = re::engine::Plugin PACKAGE = re::engine::Plugin
648 PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
665 ud.tbl = t = ptable_new();
666 ud.owner = MY_CXT.owner;
667 ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
675 level = PerlMemShared_malloc(sizeof *level);
678 SAVEDESTRUCTOR_X(rep_thread_cleanup, level);
685 pattern(re::engine::Plugin self, ...)
687 XPUSHs(self->pattern);
690 str(re::engine::Plugin self, ...)
695 mod(re::engine::Plugin self, ...)
698 if (self->rx->intflags & PMf_FOLD) {
699 XPUSHs(sv_2mortal(newSVpvs("i")));
704 if (self->rx->intflags & PMf_MULTILINE) {
705 XPUSHs(sv_2mortal(newSVpvs("m")));
710 if (self->rx->intflags & PMf_SINGLELINE) {
711 XPUSHs(sv_2mortal(newSVpvs("s")));
716 if (self->rx->intflags & PMf_EXTENDED) {
717 XPUSHs(sv_2mortal(newSVpvs("x")));
722 if (self->rx->intflags & RXf_PMf_KEEPCOPY) {
723 XPUSHs(sv_2mortal(newSVpvs("p")));
728 stash(re::engine::Plugin self, ...)
732 SvREFCNT_inc(self->stash);
739 minlen(re::engine::Plugin self, ...)
742 self->rx->minlen = (I32)SvIV(ST(1));
745 if (self->rx->minlen) {
746 XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
748 XPUSHs(sv_2mortal(&PL_sv_undef));
753 gofs(re::engine::Plugin self, ...)
756 self->rx->gofs = (U32)SvIV(ST(1));
759 if (self->rx->gofs) {
760 XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
762 XPUSHs(sv_2mortal(&PL_sv_undef));
767 nparens(re::engine::Plugin self, ...)
770 self->rx->nparens = (U32)SvIV(ST(1));
773 if (self->rx->nparens) {
774 XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
776 XPUSHs(sv_2mortal(&PL_sv_undef));
781 _exec(re::engine::Plugin self, ...)
784 SvREFCNT_dec(self->cb_exec);
785 self->cb_exec = ST(1);
786 SvREFCNT_inc(self->cb_exec);
790 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
793 SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
794 self->cb_num_capture_buff_FETCH = ST(1);
795 SvREFCNT_inc(self->cb_num_capture_buff_FETCH);
799 _num_capture_buff_STORE(re::engine::Plugin self, ...)
802 SvREFCNT_dec(self->cb_num_capture_buff_STORE);
803 self->cb_num_capture_buff_STORE = ST(1);
804 SvREFCNT_inc(self->cb_num_capture_buff_STORE);
808 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
811 SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
812 self->cb_num_capture_buff_LENGTH = ST(1);
813 SvREFCNT_inc(self->cb_num_capture_buff_LENGTH);
817 _tag(SV *comp, SV *exec)
819 RETVAL = rep_tag(comp, exec);
826 XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));