This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Callbacks for named captures (%+ and %-)
[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
973f7e2e 14extern REGEXP* my_re_compile (pTHX_ const SV * const pattern, const U32 pm_flags);
49d7dfbc 15extern I32 my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend,
20ce7b12
GS
16 char* strbeg, I32 minend, SV* screamer,
17 void* data, U32 flags);
f8149455 18
49d7dfbc 19extern 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
AB
22extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog);
23
24extern void my_regfree (pTHX_ REGEXP * const r);
2fdbfb4d 25
d932daed
SH
26extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
27 SV * const usesv);
28extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
29 SV const * const value);
30extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx,
31 const SV * const sv, const I32 paren);
32
192b9cd1
AB
33extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const,
34 const U32);
35extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx,
36 const SV * const lastkey, const U32 flags);
2fdbfb4d 37
49d7dfbc 38extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
a3c0e9ca 39#if defined(USE_ITHREADS)
49d7dfbc 40extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
a3c0e9ca 41#endif
0a28d81c 42
70685ca0
JH
43EXTERN_C const struct regexp_engine my_reg_engine;
44
45END_EXTERN_C
46
47const struct regexp_engine my_reg_engine = {
6d5c990f 48 my_re_compile,
f9f4320a
YO
49 my_regexec,
50 my_re_intuit_start,
51 my_re_intuit_string,
52 my_regfree,
2fdbfb4d
AB
53 my_reg_numbered_buff_fetch,
54 my_reg_numbered_buff_store,
55 my_reg_numbered_buff_length,
192b9cd1
AB
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
NC
62};
63
49d7dfbc 64REGEXP *
44a2ac75
YO
65get_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
YO
77 }
78 }
79 if (mgp) *mgp = NULL;
80 return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
81}
82
56953603
IZ
83MODULE = re PACKAGE = re
84
85void
f9f4320a
YO
86install()
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
YO
92
93void
de8c5301
YO
94regexp_pattern(sv)
95 SV * sv
96PROTOTYPE: $
97PREINIT:
98 MAGIC *mg;
49d7dfbc 99 REGEXP *re;
de8c5301
YO
100PPCODE:
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
YO
115 /* Housten, we have a regex! */
116 SV *pattern;
de8c5301
YO
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
YO
131
132 while((ch = *fptr++)) {
bbe252da 133 if(match_flags & 1) {
de8c5301
YO
134 reflags[left++] = ch;
135 }
bbe252da 136 match_flags >>= 1;
de8c5301
YO
137 }
138
139 pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
bbe252da 140 if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
de8c5301
YO
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
YO
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
YO
176}
177
178
179void
180regmust(sv)
181 SV * sv
182PROTOTYPE: $
183PREINIT:
49d7dfbc 184 REGEXP *re;
256ddcd0
YO
185PPCODE:
186{
44a2ac75 187 if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
256ddcd0
YO
188 {
189 SV *an = &PL_sv_no;
190 SV *fl = &PL_sv_no;
256ddcd0
YO
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