]> git.vpit.fr Git - perl/modules/re-engine-Plugin.git/blob - Plugin.xs
Reinstate Ævar as a full-fledged author
[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 /* --- Helpers ------------------------------------------------------------- */
10
11 #define XSH_PACKAGE "re::engine::Plugin"
12
13 #include "xsh/caps.h"
14 #include "xsh/util.h"
15
16 /* ... Lexical hints ....................................................... */
17
18 typedef struct {
19  SV *comp;
20  SV *exec;
21 } xsh_hints_user_t;
22
23 STATIC SV *rep_validate_callback(SV *code) {
24  if (!SvROK(code))
25   return NULL;
26
27  code = SvRV(code);
28  if (SvTYPE(code) < SVt_PVCV)
29   return NULL;
30
31  return SvREFCNT_inc_simple_NN(code);
32 }
33
34 static void xsh_hints_user_init(pTHX_ xsh_hints_user_t *hv, xsh_hints_user_t *v) {
35  hv->comp = rep_validate_callback(v->comp);
36  hv->exec = rep_validate_callback(v->exec);
37
38  return;
39 }
40
41 #if XSH_THREADSAFE
42
43 static void xsh_hints_user_clone(pTHX_ xsh_hints_user_t *nv, xsh_hints_user_t *ov, CLONE_PARAMS *params) {
44  nv->comp = xsh_dup_inc(ov->comp, params);
45  nv->exec = xsh_dup_inc(ov->exec, params);
46
47  return;
48 }
49
50 #endif /* XSH_THREADSAFE */
51
52 static void xsh_hints_user_deinit(pTHX_ xsh_hints_user_t *hv) {
53  SvREFCNT_dec(hv->comp);
54  SvREFCNT_dec(hv->exec);
55
56  return;
57 }
58
59 #define rep_hint() xsh_hints_detag(xsh_hints_fetch())
60
61 #define XSH_HINTS_TYPE_USER         1
62 #define XSH_HINTS_ONLY_COMPILE_TIME 0
63
64 #include "xsh/hints.h"
65
66 /* ... Thread-local storage ................................................ */
67
68 #define XSH_THREADS_USER_CONTEXT            0
69 #define XSH_THREADS_USER_LOCAL_SETUP        0
70 #define XSH_THREADS_USER_LOCAL_TEARDOWN     0
71 #define XSH_THREADS_USER_GLOBAL_TEARDOWN    0
72 #define XSH_THREADS_COMPILE_TIME_PROTECTION 0
73
74 #include "xsh/threads.h"
75
76 /* --- Custom regexp engine ------------------------------------------------ */
77
78 #define GET_SELF_FROM_PPRIVATE(pprivate)        \
79     re__engine__Plugin self;                    \
80     SELF_FROM_PPRIVATE(self,pprivate);
81
82 /* re__engine__Plugin self; SELF_FROM_PPRIVATE(self,rx->pprivate) */
83 #define SELF_FROM_PPRIVATE(self, pprivate)                   \
84     if (sv_isobject(pprivate)) {                             \
85         SV * ref = SvRV((SV*)pprivate);                      \
86         IV tmp = SvIV((SV*)ref);                             \
87         self = INT2PTR(re__engine__Plugin,tmp);              \
88     } else {                                                 \
89         Perl_croak(aTHX_ "Not an object");                   \
90     }
91
92 #if XSH_HAS_PERL(5, 19, 4)
93 # define REP_ENG_EXEC_MINEND_TYPE SSize_t
94 #else
95 # define REP_ENG_EXEC_MINEND_TYPE I32
96 #endif
97
98 START_EXTERN_C
99 EXTERN_C const regexp_engine engine_plugin;
100 #if XSH_HAS_PERL(5, 11, 0)
101 EXTERN_C REGEXP * Plugin_comp(pTHX_ SV * const, U32);
102 #else
103 EXTERN_C REGEXP * Plugin_comp(pTHX_ const SV * const, const U32);
104 #endif
105 EXTERN_C I32      Plugin_exec(pTHX_ REGEXP * const, char *, char *,
106                               char *, REP_ENG_EXEC_MINEND_TYPE, SV *, void *, U32);
107 #if XSH_HAS_PERL(5, 19, 1)
108 EXTERN_C char *   Plugin_intuit(pTHX_ REGEXP * const, SV *, const char * const,
109                                 char *, char *, U32, re_scream_pos_data *);
110 #else
111 EXTERN_C char *   Plugin_intuit(pTHX_ REGEXP * const, SV *, char *,
112                                 char *, U32, re_scream_pos_data *);
113 #endif
114 EXTERN_C SV *     Plugin_checkstr(pTHX_ REGEXP * const);
115 EXTERN_C void     Plugin_free(pTHX_ REGEXP * const);
116 EXTERN_C void *   Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
117 EXTERN_C void     Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const,
118                                              const I32, SV * const);
119 EXTERN_C void     Plugin_numbered_buff_STORE(pTHX_ REGEXP * const,
120                                              const I32, SV const * const);
121 EXTERN_C I32      Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const,
122                                               const SV * const, const I32);
123 EXTERN_C SV *     Plugin_named_buff (pTHX_ REGEXP * const, SV * const,
124                                      SV * const, const U32);
125 EXTERN_C SV *     Plugin_named_buff_iter (pTHX_ REGEXP * const, const SV * const,
126                                           const U32);
127 EXTERN_C SV *     Plugin_package(pTHX_ REGEXP * const);
128 #ifdef USE_ITHREADS
129 EXTERN_C void *   Plugin_dupe(pTHX_ REGEXP * const, CLONE_PARAMS *);
130 #endif
131
132 EXTERN_C const regexp_engine engine_plugin;
133 END_EXTERN_C
134
135 #define RE_ENGINE_PLUGIN (&engine_plugin)
136 const regexp_engine engine_plugin = {
137     Plugin_comp,
138     Plugin_exec,
139     Plugin_intuit,
140     Plugin_checkstr,
141     Plugin_free,
142     Plugin_numbered_buff_FETCH,
143     Plugin_numbered_buff_STORE,
144     Plugin_numbered_buff_LENGTH,
145     Plugin_named_buff,
146     Plugin_named_buff_iter,
147     Plugin_package
148 #if defined(USE_ITHREADS)
149     , Plugin_dupe
150 #endif
151 #if XSH_HAS_PERL(5, 17, 0)
152     , 0
153 #endif
154 };
155
156 typedef struct replug {
157     /* Pointer back to the containing regexp struct so that accessors
158      * can modify nparens, gofs etc. */
159     struct regexp * rx;
160
161     /* A copy of the pattern given to comp, for ->pattern */
162     SV * pattern;
163
164     /* A copy of the string being matched against, for ->str */
165     SV * str;
166
167     /* The ->stash */
168     SV * stash;
169
170     /* Callbacks */
171     SV * cb_exec;
172     SV * cb_free;
173
174     /* ->num_captures */
175     SV * cb_num_capture_buff_FETCH;
176     SV * cb_num_capture_buff_STORE;
177     SV * cb_num_capture_buff_LENGTH;
178 } *re__engine__Plugin;
179
180 #if XSH_HAS_PERL(5, 11, 0)
181 # define rxREGEXP(RX)  (SvANY(RX))
182 # define newREGEXP(RX) ((RX) = ((REGEXP*) newSV_type(SVt_REGEXP)))
183 #else
184 # define rxREGEXP(RX)  (RX)
185 # define newREGEXP(RX) (Newxz((RX), 1, struct regexp))
186 #endif
187
188 REGEXP *
189 #if XSH_HAS_PERL(5, 11, 0)
190 Plugin_comp(pTHX_ SV * const pattern, U32 flags)
191 #else
192 Plugin_comp(pTHX_ const SV * const pattern, const U32 flags)
193 #endif
194 {
195     dSP;
196     struct regexp * rx;
197     REGEXP *RX;
198
199     re__engine__Plugin re;
200     const xsh_hints_user_t *h;
201
202     STRLEN plen;
203     char *pbuf;
204
205     SV *obj;
206
207     h = rep_hint();
208     if (!h) /* This looks like a pragma leak. Apply the default behaviour */
209         return re_compile(pattern, flags);
210
211     /* exp/xend version of the pattern & length */
212     pbuf = SvPV((SV*)pattern, plen);
213
214     /* Our blessed object */
215     obj = newSV(0);
216     SvREFCNT_inc_simple_void_NN(obj);
217     Newxz(re, 1, struct replug);
218     sv_setref_pv(obj, "re::engine::Plugin", (void*)re);
219
220     newREGEXP(RX);
221     rx = rxREGEXP(RX);
222
223     re->rx = rx;                   /* Make the rx accessible from self->rx */
224     rx->intflags = flags;          /* Flags for internal use */
225     rx->extflags = flags;          /* Flags for perl to use */
226     rx->engine = RE_ENGINE_PLUGIN; /* Compile to use this engine */
227
228 #if !XSH_HAS_PERL(5, 11, 0)
229     rx->refcnt = 1;                /* Refcount so we won't be destroyed */
230
231     /* Precompiled pattern for pp_regcomp to use */
232     rx->prelen = plen;
233     rx->precomp = savepvn(pbuf, rx->prelen);
234
235     /* Set up qr// stringification to be equivalent to the supplied
236      * pattern, this should be done via overload eventually.
237      */
238     rx->wraplen = rx->prelen;
239     Newx(rx->wrapped, rx->wraplen, char);
240     Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
241 #endif
242
243     /* Store our private object */
244     rx->pprivate = obj;
245
246     /* Store the pattern for ->pattern */
247     re->pattern = (SV*)pattern;
248     SvREFCNT_inc_simple_void(re->pattern);
249
250     /* If there's an exec callback, store it into the private object so
251      * that it will be the one to be called, even if the engine changes
252      * in between */
253     if (h->exec) {
254         re->cb_exec = h->exec;
255         SvREFCNT_inc_simple_void_NN(h->exec);
256     }
257
258     re->cb_num_capture_buff_FETCH  = NULL;
259     re->cb_num_capture_buff_STORE  = NULL;
260     re->cb_num_capture_buff_LENGTH = NULL;
261
262     /* Call our callback function if one was defined, if not we've
263      * already set up all the stuff we're going to to need for
264      * subsequent exec and other calls */
265     if (h->comp) {
266         ENTER;
267         SAVETMPS;
268
269         PUSHMARK(SP);
270         XPUSHs(obj);
271         PUTBACK;
272
273         call_sv(h->comp, G_DISCARD);
274
275         FREETMPS;
276         LEAVE;
277     }
278
279     /* If any of the comp-time accessors were called we'll have to
280      * update the regexp struct with the new info.
281      */
282
283     Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair);
284
285     return RX;
286 }
287
288 I32
289 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
290             char *strbeg, REP_ENG_EXEC_MINEND_TYPE minend,
291             SV *sv, void *data, U32 flags)
292 {
293     dSP;
294     I32 matched;
295     struct regexp *rx = rxREGEXP(RX);
296     GET_SELF_FROM_PPRIVATE(rx->pprivate);
297
298     if (self->cb_exec) {
299         SV *ret;
300
301         /* Store the current str for ->str */
302         SvREFCNT_dec(self->str);
303         self->str = sv;
304         SvREFCNT_inc_simple_void(self->str);
305
306         ENTER;
307         SAVETMPS;
308
309         PUSHMARK(SP);
310         XPUSHs(rx->pprivate);
311         XPUSHs(sv);
312         PUTBACK;
313
314         call_sv(self->cb_exec, G_SCALAR);
315
316         SPAGAIN;
317
318         ret = POPs;
319         if (SvTRUE(ret))
320             matched = 1;
321         else
322             matched = 0;
323
324         PUTBACK;
325         FREETMPS;
326         LEAVE;
327     } else {
328         matched = 0;
329     }
330
331     return matched;
332 }
333
334 char *
335 #if XSH_HAS_PERL(5, 19, 1)
336 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, const char * const strbeg,
337               char *strpos, char *strend, U32 flags, re_scream_pos_data *data)
338 #else
339 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
340               char *strend, U32 flags, re_scream_pos_data *data)
341 #endif
342 {
343     PERL_UNUSED_ARG(RX);
344     PERL_UNUSED_ARG(sv);
345 #if XSH_HAS_PERL(5, 19, 1)
346     PERL_UNUSED_ARG(strbeg);
347 #endif
348     PERL_UNUSED_ARG(strpos);
349     PERL_UNUSED_ARG(strend);
350     PERL_UNUSED_ARG(flags);
351     PERL_UNUSED_ARG(data);
352     return NULL;
353 }
354
355 SV *
356 Plugin_checkstr(pTHX_ REGEXP * const RX)
357 {
358     PERL_UNUSED_ARG(RX);
359     return NULL;
360 }
361
362 void
363 Plugin_free(pTHX_ REGEXP * const RX)
364 {
365     struct regexp *rx;
366     re__engine__Plugin self;
367
368     if (PL_dirty)
369         return;
370
371     rx = rxREGEXP(RX);
372     SELF_FROM_PPRIVATE(self, rx->pprivate);
373
374     SvREFCNT_dec(self->pattern);
375     SvREFCNT_dec(self->str);
376
377     SvREFCNT_dec(self->cb_exec);
378
379     SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
380     SvREFCNT_dec(self->cb_num_capture_buff_STORE);
381     SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
382
383     self->rx = NULL;
384     Safefree(self);
385
386 /*
387     dSP;
388     SV * callback;
389
390     callback = self->cb_free;
391
392     if (callback) {
393         ENTER;
394         SAVETMPS;
395
396         PUSHMARK(SP);
397         XPUSHs(rx->pprivate);
398         PUTBACK;
399
400         call_sv(callback, G_DISCARD);
401
402         PUTBACK;
403         FREETMPS;
404         LEAVE;
405     }
406     return;
407 */
408 }
409
410 void *
411 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
412 {
413     struct regexp *rx = rxREGEXP(RX);
414     Perl_croak(aTHX_ "dupe not supported yet");
415     return rx->pprivate;
416 }
417
418
419 void
420 Plugin_numbered_buff_FETCH(pTHX_ REGEXP * const RX, const I32 paren,
421                            SV * const sv)
422 {
423     dSP;
424     I32 items;
425     SV * callback;
426     struct regexp *rx = rxREGEXP(RX);
427     GET_SELF_FROM_PPRIVATE(rx->pprivate);
428
429     callback = self->cb_num_capture_buff_FETCH;
430
431     if (callback) {
432         ENTER;
433         SAVETMPS;
434
435         PUSHMARK(SP);
436         XPUSHs(rx->pprivate);
437         XPUSHs(sv_2mortal(newSViv(paren)));
438         PUTBACK;
439
440         items = call_sv(callback, G_SCALAR);
441
442         if (items == 1) {
443             SV *ret;
444
445             SPAGAIN;
446             ret = POPs;
447             sv_setsv(sv, ret);
448         } else {
449             sv_setsv(sv, &PL_sv_undef);
450         }
451
452         PUTBACK;
453         FREETMPS;
454         LEAVE;
455     } else {
456         sv_setsv(sv, &PL_sv_undef);
457     }
458 }
459
460 void
461 Plugin_numbered_buff_STORE(pTHX_ REGEXP * const RX, const I32 paren,
462                            SV const * const value)
463 {
464     dSP;
465     SV * callback;
466     struct regexp *rx = rxREGEXP(RX);
467     GET_SELF_FROM_PPRIVATE(rx->pprivate);
468
469     callback = self->cb_num_capture_buff_STORE;
470
471     if (callback) {
472         ENTER;
473         SAVETMPS;
474
475         PUSHMARK(SP);
476         XPUSHs(rx->pprivate);
477         XPUSHs(sv_2mortal(newSViv(paren)));
478         XPUSHs((SV *) value);
479         PUTBACK;
480
481         call_sv(callback, G_DISCARD);
482
483         PUTBACK;
484         FREETMPS;
485         LEAVE;
486     }
487 }
488
489 I32
490 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
491                               const I32 paren)
492 {
493     dSP;
494     SV * callback;
495     struct regexp *rx = rxREGEXP(RX);
496     GET_SELF_FROM_PPRIVATE(rx->pprivate);
497
498     callback = self->cb_num_capture_buff_LENGTH;
499
500     if (callback) {
501         IV ret;
502
503         ENTER;
504         SAVETMPS;
505
506         PUSHMARK(SP);
507         XPUSHs(rx->pprivate);
508         XPUSHs(sv_2mortal(newSViv(paren)));
509         PUTBACK;
510
511         call_sv(callback, G_SCALAR);
512
513         SPAGAIN;
514
515         ret = POPi;
516
517         PUTBACK;
518         FREETMPS;
519         LEAVE;
520
521         return (I32)ret;
522     } else {
523         /* TODO: call FETCH and get the length on that value */
524         return 0;
525     }
526 }
527
528
529 SV*
530 Plugin_named_buff (pTHX_ REGEXP * const RX, SV * const key, SV * const value,
531                    const U32 flags)
532 {
533     return NULL;
534 }
535
536 SV*
537 Plugin_named_buff_iter (pTHX_ REGEXP * const RX, const SV * const lastkey,
538                         const U32 flags)
539 {
540     return NULL;
541 }
542
543 SV*
544 Plugin_package(pTHX_ REGEXP * const RX)
545 {
546     PERL_UNUSED_ARG(RX);
547     return newSVpvs("re::engine::Plugin");
548 }
549
550 static void xsh_user_global_setup(pTHX) {
551      HV *stash;
552
553      stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
554      newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(XSH_THREADSAFE));
555      newCONSTSUB(stash, "REP_FORKSAFE",   newSVuv(XSH_FORKSAFE));
556
557     return;
558 }
559
560 /* --- XS ------------------------------------------------------------------ */
561
562 MODULE = re::engine::Plugin       PACKAGE = re::engine::Plugin
563
564 PROTOTYPES: DISABLE
565
566 BOOT:
567 {
568     xsh_setup();
569 }
570
571 #if XSH_THREADSAFE
572
573 void
574 CLONE(...)
575 PPCODE:
576     xsh_clone();
577     XSRETURN(0);
578
579 #endif /* XSH_THREADSAFE */
580
581 void
582 pattern(re::engine::Plugin self, ...)
583 PPCODE:
584     XPUSHs(self->pattern);
585
586 void
587 str(re::engine::Plugin self, ...)
588 PPCODE:
589     XPUSHs(self->str);
590
591 void
592 mod(re::engine::Plugin self)
593 PREINIT:
594     U32 flags;
595     char mods[5 + 1];
596     int n = 0, i;
597 PPCODE:
598     flags = self->rx->intflags;
599     if (flags & PMf_FOLD)         /* /i */
600         mods[n++] = 'i';
601     if (flags & PMf_MULTILINE)    /* /m */
602         mods[n++] = 'm';
603     if (flags & PMf_SINGLELINE)   /* /s */
604         mods[n++] = 's';
605     if (flags & PMf_EXTENDED)     /* /x */
606         mods[n++] = 'x';
607     if (flags & RXf_PMf_KEEPCOPY) /* /p */
608         mods[n++] = 'p';
609     mods[n] = '\0';
610     EXTEND(SP, 2 * n);
611     for (i = 0; i < n; ++i) {
612         mPUSHp(mods + i, 1);
613         PUSHs(&PL_sv_yes);
614     }
615     XSRETURN(2 * n);
616
617 void
618 stash(re::engine::Plugin self, ...)
619 PPCODE:
620     if (items > 1) {
621         SvREFCNT_dec(self->stash);
622         self->stash = ST(1);
623         SvREFCNT_inc_simple_void(self->stash);
624         XSRETURN_EMPTY;
625     } else {
626         XPUSHs(self->stash);
627     }
628
629 void
630 minlen(re::engine::Plugin self, ...)
631 PPCODE:
632     if (items > 1) {
633         self->rx->minlen = (I32)SvIV(ST(1));
634         XSRETURN_EMPTY;
635     } else {
636         if (self->rx->minlen) {
637             XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
638         } else {
639             XPUSHs(sv_2mortal(&PL_sv_undef));
640         }
641     }
642
643 void
644 gofs(re::engine::Plugin self, ...)
645 PPCODE:
646     if (items > 1) {
647         self->rx->gofs = (U32)SvIV(ST(1));
648         XSRETURN_EMPTY;
649     } else {
650         if (self->rx->gofs) {
651             XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
652         } else {
653             XPUSHs(sv_2mortal(&PL_sv_undef));
654         }
655     }
656
657 void
658 nparens(re::engine::Plugin self, ...)
659 PPCODE:
660     if (items > 1) {
661         self->rx->nparens = (U32)SvIV(ST(1));
662         XSRETURN_EMPTY;
663     } else {
664         if (self->rx->nparens) {
665             XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
666         } else {
667             XPUSHs(sv_2mortal(&PL_sv_undef));
668         }
669     }
670
671 void
672 _exec(re::engine::Plugin self, ...)
673 PPCODE:
674     if (items > 1) {
675         SvREFCNT_dec(self->cb_exec);
676         self->cb_exec = ST(1);
677         SvREFCNT_inc_simple_void(self->cb_exec);
678     }
679
680 void
681 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
682 PPCODE:
683     if (items > 1) {
684         SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
685         self->cb_num_capture_buff_FETCH = ST(1);
686         SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH);
687     }
688
689 void
690 _num_capture_buff_STORE(re::engine::Plugin self, ...)
691 PPCODE:
692     if (items > 1) {
693         SvREFCNT_dec(self->cb_num_capture_buff_STORE);
694         self->cb_num_capture_buff_STORE = ST(1);
695         SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE);
696     }
697
698 void
699 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
700 PPCODE:
701     if (items > 1) {
702         SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
703         self->cb_num_capture_buff_LENGTH = ST(1);
704         SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH);
705     }
706
707 SV *
708 _tag(SV *comp, SV *exec)
709 PREINIT:
710     xsh_hints_user_t arg;
711 CODE:
712     arg.comp = comp;
713     arg.exec = exec;
714     RETVAL = xsh_hints_tag(&arg);
715 OUTPUT:
716     RETVAL
717
718 void
719 ENGINE()
720 PPCODE:
721     XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));