1 #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
5 #define PERL_NO_GET_CONTEXT
14 extern REGEXP* my_re_compile (pTHX_ const SV * const pattern, const U32 pm_flags);
15 extern I32 my_regexec (pTHX_ REGEXP * const 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 * const prog, SV *sv, char *strpos,
20 char *strend, const U32 flags,
21 struct re_scream_pos_data_s *data);
22 extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog);
24 extern void my_regfree (pTHX_ REGEXP * const r);
26 extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
28 extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
29 SV const * const value);
30 extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
31 const SV * const sv, const I32 paren);
33 extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
35 extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
36 const SV * const lastkey, const U32 flags);
38 extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
39 #if defined(USE_ITHREADS)
40 extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
43 EXTERN_C const struct regexp_engine my_reg_engine;
47 const struct regexp_engine my_reg_engine = {
53 my_reg_numbered_buff_fetch,
54 my_reg_numbered_buff_store,
55 my_reg_numbered_buff_length,
57 my_reg_named_buff_iter,
59 #if defined(USE_ITHREADS)
65 get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
71 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
72 SvTYPE(sv) == SVt_PVMG &&
73 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
76 return (REGEXP *)mg->mg_obj;
80 return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
83 MODULE = re PACKAGE = re
88 PL_colorset = 0; /* Allow reinspection of ENV. */
89 /* PL_debug |= DEBUG_r_FLAG; */
90 XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
103 Checks if a reference is a regex or not. If the parameter is
104 not a ref, or is not the result of a qr// then returns false
105 in scalar context and an empty list in list context.
106 Otherwise in list context it returns the pattern and the
107 modifiers, in scalar context it returns the pattern just as it
108 would if the qr// was stringified normally, regardless as
109 to the class of the variable and any strigification overloads
113 if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
115 /* Housten, we have a regex! */
121 if ( GIMME_V == G_ARRAY ) {
123 we are in list context so stringify
124 the modifiers that apply. We ignore "negative
125 modifiers" in this scenario.
128 char *fptr = INT_PAT_MODS;
130 U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
132 while((ch = *fptr++)) {
133 if(match_flags & 1) {
134 reflags[left++] = ch;
139 pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
140 if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
142 /* return the pattern and the modifiers */
144 XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
147 /* Scalar, so use the string that Perl would return */
148 /* return the pattern in (?msix:..) format */
149 pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
150 if (re->extflags & RXf_UTF8)
156 /* It ain't a regexp folks */
157 if ( GIMME_V == G_ARRAY ) {
158 /* return the empty list */
161 /* Because of the (?:..) wrapping involved in a
162 stringified pattern it is impossible to get a
163 result for a real regexp that would evaluate to
164 false. Therefore we can return PL_sv_no to signify
165 that the object is not a regex, this means that one
168 if (regex($might_be_a_regex) eq '(?:foo)') { }
170 and not worry about undefined values.
187 if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
191 if (re->anchored_substr) {
192 an = newSVsv(re->anchored_substr);
193 } else if (re->anchored_utf8) {
194 an = newSVsv(re->anchored_utf8);
196 if (re->float_substr) {
197 fl = newSVsv(re->float_substr);
198 } else if (re->float_utf8) {
199 fl = newSVsv(re->float_utf8);