This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid my_regdupe type mismatch warning after #29430
[perl5.git] / ext / re / re.xs
CommitLineData
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
12START_EXTERN_C
13
6d5c990f 14extern regexp* my_re_compile (pTHX_ char* exp, char* xend, PMOP* pm);
cea2e8a9 15extern 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
19extern 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);
22extern SV* my_re_intuit_string (pTHX_ regexp *prog);
56953603 23
f8149455 24extern void my_regfree (pTHX_ struct regexp* r);
a3c0e9ca 25#if defined(USE_ITHREADS)
9f33bf00 26extern void* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
a3c0e9ca 27#endif
0a28d81c 28
70685ca0
JH
29EXTERN_C const struct regexp_engine my_reg_engine;
30
31END_EXTERN_C
32
33const struct regexp_engine my_reg_engine = {
6d5c990f 34 my_re_compile,
f9f4320a
YO
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
44MODULE = re PACKAGE = re
45
46void
f9f4320a
YO
47install()
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
54void
55is_regexp(sv)
56 SV * sv
57PROTOTYPE: $
58PREINIT:
59 MAGIC *mg;
60PPCODE:
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
76void
77regexp_pattern(sv)
78 SV * sv
79PROTOTYPE: $
80PREINIT:
81 MAGIC *mg;
82PPCODE:
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
171void
172regmust(sv)
173 SV * sv
174PROTOTYPE: $
175PREINIT:
176 MAGIC *mg;
177PPCODE:
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}