Commit | Line | Data |
---|---|---|
41b16711 AD |
1 | #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING) |
2 | # define DEBUGGING | |
3 | #endif | |
4 | ||
c5be433b | 5 | #define PERL_NO_GET_CONTEXT |
56953603 IZ |
6 | #include "EXTERN.h" |
7 | #include "perl.h" | |
8 | #include "XSUB.h" | |
256ddcd0 | 9 | #include "re_comp.h" |
56953603 | 10 | |
f9f4320a | 11 | |
97f88e98 JH |
12 | START_EXTERN_C |
13 | ||
cea2e8a9 GS |
14 | extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm); |
15 | extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend, | |
20ce7b12 GS |
16 | char* strbeg, I32 minend, SV* screamer, |
17 | void* data, U32 flags); | |
f8149455 | 18 | |
f722798b IZ |
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); | |
56953603 | 23 | |
f8149455 | 24 | extern void my_regfree (pTHX_ struct regexp* r); |
a3c0e9ca | 25 | #if defined(USE_ITHREADS) |
f9f4320a | 26 | extern regexp* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param); |
a3c0e9ca | 27 | #endif |
0a28d81c | 28 | |
70685ca0 JH |
29 | EXTERN_C const struct regexp_engine my_reg_engine; |
30 | ||
31 | END_EXTERN_C | |
32 | ||
33 | const struct regexp_engine my_reg_engine = { | |
f9f4320a YO |
34 | my_regcomp, |
35 | my_regexec, | |
36 | my_re_intuit_start, | |
37 | my_re_intuit_string, | |
38 | my_regfree, | |
a3c0e9ca | 39 | #if defined(USE_ITHREADS) |
f9f4320a | 40 | my_regdupe |
a3c0e9ca | 41 | #endif |
0a28d81c NC |
42 | }; |
43 | ||
56953603 IZ |
44 | MODULE = re PACKAGE = re |
45 | ||
46 | void | |
f9f4320a YO |
47 | install() |
48 | PPCODE: | |
49 | PL_colorset = 0; /* Allow reinspection of ENV. */ | |
50 | /* PL_debug |= DEBUG_r_FLAG; */ | |
51 | XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine)))); | |
52 | ||
de8c5301 YO |
53 | |
54 | void | |
55 | is_regexp(sv) | |
56 | SV * sv | |
57 | PROTOTYPE: $ | |
58 | PREINIT: | |
59 | MAGIC *mg; | |
60 | PPCODE: | |
61 | { | |
62 | if (SvMAGICAL(sv)) | |
63 | mg_get(sv); | |
64 | if (SvROK(sv) && | |
65 | (sv = (SV*)SvRV(sv)) && /* assign deliberate */ | |
66 | SvTYPE(sv) == SVt_PVMG && | |
67 | (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ | |
68 | { | |
69 | XSRETURN_YES; | |
70 | } else { | |
71 | XSRETURN_NO; | |
72 | } | |
73 | /* NOTREACHED */ | |
74 | } | |
75 | ||
76 | void | |
77 | regexp_pattern(sv) | |
78 | SV * sv | |
79 | PROTOTYPE: $ | |
80 | PREINIT: | |
81 | MAGIC *mg; | |
82 | PPCODE: | |
83 | { | |
84 | /* | |
85 | Checks if a reference is a regex or not. If the parameter is | |
86 | not a ref, or is not the result of a qr// then returns false | |
87 | in scalar context and an empty list in list context. | |
88 | Otherwise in list context it returns the pattern and the | |
89 | modifiers, in scalar context it returns the pattern just as it | |
90 | would if the qr// was stringified normally, regardless as | |
91 | to the class of the variable and any strigification overloads | |
92 | on the object. | |
93 | */ | |
94 | ||
95 | if (SvMAGICAL(sv)) | |
96 | mg_get(sv); | |
97 | if (SvROK(sv) && | |
98 | (sv = (SV*)SvRV(sv)) && /* assign deliberate */ | |
99 | SvTYPE(sv) == SVt_PVMG && | |
100 | (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ | |
101 | { | |
102 | ||
103 | /* Housten, we have a regex! */ | |
104 | SV *pattern; | |
105 | regexp *re = (regexp *)mg->mg_obj; | |
106 | STRLEN patlen = 0; | |
107 | STRLEN left = 0; | |
108 | char reflags[6]; | |
109 | ||
110 | if ( GIMME_V == G_ARRAY ) { | |
111 | /* | |
112 | we are in list context so stringify | |
113 | the modifiers that apply. We ignore "negative | |
114 | modifiers" in this scenario. | |
115 | */ | |
116 | ||
117 | char *fptr = "msix"; | |
118 | char ch; | |
bbe252da | 119 | U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12); |
de8c5301 YO |
120 | |
121 | while((ch = *fptr++)) { | |
bbe252da | 122 | if(match_flags & 1) { |
de8c5301 YO |
123 | reflags[left++] = ch; |
124 | } | |
bbe252da | 125 | match_flags >>= 1; |
de8c5301 YO |
126 | } |
127 | ||
128 | pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen)); | |
bbe252da | 129 | if (re->extflags & RXf_UTF8) SvUTF8_on(pattern); |
de8c5301 YO |
130 | |
131 | /* return the pattern and the modifiers */ | |
132 | XPUSHs(pattern); | |
133 | XPUSHs(sv_2mortal(newSVpvn(reflags,left))); | |
134 | XSRETURN(2); | |
135 | } else { | |
136 | /* Scalar, so use the string that Perl would return */ | |
137 | if (!mg->mg_ptr) | |
138 | CALLREG_STRINGIFY(mg,0,0); | |
139 | ||
140 | /* return the pattern in (?msix:..) format */ | |
141 | pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len)); | |
bbe252da | 142 | if (re->extflags & RXf_UTF8) |
de8c5301 YO |
143 | SvUTF8_on(pattern); |
144 | XPUSHs(pattern); | |
145 | XSRETURN(1); | |
146 | } | |
147 | } else { | |
148 | /* It ain't a regexp folks */ | |
149 | if ( GIMME_V == G_ARRAY ) { | |
150 | /* return the empty list */ | |
151 | XSRETURN_UNDEF; | |
152 | } else { | |
153 | /* Because of the (?:..) wrapping involved in a | |
154 | stringified pattern it is impossible to get a | |
155 | result for a real regexp that would evaluate to | |
156 | false. Therefore we can return PL_sv_no to signify | |
157 | that the object is not a regex, this means that one | |
158 | can say | |
159 | ||
160 | if (regex($might_be_a_regex) eq '(?:foo)') { } | |
161 | ||
162 | and not worry about undefined values. | |
163 | */ | |
164 | XSRETURN_NO; | |
165 | } | |
166 | } | |
167 | /* NOT-REACHED */ | |
256ddcd0 YO |
168 | } |
169 | ||
170 | ||
171 | void | |
172 | regmust(sv) | |
173 | SV * sv | |
174 | PROTOTYPE: $ | |
175 | PREINIT: | |
176 | MAGIC *mg; | |
177 | PPCODE: | |
178 | { | |
179 | if (SvMAGICAL(sv)) | |
180 | mg_get(sv); | |
181 | if (SvROK(sv) && | |
182 | (sv = (SV*)SvRV(sv)) && /* assign deliberate */ | |
183 | SvTYPE(sv) == SVt_PVMG && | |
184 | (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ | |
185 | { | |
186 | SV *an = &PL_sv_no; | |
187 | SV *fl = &PL_sv_no; | |
188 | regexp *re = (regexp *)mg->mg_obj; | |
189 | if (re->anchored_substr) { | |
190 | an = newSVsv(re->anchored_substr); | |
191 | } else if (re->anchored_utf8) { | |
192 | an = newSVsv(re->anchored_utf8); | |
193 | } | |
194 | if (re->float_substr) { | |
195 | fl = newSVsv(re->float_substr); | |
196 | } else if (re->float_utf8) { | |
197 | fl = newSVsv(re->float_utf8); | |
198 | } | |
199 | XPUSHs(an); | |
200 | XPUSHs(fl); | |
201 | XSRETURN(2); | |
202 | } | |
203 | XSRETURN_UNDEF; | |
204 | } |