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
17 START_EXTERN_C
18
19 extern REGEXP* my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags);
20 extern 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
24 extern 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
28 extern 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
37 extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog);
38
39 extern void my_regfree (pTHX_ REGEXP * const r);
40
41 extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
42 SV * const usesv);
43 extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
44 SV const * const value);
45 extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
46 const SV * const sv, const I32 paren);
47
48 extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
49 const U32);
50 extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
51 const SV * const lastkey, const U32 flags);
52
53 extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
54 #if defined(USE_ITHREADS)
55 extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
56 #endif
57 extern 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
62 EXTERN_C const struct regexp_engine my_reg_engine;
63 EXTERN_C const struct regexp_engine wild_reg_engine;
64
65 END_EXTERN_C
66
67 const 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' */
89 const 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
109 MODULE = re PACKAGE = re
110
111 void
112 install()
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
118 void
regmust(sv)119 regmust(sv)
120 SV * sv
121 PROTOTYPE: $
122 PREINIT:
123 REGEXP *re;
124 PPCODE:
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
152 SV *
153 optimization(sv)
154 SV * sv
155 PROTOTYPE: $
156 PREINIT:
157 REGEXP *re;
158 regexp *r;
159 struct reg_substr_datum * data;
160 HV *hv;
161 CODE:
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 }
237 OUTPUT:
238 RETVAL
239
240 #
241 # ex: set ts=8 sts=4 sw=4 et:
242 #
243