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