]> git.vpit.fr Git - perl/modules/re-engine-Plugin.git/blob - Plugin.xs
No automatic context
[perl/modules/re-engine-Plugin.git] / Plugin.xs
1 /* This file is part of the re::engine::Plugin Perl module.
2  * See http://search.cpan.org/dist/re-engine-Plugin/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #include "Plugin.h"
10
11 #define __PACKAGE__     "re::engine::Plugin"
12 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
13
14 #define REP_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
15
16 #ifndef REP_WORKAROUND_REQUIRE_PROPAGATION
17 # define REP_WORKAROUND_REQUIRE_PROPAGATION !REP_HAS_PERL(5, 10, 1)
18 #endif
19
20 /* ... Thread safety and multiplicity ...................................... */
21
22 #ifndef REP_MULTIPLICITY
23 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
24 #  define REP_MULTIPLICITY 1
25 # else
26 #  define REP_MULTIPLICITY 0
27 # endif
28 #endif
29 #if REP_MULTIPLICITY && !defined(tTHX)
30 # define tTHX PerlInterpreter*
31 #endif
32
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
35 # ifndef MY_CXT_CLONE
36 #  define MY_CXT_CLONE \
37     dMY_CXT_SV;                                                      \
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))
41 # endif
42 #else
43 # define REP_THREADSAFE 0
44 # undef  dMY_CXT
45 # define dMY_CXT      dNOOP
46 # undef  MY_CXT
47 # define MY_CXT       rep_globaldata
48 # undef  START_MY_CXT
49 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
50 # undef  MY_CXT_INIT
51 # define MY_CXT_INIT  NOOP
52 # undef  MY_CXT_CLONE
53 # define MY_CXT_CLONE NOOP
54 #endif
55
56 /* --- Helpers ------------------------------------------------------------- */
57
58 /* ... Thread-safe hints ................................................... */
59
60 typedef struct {
61  SV  *comp;
62  SV  *exec;
63 #if REP_WORKAROUND_REQUIRE_PROPAGATION
64  I32  requires;
65 #endif
66 } rep_hint_t;
67
68 #if REP_THREADSAFE
69
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);      \
75 }
76
77 #define pPTBL  pTHX
78 #define pPTBL_ pTHX_
79 #define aPTBL  aTHX
80 #define aPTBL_ aTHX_
81
82 #include "ptable.h"
83
84 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
85 #define ptable_free(T)        ptable_free(aTHX_ (T))
86
87 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
88
89 typedef struct {
90  ptable *tbl;
91  tTHX    owner;
92 } my_cxt_t;
93
94 START_MY_CXT
95
96 STATIC SV *rep_clone(pTHX_ SV *sv, tTHX owner) {
97 #define rep_clone(S, O) rep_clone(aTHX_ (S), (O))
98  CLONE_PARAMS  param;
99  AV           *stashes = NULL;
100  SV           *dupsv;
101
102  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
103   stashes = newAV();
104
105  param.stashes    = stashes;
106  param.flags      = 0;
107  param.proto_perl = owner;
108
109  dupsv = sv_dup(sv, &param);
110
111  if (stashes) {
112   av_undef(stashes);
113   SvREFCNT_dec(stashes);
114  }
115
116  return SvREFCNT_inc(dupsv);
117 }
118
119 STATIC void rep_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
120  my_cxt_t   *ud = ud_;
121  rep_hint_t *h1 = ent->val;
122  rep_hint_t *h2;
123
124  if (ud->owner == aTHX)
125   return;
126
127  h2           = PerlMemShared_malloc(sizeof *h2);
128  h2->comp     = rep_clone(h1->comp, ud->owner);
129  SvREFCNT_inc(h2->comp);
130  h2->exec     = rep_clone(h1->exec, ud->owner);
131  SvREFCNT_inc(h2->exec);
132 #if REP_WORKAROUND_REQUIRE_PROPAGATION
133  h2->requires = h1->requires;
134 #endif
135
136  ptable_store(ud->tbl, ent->key, h2);
137 }
138
139 STATIC void rep_thread_cleanup(pTHX_ void *);
140
141 STATIC void rep_thread_cleanup(pTHX_ void *ud) {
142  int *level = ud;
143
144  if (*level) {
145   *level = 0;
146   LEAVE;
147   SAVEDESTRUCTOR_X(rep_thread_cleanup, level);
148   ENTER;
149  } else {
150   dMY_CXT;
151   PerlMemShared_free(level);
152   ptable_free(MY_CXT.tbl);
153  }
154 }
155
156 #endif /* REP_THREADSAFE */
157
158 STATIC SV *rep_validate_callback(SV *code) {
159  if (!SvROK(code))
160   return NULL;
161
162  code = SvRV(code);
163  if (SvTYPE(code) < SVt_PVCV)
164   return NULL;
165
166  return SvREFCNT_inc_simple_NN(code);
167 }
168
169 STATIC SV *rep_tag(pTHX_ SV *comp, SV *exec) {
170 #define rep_tag(C, E) rep_tag(aTHX_ (C), (E))
171  rep_hint_t *h;
172  dMY_CXT;
173
174  h = PerlMemShared_malloc(sizeof *h);
175
176  h->comp = rep_validate_callback(comp);
177  h->exec = rep_validate_callback(exec);
178
179 #if REP_WORKAROUND_REQUIRE_PROPAGATION
180  {
181   const PERL_SI *si;
182   I32            requires = 0;
183
184   for (si = PL_curstackinfo; si; si = si->si_prev) {
185    I32 cxix;
186
187    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
188     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
189
190     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
191      ++requires;
192    }
193   }
194
195   h->requires = requires;
196  }
197 #endif
198
199 #if REP_THREADSAFE
200  /* We only need for the key to be an unique tag for looking up the value later.
201   * Allocated memory provides convenient unique identifiers, so that's why we
202   * use the hint as the key itself. */
203  ptable_store(MY_CXT.tbl, h, h);
204 #endif /* REP_THREADSAFE */
205
206  return newSViv(PTR2IV(h));
207 }
208
209 STATIC const rep_hint_t *rep_detag(pTHX_ const SV *hint) {
210 #define rep_detag(H) rep_detag(aTHX_ (H))
211  rep_hint_t *h;
212  dMY_CXT;
213
214  if (!(hint && SvIOK(hint)))
215   return NULL;
216
217  h = INT2PTR(rep_hint_t *, SvIVX(hint));
218 #if REP_THREADSAFE
219  h = ptable_fetch(MY_CXT.tbl, h);
220 #endif /* REP_THREADSAFE */
221
222 #if REP_WORKAROUND_REQUIRE_PROPAGATION
223  {
224   const PERL_SI *si;
225   I32            requires = 0;
226
227   for (si = PL_curstackinfo; si; si = si->si_prev) {
228    I32 cxix;
229
230    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
231     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
232
233     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
234                                && ++requires > h->requires)
235      return NULL;
236    }
237   }
238  }
239 #endif
240
241  return h;
242 }
243
244 STATIC U32 rep_hash = 0;
245
246 STATIC const rep_hint_t *rep_hint(pTHX) {
247 #define rep_hint() rep_hint(aTHX)
248  SV *hint;
249
250  /* We already require 5.9.5 for the regexp engine API. */
251  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
252                                        NULL,
253                                        __PACKAGE__, __PACKAGE_LEN__,
254                                        0,
255                                        rep_hash);
256
257  return rep_detag(hint);
258 }
259
260 REGEXP *
261 #if PERL_VERSION <= 10
262 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
263 #else
264 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
265 #endif
266 {
267     dSP;
268     struct regexp * rx;
269     REGEXP *RX;
270     I32 buffers;
271     re__engine__Plugin re;
272     const rep_hint_t *h;
273
274     /* exp/xend version of the pattern & length */
275     STRLEN plen;
276     char*  exp = SvPV((SV*)pattern, plen);
277
278     /* Our blessed object */
279     SV *obj = newSV(0);
280     SvREFCNT_inc(obj);
281     Newxz(re, 1, struct replug);
282     sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
283
284     newREGEXP(RX);
285     rx = rxREGEXP(RX);
286
287     re->rx = rx;                   /* Make the rx accessible from self->rx */
288     rx->intflags = flags;          /* Flags for internal use */
289     rx->extflags = flags;          /* Flags for perl to use */
290     rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
291
292 #if PERL_VERSION <= 10
293     rx->refcnt = 1;                /* Refcount so we won't be destroyed */
294
295     /* Precompiled pattern for pp_regcomp to use */
296     rx->prelen = plen;
297     rx->precomp = savepvn(exp, rx->prelen);
298
299     /* Set up qr// stringification to be equivalent to the supplied
300      * pattern, this should be done via overload eventually.
301      */
302     rx->wraplen = rx->prelen;
303     Newx(rx->wrapped, rx->wraplen, char);
304     Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
305 #endif
306
307     /* Store our private object */
308     rx->pprivate = obj;
309
310     /* Store the pattern for ->pattern */
311     re->pattern = (SV*)pattern;
312     SvREFCNT_inc(re->pattern);
313
314     /*
315      * Call our callback function if one was defined, if not we've
316      * already set up all the stuff we're going to to need for
317      * subsequent exec and other calls
318      */
319     h = rep_hint();
320     if (h && h->comp) {
321         ENTER;    
322         SAVETMPS;
323    
324         PUSHMARK(SP);
325         XPUSHs(obj);
326         PUTBACK;
327
328         call_sv(h->comp, G_DISCARD);
329
330         FREETMPS;
331         LEAVE;
332     }
333
334     /* If any of the comp-time accessors were called we'll have to
335      * update the regexp struct with the new info.
336      */
337
338     buffers = rx->nparens;
339
340     Newxz(rx->offs, buffers + 1, regexp_paren_pair);
341
342     return RX;
343 }
344
345 I32
346 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
347             char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
348 {
349     dSP;
350     I32 matched;
351     struct regexp *rx = rxREGEXP(RX);
352     const rep_hint_t *h;
353     GET_SELF_FROM_PPRIVATE(rx->pprivate);
354
355     h = rep_hint();
356     if (h && h->exec) {
357         /* Store the current str for ->str */
358         self->str = (SV*)sv;
359         SvREFCNT_inc(self->str);
360
361         ENTER;
362         SAVETMPS;
363    
364         PUSHMARK(SP);
365         XPUSHs(rx->pprivate);
366         XPUSHs(sv);
367         PUTBACK;
368
369         call_sv(h->exec, G_SCALAR);
370  
371         SPAGAIN;
372
373         SV * ret = POPs;
374
375         if (SvTRUE(ret))
376             matched = 1;
377         else
378             matched = 0;
379
380         PUTBACK;
381         FREETMPS;
382         LEAVE;
383     } else {
384         matched = 0;
385     }
386
387     return matched;
388 }
389
390 char *
391 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
392                      char *strend, U32 flags, re_scream_pos_data *data)
393 {
394     PERL_UNUSED_ARG(RX);
395     PERL_UNUSED_ARG(sv);
396     PERL_UNUSED_ARG(strpos);
397     PERL_UNUSED_ARG(strend);
398     PERL_UNUSED_ARG(flags);
399     PERL_UNUSED_ARG(data);
400     return NULL;
401 }
402
403 SV *
404 Plugin_checkstr(pTHX_ REGEXP * const RX)
405 {
406     PERL_UNUSED_ARG(RX);
407     return NULL;
408 }
409
410 void
411 Plugin_free(pTHX_ REGEXP * const RX)
412 {
413     PERL_UNUSED_ARG(RX);
414 /*
415     dSP;
416     SV * callback;
417     GET_SELF_FROM_PPRIVATE(rx->pprivate);
418
419     callback = self->cb_free;
420
421     if (callback) {
422         ENTER;
423         SAVETMPS;
424    
425         PUSHMARK(SP);
426         XPUSHs(rx->pprivate);
427         PUTBACK;
428
429         call_sv(callback, G_DISCARD);
430
431         PUTBACK;
432         FREETMPS;
433         LEAVE;
434     }
435     return;
436 */
437 }
438
439 void *
440 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
441 {
442     struct regexp *rx = rxREGEXP(RX);
443     Perl_croak(aTHX_ "dupe not supported yet");
444     return rx->pprivate;
445 }
446
447
448 void
449 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
450                            SV * const sv)
451 {
452     dSP;
453     I32 items;
454     SV * callback;
455     struct regexp *rx = rxREGEXP(RX);
456     GET_SELF_FROM_PPRIVATE(rx->pprivate);
457
458     callback = self->cb_num_capture_buff_FETCH;
459
460     if (callback) {
461         ENTER;
462         SAVETMPS;
463    
464         PUSHMARK(SP);
465         XPUSHs(rx->pprivate);
466         XPUSHs(sv_2mortal(newSViv(paren)));
467         PUTBACK;
468
469         items = call_sv(callback, G_SCALAR);
470         
471         if (items == 1) {
472             SPAGAIN;
473
474             SV * ret = POPs;
475             sv_setsv(sv, ret);
476         } else {
477             sv_setsv(sv, &PL_sv_undef);
478         }
479
480         PUTBACK;
481         FREETMPS;
482         LEAVE;
483     } else {
484         sv_setsv(sv, &PL_sv_undef);
485     }
486 }
487
488 void
489 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
490                            SV const * const value)
491 {
492     dSP;
493     SV * callback;
494     struct regexp *rx = rxREGEXP(RX);
495     GET_SELF_FROM_PPRIVATE(rx->pprivate);
496
497     callback = self->cb_num_capture_buff_STORE;
498
499     if (callback) {
500         ENTER;
501         SAVETMPS;
502    
503         PUSHMARK(SP);
504         XPUSHs(rx->pprivate);
505         XPUSHs(sv_2mortal(newSViv(paren)));
506         XPUSHs(SvREFCNT_inc((SV *) value));
507         PUTBACK;
508
509         call_sv(callback, G_DISCARD);
510
511         PUTBACK;
512         FREETMPS;
513         LEAVE;
514     }
515 }
516
517 I32
518 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
519                               const I32 paren)
520 {
521     dSP;
522     SV * callback;
523     struct regexp *rx = rxREGEXP(RX);
524     GET_SELF_FROM_PPRIVATE(rx->pprivate);
525
526     callback = self->cb_num_capture_buff_LENGTH;
527
528     if (callback) {
529         ENTER;
530         SAVETMPS;
531    
532         PUSHMARK(SP);
533         XPUSHs(rx->pprivate);
534         XPUSHs(sv_2mortal(newSViv(paren)));
535         PUTBACK;
536
537         call_sv(callback, G_SCALAR);
538
539         SPAGAIN;
540
541         IV ret = POPi;
542
543         PUTBACK;
544         FREETMPS;
545         LEAVE;
546
547         return (I32)ret;
548     } else {
549         /* TODO: call FETCH and get the length on that value */
550         return 0;
551     }
552 }
553
554
555 SV*
556 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
557                    const U32 flags)
558 {
559     return NULL;
560 }
561
562 SV*
563 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
564                         const U32 flags)
565 {
566     return NULL;
567 }
568
569 SV*
570 Plugin_package(pTHX_ REGEXP * const RX)
571 {
572     PERL_UNUSED_ARG(RX);
573     return newSVpvs("re::engine::Plugin");
574 }
575
576 #if REP_THREADSAFE
577
578 STATIC U32 rep_initialized = 0;
579
580 STATIC void rep_teardown(pTHX_ void *root) {
581  dMY_CXT;
582
583  if (!rep_initialized || aTHX != root)
584   return;
585
586  ptable_free(MY_CXT.tbl);
587
588  rep_initialized = 0;
589 }
590
591 STATIC void rep_setup(pTHX) {
592 #define rep_setup() rep_setup(aTHX)
593  if (rep_initialized)
594   return;
595
596  MY_CXT_INIT;
597  MY_CXT.tbl   = ptable_new();
598  MY_CXT.owner = aTHX;
599
600  call_atexit(rep_teardown, aTHX);
601
602  rep_initialized = 1;
603 }
604
605 #else  /*  REP_THREADSAFE */
606
607 #define rep_setup()
608
609 #endif /* !REP_THREADSAFE */
610
611 STATIC U32 rep_booted = 0;
612
613 /* --- XS ------------------------------------------------------------------ */
614
615 MODULE = re::engine::Plugin     PACKAGE = re::engine::Plugin
616
617 PROTOTYPES: DISABLE
618
619 BOOT:
620 {
621     if (!rep_booted++) {
622         PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
623     }
624
625     rep_setup();
626 }
627
628 #if REP_THREADSAFE
629
630 void
631 CLONE(...)
632 PREINIT:
633     ptable *t;
634     int    *level;
635 CODE:
636     {
637         my_cxt_t ud;
638         dMY_CXT;
639         ud.tbl   = t = ptable_new();
640         ud.owner = MY_CXT.owner;
641         ptable_walk(MY_CXT.tbl, rep_ptable_clone, &ud);
642     }
643     {
644         MY_CXT_CLONE;
645         MY_CXT.tbl   = t;
646         MY_CXT.owner = aTHX;
647     }
648
649 #endif
650
651 void
652 pattern(re::engine::Plugin self, ...)
653 PPCODE:
654     XPUSHs(self->pattern);
655
656 void
657 str(re::engine::Plugin self, ...)
658 PPCODE:
659     XPUSHs(self->str);
660
661 char*
662 mod(re::engine::Plugin self, ...)
663 PPCODE:
664     /* /i */
665     if (self->rx->intflags & PMf_FOLD) {
666       XPUSHs(sv_2mortal(newSVpvs("i")));
667       XPUSHs(&PL_sv_yes);
668     }
669
670     /* /m */
671     if (self->rx->intflags & PMf_MULTILINE) {
672       XPUSHs(sv_2mortal(newSVpvs("m")));
673       XPUSHs(&PL_sv_yes);
674     }
675
676     /* /s */
677     if (self->rx->intflags & PMf_SINGLELINE) {
678       XPUSHs(sv_2mortal(newSVpvs("s")));
679       XPUSHs(&PL_sv_yes);
680     }
681
682     /* /x */
683     if (self->rx->intflags & PMf_EXTENDED) {
684       XPUSHs(sv_2mortal(newSVpvs("x")));
685       XPUSHs(&PL_sv_yes);
686     }
687
688     /* /p */
689     if (self->rx->intflags & RXf_PMf_KEEPCOPY) {
690       XPUSHs(sv_2mortal(newSVpvs("p")));
691       XPUSHs(&PL_sv_yes);
692     }
693
694 void
695 stash(re::engine::Plugin self, ...)
696 PPCODE:
697     if (items > 1) {
698         self->stash = ST(1);
699         SvREFCNT_inc(self->stash);
700         XSRETURN_EMPTY;
701     } else {
702         XPUSHs(self->stash);
703     }
704
705 void
706 minlen(re::engine::Plugin self, ...)
707 PPCODE:
708     if (items > 1) {
709         self->rx->minlen = (I32)SvIV(ST(1));
710         XSRETURN_EMPTY;
711     } else {
712         if (self->rx->minlen) {
713             XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
714         } else {
715             XPUSHs(sv_2mortal(&PL_sv_undef));
716         }
717     }
718
719 void
720 gofs(re::engine::Plugin self, ...)
721 PPCODE:
722     if (items > 1) {
723         self->rx->gofs = (U32)SvIV(ST(1));
724         XSRETURN_EMPTY;
725     } else {
726         if (self->rx->gofs) {
727             XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
728         } else {
729             XPUSHs(sv_2mortal(&PL_sv_undef));
730         }
731     }
732
733 void
734 nparens(re::engine::Plugin self, ...)
735 PPCODE:
736     if (items > 1) {
737         self->rx->nparens = (U32)SvIV(ST(1));
738         XSRETURN_EMPTY;
739     } else {
740         if (self->rx->nparens) {
741             XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
742         } else {
743             XPUSHs(sv_2mortal(&PL_sv_undef));
744         }
745     }
746
747 void
748 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
749 PPCODE:
750     if (items > 1) {
751         self->cb_num_capture_buff_FETCH = ST(1);
752         SvREFCNT_inc(self->cb_num_capture_buff_FETCH);
753     }
754
755 void
756 _num_capture_buff_STORE(re::engine::Plugin self, ...)
757 PPCODE:
758     if (items > 1) {
759         self->cb_num_capture_buff_STORE = ST(1);
760         SvREFCNT_inc(self->cb_num_capture_buff_STORE);
761     }
762
763 void
764 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
765 PPCODE:
766     if (items > 1) {
767         self->cb_num_capture_buff_LENGTH = ST(1);
768         SvREFCNT_inc(self->cb_num_capture_buff_LENGTH);
769     }
770
771 SV *
772 _tag(SV *comp, SV *exec)
773 CODE:
774     RETVAL = rep_tag(comp, exec);
775 OUTPUT:
776     RETVAL
777
778 void
779 ENGINE()
780 PPCODE:
781     XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));