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