1#if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
2#  define DEBUGGING
3#  define DEBUGGING_RE_ONLY
4#endif
5
6#define PERL_NO_GET_CONTEXT
7#include "EXTERN.h"
8#include "perl.h"
9#include "XSUB.h"
10#include "re_comp.h"
11
12#undef dXSBOOTARGSXSAPIVERCHK
13/* skip API version checking due to different interp struct size but,
14   this hack is until GitHub issue #14169 is resolved */
15#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
16
17START_EXTERN_C
18
19extern REGEXP*	my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags);
20extern REGEXP*	my_re_op_compile (pTHX_ SV ** const patternp, int pat_count,
21		    OP *expr, const regexp_engine* eng, REGEXP *volatile old_re,
22		     bool *is_bare_re, U32 rx_flags, U32 pm_flags);
23
24extern I32	my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend,
25			    char* strbeg, SSize_t minend, SV* screamer,
26			    void* data, U32 flags);
27
28extern char*	my_re_intuit_start(pTHX_
29                    REGEXP * const rx,
30                    SV *sv,
31                    const char * const strbeg,
32                    char *strpos,
33                    char *strend,
34                    const U32 flags,
35                    re_scream_pos_data *data);
36
37extern SV*	my_re_intuit_string (pTHX_ REGEXP * const prog);
38
39extern void	my_regfree (pTHX_ REGEXP * const r);
40
41extern void	my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
42					   SV * const usesv);
43extern void	my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
44					   SV const * const value);
45extern I32	my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
46					    const SV * const sv, const I32 paren);
47
48extern SV*	my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
49                              const U32);
50extern SV*	my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
51                                   const SV * const lastkey, const U32 flags);
52
53extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
54#if defined(USE_ITHREADS)
55extern void*	my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
56#endif
57extern void     my_regprop(pTHX_
58    const regexp *prog, SV* sv, const regnode* o,
59    const regmatch_info *reginfo, const RExC_state_t *pRExC_state
60);
61
62EXTERN_C const struct regexp_engine my_reg_engine;
63EXTERN_C const struct regexp_engine wild_reg_engine;
64
65END_EXTERN_C
66
67const struct regexp_engine my_reg_engine = {
68        my_re_compile,
69        my_regexec,
70        my_re_intuit_start,
71        my_re_intuit_string,
72        my_regfree,
73        my_reg_numbered_buff_fetch,
74        my_reg_numbered_buff_store,
75        my_reg_numbered_buff_length,
76        my_reg_named_buff,
77        my_reg_named_buff_iter,
78        my_reg_qr_package,
79#if defined(USE_ITHREADS)
80        my_regdupe,
81#endif
82        my_re_op_compile,
83};
84
85/* For use with Unicode property wildcards, when we want to see the compilation
86 * of the wildcard subpattern, but don't want to see the matching process.  All
87 * but the compilation are the regcomp.c/regexec.c functions which aren't
88 * subject to 'use re' */
89const struct regexp_engine wild_reg_engine = {
90        my_re_compile,
91        Perl_regexec_flags,
92        Perl_re_intuit_start,
93        Perl_re_intuit_string,
94        Perl_regfree_internal,
95        Perl_reg_numbered_buff_fetch,
96        Perl_reg_numbered_buff_store,
97        Perl_reg_numbered_buff_length,
98        Perl_reg_named_buff,
99        Perl_reg_named_buff_iter,
100        Perl_reg_qr_package,
101#if defined(USE_ITHREADS)
102        Perl_regdupe_internal,
103#endif
104        my_re_op_compile,
105};
106
107#define newSVbool_(x) newSViv((x) ? 1 : 0)
108
109MODULE = re	PACKAGE = re
110
111void
112install()
113    PPCODE:
114        PL_colorset = 0;	/* Allow reinspection of ENV. */
115        /* PL_debug |= DEBUG_r_FLAG; */
116	XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
117
118void
119regmust(sv)
120    SV * sv
121PROTOTYPE: $
122PREINIT:
123    REGEXP *re;
124PPCODE:
125{
126    if ((re = SvRX(sv)) /* assign deliberate */
127       /* only for re engines we know about */
128       && (   RX_ENGINE(re) == &my_reg_engine
129           || RX_ENGINE(re) == &wild_reg_engine
130           || RX_ENGINE(re) == &PL_core_reg_engine))
131    {
132        SV *an = &PL_sv_no;
133        SV *fl = &PL_sv_no;
134        if (RX_ANCHORED_SUBSTR(re)) {
135            an = sv_2mortal(newSVsv(RX_ANCHORED_SUBSTR(re)));
136        } else if (RX_ANCHORED_UTF8(re)) {
137            an = sv_2mortal(newSVsv(RX_ANCHORED_UTF8(re)));
138        }
139        if (RX_FLOAT_SUBSTR(re)) {
140            fl = sv_2mortal(newSVsv(RX_FLOAT_SUBSTR(re)));
141        } else if (RX_FLOAT_UTF8(re)) {
142            fl = sv_2mortal(newSVsv(RX_FLOAT_UTF8(re)));
143        }
144        EXTEND(SP, 2);
145        PUSHs(an);
146        PUSHs(fl);
147        XSRETURN(2);
148    }
149    XSRETURN_UNDEF;
150}
151
152SV *
153optimization(sv)
154    SV * sv
155PROTOTYPE: $
156PREINIT:
157    REGEXP *re;
158    regexp *r;
159    struct reg_substr_datum * data;
160    HV *hv;
161CODE:
162{
163    re = SvRX(sv);
164    if (!re) {
165        XSRETURN_UNDEF;
166    }
167
168    /* only for re engines we know about */
169    if (   RX_ENGINE(re) != &my_reg_engine
170        && RX_ENGINE(re) != &wild_reg_engine
171        && RX_ENGINE(re) != &PL_core_reg_engine)
172    {
173        XSRETURN_UNDEF;
174    }
175
176    if (!PL_colorset) {
177        reginitcolors();
178    }
179
180    r = ReANY(re);
181    hv = newHV();
182
183    hv_stores(hv, "minlen", newSViv(r->minlen));
184    hv_stores(hv, "minlenret", newSViv(r->minlenret));
185    hv_stores(hv, "gofs", newSViv(r->gofs));
186
187    data = &r->substrs->data[0];
188    hv_stores(hv, "anchored", data->substr
189            ? newSVsv(data->substr) : &PL_sv_undef);
190    hv_stores(hv, "anchored utf8", data->utf8_substr
191            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
192    hv_stores(hv, "anchored min offset", newSViv(data->min_offset));
193    hv_stores(hv, "anchored max offset", newSViv(data->max_offset));
194    hv_stores(hv, "anchored end shift", newSViv(data->end_shift));
195
196    data = &r->substrs->data[1];
197    hv_stores(hv, "floating", data->substr
198            ? newSVsv(data->substr) : &PL_sv_undef);
199    hv_stores(hv, "floating utf8", data->utf8_substr
200            ? newSVsv(data->utf8_substr) : &PL_sv_undef);
201    hv_stores(hv, "floating min offset", newSViv(data->min_offset));
202    hv_stores(hv, "floating max offset", newSViv(data->max_offset));
203    hv_stores(hv, "floating end shift", newSViv(data->end_shift));
204
205    hv_stores(hv, "checking", newSVpv(
206        (!r->check_substr && !r->check_utf8)
207            ? "none"
208        : (    r->check_substr == r->substrs->data[1].substr
209            && r->check_utf8   == r->substrs->data[1].utf8_substr
210        )
211            ? "floating"
212        : "anchored"
213    , 0));
214
215    hv_stores(hv, "noscan", newSVbool_(r->intflags & PREGf_NOSCAN));
216    hv_stores(hv, "isall", newSVbool_(r->extflags & RXf_CHECK_ALL));
217    hv_stores(hv, "anchor SBOL", newSVbool_(r->intflags & PREGf_ANCH_SBOL));
218    hv_stores(hv, "anchor MBOL", newSVbool_(r->intflags & PREGf_ANCH_MBOL));
219    hv_stores(hv, "anchor GPOS", newSVbool_(r->intflags & PREGf_ANCH_GPOS));
220    hv_stores(hv, "skip", newSVbool_(r->intflags & PREGf_SKIP));
221    hv_stores(hv, "implicit", newSVbool_(r->intflags & PREGf_IMPLICIT));
222
223    {
224        RXi_GET_DECL(r, ri);
225        if (ri->regstclass) {
226            SV* sv = newSV(0);
227            /* not Perl_regprop, we must have the DEBUGGING version */
228            my_regprop(aTHX_ r, sv, ri->regstclass, NULL, NULL);
229            hv_stores(hv, "stclass", sv);
230        } else {
231            hv_stores(hv, "stclass", &PL_sv_undef);
232        }
233    }
234
235    RETVAL = newRV_noinc((SV *)hv);
236}
237OUTPUT:
238    RETVAL
239
240#
241# ex: set ts=8 sts=4 sw=4 et:
242#
243