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 | |
973f7e2e |
14 | extern REGEXP* my_re_compile (pTHX_ const SV * const pattern, const U32 pm_flags); |
49d7dfbc |
15 | extern I32 my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend, |
20ce7b12 |
16 | char* strbeg, I32 minend, SV* screamer, |
17 | void* data, U32 flags); |
f8149455 |
18 | |
49d7dfbc |
19 | extern char* my_re_intuit_start (pTHX_ REGEXP * const prog, SV *sv, char *strpos, |
973f7e2e |
20 | char *strend, const U32 flags, |
f722798b |
21 | struct re_scream_pos_data_s *data); |
49d7dfbc |
22 | extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog); |
23 | |
24 | extern void my_regfree (pTHX_ REGEXP * const r); |
2fdbfb4d |
25 | |
d932daed |
26 | extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, |
27 | SV * const usesv); |
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); |
32 | |
192b9cd1 |
33 | extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const, |
34 | const U32); |
35 | extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx, |
36 | const SV * const lastkey, const U32 flags); |
2fdbfb4d |
37 | |
49d7dfbc |
38 | extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx); |
a3c0e9ca |
39 | #if defined(USE_ITHREADS) |
49d7dfbc |
40 | extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param); |
a3c0e9ca |
41 | #endif |
0a28d81c |
42 | |
70685ca0 |
43 | EXTERN_C const struct regexp_engine my_reg_engine; |
44 | |
45 | END_EXTERN_C |
46 | |
47 | const struct regexp_engine my_reg_engine = { |
6d5c990f |
48 | my_re_compile, |
f9f4320a |
49 | my_regexec, |
50 | my_re_intuit_start, |
51 | my_re_intuit_string, |
52 | my_regfree, |
2fdbfb4d |
53 | my_reg_numbered_buff_fetch, |
54 | my_reg_numbered_buff_store, |
55 | my_reg_numbered_buff_length, |
192b9cd1 |
56 | my_reg_named_buff, |
57 | my_reg_named_buff_iter, |
49d7dfbc |
58 | my_reg_qr_package, |
a3c0e9ca |
59 | #if defined(USE_ITHREADS) |
f9f4320a |
60 | my_regdupe |
a3c0e9ca |
61 | #endif |
0a28d81c |
62 | }; |
63 | |
49d7dfbc |
64 | REGEXP * |
44a2ac75 |
65 | get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) { |
66 | MAGIC *mg; |
67 | if (sv) { |
68 | if (SvMAGICAL(sv)) |
69 | mg_get(sv); |
70 | if (SvROK(sv) && |
71 | (sv = (SV*)SvRV(sv)) && /* assign deliberate */ |
72 | SvTYPE(sv) == SVt_PVMG && |
73 | (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ |
74 | { |
75 | if (mgp) *mgp = mg; |
49d7dfbc |
76 | return (REGEXP *)mg->mg_obj; |
44a2ac75 |
77 | } |
78 | } |
79 | if (mgp) *mgp = NULL; |
80 | return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL); |
81 | } |
82 | |
56953603 |
83 | MODULE = re PACKAGE = re |
84 | |
85 | void |
f9f4320a |
86 | install() |
87 | PPCODE: |
88 | PL_colorset = 0; /* Allow reinspection of ENV. */ |
89 | /* PL_debug |= DEBUG_r_FLAG; */ |
90 | XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine)))); |
91 | |
de8c5301 |
92 | |
93 | void |
de8c5301 |
94 | regexp_pattern(sv) |
95 | SV * sv |
96 | PROTOTYPE: $ |
97 | PREINIT: |
98 | MAGIC *mg; |
49d7dfbc |
99 | REGEXP *re; |
de8c5301 |
100 | PPCODE: |
101 | { |
102 | /* |
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 |
110 | on the object. |
111 | */ |
112 | |
44a2ac75 |
113 | if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */ |
de8c5301 |
114 | { |
de8c5301 |
115 | /* Housten, we have a regex! */ |
116 | SV *pattern; |
de8c5301 |
117 | STRLEN patlen = 0; |
118 | STRLEN left = 0; |
119 | char reflags[6]; |
120 | |
121 | if ( GIMME_V == G_ARRAY ) { |
122 | /* |
123 | we are in list context so stringify |
124 | the modifiers that apply. We ignore "negative |
125 | modifiers" in this scenario. |
126 | */ |
127 | |
bcdf7404 |
128 | char *fptr = INT_PAT_MODS; |
de8c5301 |
129 | char ch; |
bbe252da |
130 | U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12); |
de8c5301 |
131 | |
132 | while((ch = *fptr++)) { |
bbe252da |
133 | if(match_flags & 1) { |
de8c5301 |
134 | reflags[left++] = ch; |
135 | } |
bbe252da |
136 | match_flags >>= 1; |
de8c5301 |
137 | } |
138 | |
139 | pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen)); |
bbe252da |
140 | if (re->extflags & RXf_UTF8) SvUTF8_on(pattern); |
de8c5301 |
141 | |
142 | /* return the pattern and the modifiers */ |
143 | XPUSHs(pattern); |
144 | XPUSHs(sv_2mortal(newSVpvn(reflags,left))); |
145 | XSRETURN(2); |
146 | } else { |
147 | /* Scalar, so use the string that Perl would return */ |
de8c5301 |
148 | /* return the pattern in (?msix:..) format */ |
bcdf7404 |
149 | pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen)); |
bbe252da |
150 | if (re->extflags & RXf_UTF8) |
de8c5301 |
151 | SvUTF8_on(pattern); |
152 | XPUSHs(pattern); |
153 | XSRETURN(1); |
154 | } |
155 | } else { |
156 | /* It ain't a regexp folks */ |
157 | if ( GIMME_V == G_ARRAY ) { |
158 | /* return the empty list */ |
159 | XSRETURN_UNDEF; |
160 | } else { |
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 |
166 | can say |
167 | |
168 | if (regex($might_be_a_regex) eq '(?:foo)') { } |
169 | |
170 | and not worry about undefined values. |
171 | */ |
172 | XSRETURN_NO; |
173 | } |
174 | } |
175 | /* NOT-REACHED */ |
256ddcd0 |
176 | } |
177 | |
178 | |
179 | void |
180 | regmust(sv) |
181 | SV * sv |
182 | PROTOTYPE: $ |
183 | PREINIT: |
49d7dfbc |
184 | REGEXP *re; |
256ddcd0 |
185 | PPCODE: |
186 | { |
44a2ac75 |
187 | if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */ |
256ddcd0 |
188 | { |
189 | SV *an = &PL_sv_no; |
190 | SV *fl = &PL_sv_no; |
256ddcd0 |
191 | if (re->anchored_substr) { |
192 | an = newSVsv(re->anchored_substr); |
193 | } else if (re->anchored_utf8) { |
194 | an = newSVsv(re->anchored_utf8); |
195 | } |
196 | if (re->float_substr) { |
197 | fl = newSVsv(re->float_substr); |
198 | } else if (re->float_utf8) { |
199 | fl = newSVsv(re->float_utf8); |
200 | } |
201 | XPUSHs(an); |
202 | XPUSHs(fl); |
203 | XSRETURN(2); |
204 | } |
205 | XSRETURN_UNDEF; |
206 | } |
44a2ac75 |
207 | |