1 #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
5 #define PERL_NO_GET_CONTEXT
14 extern regexp* my_regcomp (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);
18 extern void my_regfree (pTHX_ struct regexp* r);
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);
23 extern char* my_reg_stringify (pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval);
25 #if defined(USE_ITHREADS)
26 extern regexp* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
29 EXTERN_C const struct regexp_engine my_reg_engine = {
36 #if defined(USE_ITHREADS)
43 MODULE = re PACKAGE = re
48 PL_colorset = 0; /* Allow reinspection of ENV. */
49 /* PL_debug |= DEBUG_r_FLAG; */
50 XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
64 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
65 SvTYPE(sv) == SVt_PVMG &&
66 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
84 Checks if a reference is a regex or not. If the parameter is
85 not a ref, or is not the result of a qr// then returns false
86 in scalar context and an empty list in list context.
87 Otherwise in list context it returns the pattern and the
88 modifiers, in scalar context it returns the pattern just as it
89 would if the qr// was stringified normally, regardless as
90 to the class of the variable and any strigification overloads
97 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
98 SvTYPE(sv) == SVt_PVMG &&
99 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
102 /* Housten, we have a regex! */
104 regexp *re = (regexp *)mg->mg_obj;
109 if ( GIMME_V == G_ARRAY ) {
111 we are in list context so stringify
112 the modifiers that apply. We ignore "negative
113 modifiers" in this scenario.
118 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
120 while((ch = *fptr++)) {
122 reflags[left++] = ch;
127 pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
128 if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern);
130 /* return the pattern and the modifiers */
132 XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
135 /* Scalar, so use the string that Perl would return */
137 CALLREG_STRINGIFY(mg,0,0);
139 /* return the pattern in (?msix:..) format */
140 pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len));
141 if (re->reganch & ROPT_UTF8)
147 /* It ain't a regexp folks */
148 if ( GIMME_V == G_ARRAY ) {
149 /* return the empty list */
152 /* Because of the (?:..) wrapping involved in a
153 stringified pattern it is impossible to get a
154 result for a real regexp that would evaluate to
155 false. Therefore we can return PL_sv_no to signify
156 that the object is not a regex, this means that one
159 if (regex($might_be_a_regex) eq '(?:foo)') { }
161 and not worry about undefined values.
181 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
182 SvTYPE(sv) == SVt_PVMG &&
183 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
187 regexp *re = (regexp *)mg->mg_obj;
188 if (re->anchored_substr) {
189 an = newSVsv(re->anchored_substr);
190 } else if (re->anchored_utf8) {
191 an = newSVsv(re->anchored_utf8);
193 if (re->float_substr) {
194 fl = newSVsv(re->float_substr);
195 } else if (re->float_utf8) {
196 fl = newSVsv(re->float_utf8);