]> git.vpit.fr Git - perl/modules/re-engine-Plugin.git/blob - Plugin.xs
Explicitely state how many values are returned from our XSUBs
[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  rx->wraplen  = rx->prelen;
238  Newx(rx->wrapped, rx->wraplen, char);
239  Copy(rx->precomp, rx->wrapped, rx->wraplen, char);
240 #endif
241
242  /* Store our private object */
243  rx->pprivate = obj;
244
245  /* Store the pattern for ->pattern */
246  re->pattern  = (SV *) pattern;
247  SvREFCNT_inc_simple_void(re->pattern);
248
249  /* If there's an exec callback, store it into the private object so that it
250   * will be the one to be called, even if the engine changes in between */
251  if (h->exec) {
252   re->cb_exec = h->exec;
253   SvREFCNT_inc_simple_void_NN(h->exec);
254  }
255
256  re->cb_num_capture_buff_FETCH  = NULL;
257  re->cb_num_capture_buff_STORE  = NULL;
258  re->cb_num_capture_buff_LENGTH = NULL;
259
260  /* Call our callback function if one was defined, if not we've already set up
261   * all the stuff we're going to to need for subsequent exec and other calls */
262  if (h->comp) {
263   ENTER;
264   SAVETMPS;
265
266   PUSHMARK(SP);
267   XPUSHs(obj);
268   PUTBACK;
269
270   call_sv(h->comp, G_DISCARD);
271
272   FREETMPS;
273   LEAVE;
274  }
275
276  /* If any of the comp-time accessors were called we'll have to
277   * update the regexp struct with the new info */
278  Newxz(rx->offs, rx->nparens + 1, regexp_paren_pair);
279
280  return RX;
281 }
282
283 I32
284 Plugin_exec(pTHX_ REGEXP * const RX, char *stringarg, char *strend,
285             char *strbeg, REP_ENG_EXEC_MINEND_TYPE minend,
286             SV *sv, void *data, U32 flags)
287 {
288  dSP;
289  I32 matched;
290  struct regexp *rx = rxREGEXP(RX);
291
292  GET_SELF_FROM_PPRIVATE(rx->pprivate);
293
294  if (self->cb_exec) {
295   SV *ret;
296
297   /* Store the current str for ->str */
298   SvREFCNT_dec(self->str);
299   self->str = sv;
300   SvREFCNT_inc_simple_void(self->str);
301
302   ENTER;
303   SAVETMPS;
304
305   PUSHMARK(SP);
306   XPUSHs(rx->pprivate);
307   XPUSHs(sv);
308   PUTBACK;
309
310   call_sv(self->cb_exec, G_SCALAR);
311
312   SPAGAIN;
313
314   ret = POPs;
315   if (SvTRUE(ret))
316    matched = 1;
317   else
318    matched = 0;
319
320   PUTBACK;
321   FREETMPS;
322   LEAVE;
323  } else {
324   matched = 0;
325  }
326
327  return matched;
328 }
329
330 char *
331 #if XSH_HAS_PERL(5, 19, 1)
332 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, const char * const strbeg,
333               char *strpos, char *strend, U32 flags, re_scream_pos_data *data)
334 #else
335 Plugin_intuit(pTHX_ REGEXP * const RX, SV *sv, char *strpos,
336               char *strend, U32 flags, re_scream_pos_data *data)
337 #endif
338 {
339  PERL_UNUSED_ARG(RX);
340  PERL_UNUSED_ARG(sv);
341 #if XSH_HAS_PERL(5, 19, 1)
342  PERL_UNUSED_ARG(strbeg);
343 #endif
344  PERL_UNUSED_ARG(strpos);
345  PERL_UNUSED_ARG(strend);
346  PERL_UNUSED_ARG(flags);
347  PERL_UNUSED_ARG(data);
348
349  return NULL;
350 }
351
352 SV *
353 Plugin_checkstr(pTHX_ REGEXP * const RX)
354 {
355  PERL_UNUSED_ARG(RX);
356
357  return NULL;
358 }
359
360 void
361 Plugin_free(pTHX_ REGEXP * const RX)
362 {
363  struct regexp *rx;
364  re__engine__Plugin self;
365
366  if (PL_dirty)
367   return;
368
369  rx = rxREGEXP(RX);
370  SELF_FROM_PPRIVATE(self, rx->pprivate);
371
372  SvREFCNT_dec(self->pattern);
373  SvREFCNT_dec(self->str);
374
375  SvREFCNT_dec(self->cb_exec);
376
377  SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
378  SvREFCNT_dec(self->cb_num_capture_buff_STORE);
379  SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
380
381  self->rx = NULL;
382  Safefree(self);
383
384 /*
385  dSP;
386  SV *callback;
387
388  callback = self->cb_free;
389
390  if (callback) {
391   ENTER;
392   SAVETMPS;
393
394   PUSHMARK(SP);
395   XPUSHs(rx->pprivate);
396   PUTBACK;
397
398   call_sv(callback, G_DISCARD);
399
400   PUTBACK;
401   FREETMPS;
402   LEAVE;
403  }
404  return;
405 */
406 }
407
408 void *
409 Plugin_dupe(pTHX_ REGEXP * const RX, CLONE_PARAMS *param)
410 {
411  struct regexp *rx = rxREGEXP(RX);
412
413  Perl_croak(aTHX_ "dupe not supported yet");
414
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
428  GET_SELF_FROM_PPRIVATE(rx->pprivate);
429
430  callback = self->cb_num_capture_buff_FETCH;
431
432  if (callback) {
433   ENTER;
434   SAVETMPS;
435
436   PUSHMARK(SP);
437   XPUSHs(rx->pprivate);
438   XPUSHs(sv_2mortal(newSViv(paren)));
439   PUTBACK;
440
441   items = call_sv(callback, G_SCALAR);
442
443   if (items == 1) {
444    SV *ret;
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
468  GET_SELF_FROM_PPRIVATE(rx->pprivate);
469
470  callback = self->cb_num_capture_buff_STORE;
471
472  if (callback) {
473   ENTER;
474   SAVETMPS;
475
476   PUSHMARK(SP);
477   XPUSHs(rx->pprivate);
478   XPUSHs(sv_2mortal(newSViv(paren)));
479   XPUSHs((SV *) value);
480   PUTBACK;
481
482   call_sv(callback, G_DISCARD);
483
484   PUTBACK;
485   FREETMPS;
486   LEAVE;
487  }
488 }
489
490 I32
491 Plugin_numbered_buff_LENGTH(pTHX_ REGEXP * const RX, const SV * const sv,
492                             const I32 paren)
493 {
494  dSP;
495  SV *callback;
496  struct regexp *rx = rxREGEXP(RX);
497
498  GET_SELF_FROM_PPRIVATE(rx->pprivate);
499
500  callback = self->cb_num_capture_buff_LENGTH;
501
502  if (callback) {
503   IV ret;
504
505   ENTER;
506   SAVETMPS;
507
508   PUSHMARK(SP);
509   XPUSHs(rx->pprivate);
510   XPUSHs(sv_2mortal(newSViv(paren)));
511   PUTBACK;
512
513   call_sv(callback, G_SCALAR);
514
515   SPAGAIN;
516
517   ret = POPi;
518
519   PUTBACK;
520   FREETMPS;
521   LEAVE;
522
523   return (I32) ret;
524  } else {
525   /* TODO: call FETCH and get the length on that value */
526   return 0;
527  }
528 }
529
530 SV *
531 Plugin_named_buff(pTHX_ REGEXP * const RX, SV * const key, SV * const value,
532                   const U32 flags)
533 {
534  return NULL;
535 }
536
537 SV *
538 Plugin_named_buff_iter(pTHX_ REGEXP * const RX, const SV * const lastkey,
539                        const U32 flags)
540 {
541  return NULL;
542 }
543
544 SV *
545 Plugin_package(pTHX_ REGEXP * const RX)
546 {
547  PERL_UNUSED_ARG(RX);
548
549  return newSVpvs("re::engine::Plugin");
550 }
551
552 static void xsh_user_global_setup(pTHX) {
553  HV *stash;
554
555  stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
556  newCONSTSUB(stash, "REP_THREADSAFE", newSVuv(XSH_THREADSAFE));
557  newCONSTSUB(stash, "REP_FORKSAFE",   newSVuv(XSH_FORKSAFE));
558
559  return;
560 }
561
562 /* --- XS ------------------------------------------------------------------ */
563
564 MODULE = re::engine::Plugin       PACKAGE = re::engine::Plugin
565
566 PROTOTYPES: DISABLE
567
568 BOOT:
569 {
570  xsh_setup();
571 }
572
573 #if XSH_THREADSAFE
574
575 void
576 CLONE(...)
577 PPCODE:
578  xsh_clone();
579  XSRETURN(0);
580
581 #endif /* XSH_THREADSAFE */
582
583 void
584 pattern(re::engine::Plugin self, ...)
585 PPCODE:
586  XPUSHs(self->pattern);
587  XSRETURN(1);
588
589 void
590 str(re::engine::Plugin self, ...)
591 PPCODE:
592  XPUSHs(self->str);
593  XSRETURN(1);
594
595 void
596 mod(re::engine::Plugin self)
597 PREINIT:
598  U32 flags;
599  char mods[5 + 1];
600  int n = 0, i;
601 PPCODE:
602  flags = self->rx->intflags;
603  if (flags & PMf_FOLD)         /* /i */
604   mods[n++] = 'i';
605  if (flags & PMf_MULTILINE)    /* /m */
606   mods[n++] = 'm';
607  if (flags & PMf_SINGLELINE)   /* /s */
608   mods[n++] = 's';
609  if (flags & PMf_EXTENDED)     /* /x */
610   mods[n++] = 'x';
611  if (flags & RXf_PMf_KEEPCOPY) /* /p */
612   mods[n++] = 'p';
613  mods[n] = '\0';
614  EXTEND(SP, 2 * n);
615  for (i = 0; i < n; ++i) {
616   mPUSHp(mods + i, 1);
617   PUSHs(&PL_sv_yes);
618  }
619  XSRETURN(2 * n);
620
621 void
622 stash(re::engine::Plugin self, ...)
623 PPCODE:
624  if (items > 1) {
625   SvREFCNT_dec(self->stash);
626   self->stash = ST(1);
627   SvREFCNT_inc_simple_void(self->stash);
628   XSRETURN_EMPTY;
629  } else {
630   XPUSHs(self->stash);
631   XSRETURN(1);
632  }
633
634 void
635 minlen(re::engine::Plugin self, ...)
636 PPCODE:
637  if (items > 1) {
638   self->rx->minlen = (I32)SvIV(ST(1));
639   XSRETURN_EMPTY;
640  } else {
641   if (self->rx->minlen) {
642    XPUSHs(sv_2mortal(newSViv(self->rx->minlen)));
643   } else {
644    XPUSHs(sv_2mortal(&PL_sv_undef));
645   }
646   XSRETURN(1);
647  }
648
649 void
650 gofs(re::engine::Plugin self, ...)
651 PPCODE:
652  if (items > 1) {
653   self->rx->gofs = (U32)SvIV(ST(1));
654   XSRETURN_EMPTY;
655  } else {
656   if (self->rx->gofs) {
657    XPUSHs(sv_2mortal(newSVuv(self->rx->gofs)));
658   } else {
659    XPUSHs(sv_2mortal(&PL_sv_undef));
660   }
661   XSRETURN(1);
662  }
663
664 void
665 nparens(re::engine::Plugin self, ...)
666 PPCODE:
667  if (items > 1) {
668   self->rx->nparens = (U32)SvIV(ST(1));
669   XSRETURN_EMPTY;
670  } else {
671   if (self->rx->nparens) {
672    XPUSHs(sv_2mortal(newSVuv(self->rx->nparens)));
673   } else {
674    XPUSHs(sv_2mortal(&PL_sv_undef));
675   }
676   XSRETURN(1);
677  }
678
679 void
680 _exec(re::engine::Plugin self, ...)
681 PPCODE:
682  if (items > 1) {
683   SvREFCNT_dec(self->cb_exec);
684   self->cb_exec = ST(1);
685   SvREFCNT_inc_simple_void(self->cb_exec);
686  }
687  XSRETURN(0);
688
689 void
690 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
691 PPCODE:
692  if (items > 1) {
693   SvREFCNT_dec(self->cb_num_capture_buff_FETCH);
694   self->cb_num_capture_buff_FETCH = ST(1);
695   SvREFCNT_inc_simple_void(self->cb_num_capture_buff_FETCH);
696  }
697  XSRETURN(0);
698
699 void
700 _num_capture_buff_STORE(re::engine::Plugin self, ...)
701 PPCODE:
702  if (items > 1) {
703   SvREFCNT_dec(self->cb_num_capture_buff_STORE);
704   self->cb_num_capture_buff_STORE = ST(1);
705   SvREFCNT_inc_simple_void(self->cb_num_capture_buff_STORE);
706  }
707  XSRETURN(0);
708
709 void
710 _num_capture_buff_LENGTH(re::engine::Plugin self, ...)
711 PPCODE:
712  if (items > 1) {
713   SvREFCNT_dec(self->cb_num_capture_buff_LENGTH);
714   self->cb_num_capture_buff_LENGTH = ST(1);
715   SvREFCNT_inc_simple_void(self->cb_num_capture_buff_LENGTH);
716  }
717  XSRETURN(0);
718
719 SV *
720 _tag(SV *comp, SV *exec)
721 PREINIT:
722  xsh_hints_user_t arg;
723 CODE:
724  arg.comp = comp;
725  arg.exec = exec;
726  RETVAL = xsh_hints_tag(&arg);
727 OUTPUT:
728  RETVAL
729
730 void
731 ENGINE()
732 PPCODE:
733  XPUSHs(sv_2mortal(newSViv(PTR2IV(&engine_plugin))));
734  XSRETURN(1);