This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SvRX() and SvRXOK() macros
[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_ const SV * const pattern, const U32 pm_flags);
15 extern I32      my_regexec (pTHX_ REGEXP * const 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 * const prog, SV *sv, char *strpos,
20                                     char *strend, const U32 flags,
21                                     struct re_scream_pos_data_s *data);
22 extern SV*      my_re_intuit_string (pTHX_ REGEXP * const prog);
23
24 extern void     my_regfree (pTHX_ REGEXP * const r);
25
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
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);
37
38 extern SV*      my_reg_qr_package(pTHX_ REGEXP * const rx);
39 #if defined(USE_ITHREADS)
40 extern void*    my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
41 #endif
42
43 EXTERN_C const struct regexp_engine my_reg_engine;
44
45 END_EXTERN_C
46
47 const struct regexp_engine my_reg_engine = { 
48         my_re_compile, 
49         my_regexec, 
50         my_re_intuit_start, 
51         my_re_intuit_string, 
52         my_regfree, 
53         my_reg_numbered_buff_fetch,
54         my_reg_numbered_buff_store,
55         my_reg_numbered_buff_length,
56         my_reg_named_buff,
57         my_reg_named_buff_iter,
58         my_reg_qr_package,
59 #if defined(USE_ITHREADS)
60         my_regdupe 
61 #endif
62 };
63
64 MODULE = re     PACKAGE = re
65
66 void
67 install()
68     PPCODE:
69         PL_colorset = 0;        /* Allow reinspection of ENV. */
70         /* PL_debug |= DEBUG_r_FLAG; */
71         XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
72         
73
74 void
75 regexp_pattern(sv)
76     SV * sv
77 PROTOTYPE: $
78 PREINIT:
79     REGEXP *re;
80 PPCODE:
81 {
82     /*
83        Checks if a reference is a regex or not. If the parameter is
84        not a ref, or is not the result of a qr// then returns false
85        in scalar context and an empty list in list context.
86        Otherwise in list context it returns the pattern and the
87        modifiers, in scalar context it returns the pattern just as it
88        would if the qr// was stringified normally, regardless as
89        to the class of the variable and any strigification overloads
90        on the object. 
91     */
92
93     if ((re = SvRX(sv))) /* assign deliberate */
94     {
95         /* Housten, we have a regex! */
96         SV *pattern;
97         STRLEN patlen = 0;
98         STRLEN left = 0;
99         char reflags[6];
100         
101         if ( GIMME_V == G_ARRAY ) {
102             /*
103                we are in list context so stringify
104                the modifiers that apply. We ignore "negative
105                modifiers" in this scenario. 
106             */
107
108             char *fptr = INT_PAT_MODS;
109             char ch;
110             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
111
112             while((ch = *fptr++)) {
113                 if(match_flags & 1) {
114                     reflags[left++] = ch;
115                 }
116                 match_flags >>= 1;
117             }
118
119             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
120             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
121
122             /* return the pattern and the modifiers */
123             XPUSHs(pattern);
124             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
125             XSRETURN(2);
126         } else {
127             /* Scalar, so use the string that Perl would return */
128             /* return the pattern in (?msix:..) format */
129             pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
130             if (re->extflags & RXf_UTF8) 
131                 SvUTF8_on(pattern);
132             XPUSHs(pattern);
133             XSRETURN(1);
134         }
135     } else {
136         /* It ain't a regexp folks */
137         if ( GIMME_V == G_ARRAY ) {
138             /* return the empty list */
139             XSRETURN_UNDEF;
140         } else {
141             /* Because of the (?:..) wrapping involved in a 
142                stringified pattern it is impossible to get a 
143                result for a real regexp that would evaluate to 
144                false. Therefore we can return PL_sv_no to signify
145                that the object is not a regex, this means that one 
146                can say
147                
148                  if (regex($might_be_a_regex) eq '(?:foo)') { }
149                
150                and not worry about undefined values.
151             */
152             XSRETURN_NO;
153         }    
154     }
155     /* NOT-REACHED */
156 }
157
158
159 void
160 regmust(sv)
161     SV * sv
162 PROTOTYPE: $
163 PREINIT:
164     REGEXP *re;
165 PPCODE:
166 {
167     if ((re = SvRX(sv))) /* assign deliberate */
168     {
169         SV *an = &PL_sv_no;
170         SV *fl = &PL_sv_no;
171         if (re->anchored_substr) {
172             an = newSVsv(re->anchored_substr);
173         } else if (re->anchored_utf8) {
174             an = newSVsv(re->anchored_utf8);
175         }
176         if (re->float_substr) {
177             fl = newSVsv(re->float_substr);
178         } else if (re->float_utf8) {
179             fl = newSVsv(re->float_utf8);
180         }
181         XPUSHs(an);
182         XPUSHs(fl);
183         XSRETURN(2);
184     }
185     XSRETURN_UNDEF;
186 }
187