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
1 #if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
2 #  define DEBUGGING
3 #endif
4
5 #define PERL_NO_GET_CONTEXT
6 #include "EXTERN.h"
7 #include "perl.h"
8 #include "XSUB.h"
9 #include "re_comp.h"
10
11
12 START_EXTERN_C
13
14 extern regexp*  my_re_compile (pTHX_ char* exp, char* xend, PMOP* pm);
15 extern I32      my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
16                             char* strbeg, I32 minend, SV* screamer,
17                             void* data, U32 flags);
18
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);
23
24 extern void     my_regfree (pTHX_ struct regexp* r);
25 #if defined(USE_ITHREADS)
26 extern void*    my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
27 #endif
28
29 EXTERN_C const struct regexp_engine my_reg_engine;
30
31 END_EXTERN_C
32
33 const struct regexp_engine my_reg_engine = { 
34         my_re_compile, 
35         my_regexec, 
36         my_re_intuit_start, 
37         my_re_intuit_string, 
38         my_regfree, 
39 #if defined(USE_ITHREADS)
40         my_regdupe 
41 #endif
42 };
43
44 MODULE = re     PACKAGE = re
45
46 void
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         
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;
119             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
120
121             while((ch = *fptr++)) {
122                 if(match_flags & 1) {
123                     reflags[left++] = ch;
124                 }
125                 match_flags >>= 1;
126             }
127
128             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
129             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
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));
142             if (re->extflags & RXf_UTF8) 
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 */
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 }