1 #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
5 #define PERL_NO_GET_CONTEXT
14 extern regexp* my_re_compile (pTHX_ char* exp, char* xend, PMOP* pm);
15 extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
16 char* strbeg, I32 minend, SV* screamer,
17 void* data, U32 flags);
19 extern char* my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos,
20 char *strend, U32 flags,
21 struct re_scream_pos_data_s *data);
22 extern SV* my_re_intuit_string (pTHX_ regexp *prog);
24 extern void my_regfree (pTHX_ struct regexp* r);
25 #if defined(USE_ITHREADS)
26 extern void* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
29 EXTERN_C const struct regexp_engine my_reg_engine;
33 const struct regexp_engine my_reg_engine = {
39 #if defined(USE_ITHREADS)
45 get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
51 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
52 SvTYPE(sv) == SVt_PVMG &&
53 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
56 return (regexp *)mg->mg_obj;
60 return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
63 MODULE = re PACKAGE = re
68 PL_colorset = 0; /* Allow reinspection of ENV. */
69 /* PL_debug |= DEBUG_r_FLAG; */
70 XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
79 if ( get_re_arg( aTHX_ sv, 0, NULL ) )
98 Checks if a reference is a regex or not. If the parameter is
99 not a ref, or is not the result of a qr// then returns false
100 in scalar context and an empty list in list context.
101 Otherwise in list context it returns the pattern and the
102 modifiers, in scalar context it returns the pattern just as it
103 would if the qr// was stringified normally, regardless as
104 to the class of the variable and any strigification overloads
108 if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
110 /* Housten, we have a regex! */
116 if ( GIMME_V == G_ARRAY ) {
118 we are in list context so stringify
119 the modifiers that apply. We ignore "negative
120 modifiers" in this scenario.
125 U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
127 while((ch = *fptr++)) {
128 if(match_flags & 1) {
129 reflags[left++] = ch;
134 pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
135 if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
137 /* return the pattern and the modifiers */
139 XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
142 /* Scalar, so use the string that Perl would return */
144 CALLREG_STRINGIFY(mg,0,0);
146 /* return the pattern in (?msix:..) format */
147 pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len));
148 if (re->extflags & RXf_UTF8)
154 /* It ain't a regexp folks */
155 if ( GIMME_V == G_ARRAY ) {
156 /* return the empty list */
159 /* Because of the (?:..) wrapping involved in a
160 stringified pattern it is impossible to get a
161 result for a real regexp that would evaluate to
162 false. Therefore we can return PL_sv_no to signify
163 that the object is not a regex, this means that one
166 if (regex($might_be_a_regex) eq '(?:foo)') { }
168 and not worry about undefined values.
185 if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
189 if (re->anchored_substr) {
190 an = newSVsv(re->anchored_substr);
191 } else if (re->anchored_utf8) {
192 an = newSVsv(re->anchored_utf8);
194 if (re->float_substr) {
195 fl = newSVsv(re->float_substr);
196 } else if (re->float_utf8) {
197 fl = newSVsv(re->float_utf8);
207 regname(sv, qr = NULL, all = NULL)
217 re = get_re_arg( aTHX_ qr, 1, NULL);
218 if (SvPOK(sv) && re && re->paren_names) {
219 bufs = Perl_reg_named_buff_get(aTHX_ sv, re ,all && SvTRUE(all));
221 if (all && SvTRUE(all))
224 XPUSHs(SvREFCNT_inc(bufs));
232 regnames(sv = NULL, all = NULL)
241 re = get_re_arg( aTHX_ sv, 1, NULL );
242 if (re && re->paren_names) {
243 HV *hv= re->paren_names;
244 (void)hv_iterinit(hv);
246 HE *temphe = hv_iternext_flags(hv,0);
250 SV* sv_dat = HeVAL(temphe);
251 I32 *nums = (I32*)SvPVX(sv_dat);
252 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
253 if ((I32)(re->lastcloseparen) >= nums[i] &&
254 re->startp[nums[i]] != -1 &&
255 re->endp[nums[i]] != -1)
261 if (parno || (all && SvTRUE(all))) {
263 char *pv = HePV(temphe, len);
264 if ( GIMME_V == G_ARRAY )
265 XPUSHs(newSVpvn(pv,len));
273 if ( GIMME_V == G_ARRAY )
280 regnames_iterinit(sv = NULL)
287 re = get_re_arg( aTHX_ sv, 1, NULL );
288 if (re && re->paren_names) {
289 (void)hv_iterinit(re->paren_names);
290 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
297 regnames_iternext(sv = NULL, all = NULL)
305 re = get_re_arg( aTHX_ sv, 1, NULL );
306 if (re && re->paren_names) {
307 HV *hv= re->paren_names;
309 HE *temphe = hv_iternext_flags(hv,0);
313 SV* sv_dat = HeVAL(temphe);
314 I32 *nums = (I32*)SvPVX(sv_dat);
315 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
316 if ((I32)(re->lastcloseparen) >= nums[i] &&
317 re->startp[nums[i]] != -1 &&
318 re->endp[nums[i]] != -1)
324 if (parno || (all && SvTRUE(all))) {
326 char *pv = HePV(temphe, len);
327 XPUSHs(newSVpvn(pv,len));
339 regnames_count(sv = NULL)
346 re = get_re_arg( aTHX_ sv, 1, NULL );
347 if (re && re->paren_names) {
348 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));