This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
13dcdc268d76696350afdffd6b5a6f892430309c
[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
10
11 START_EXTERN_C
12
13 extern regexp*  my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm);
14 extern I32      my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
15                             char* strbeg, I32 minend, SV* screamer,
16                             void* data, U32 flags);
17 extern void     my_regfree (pTHX_ struct regexp* r);
18 extern char*    my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos,
19                                     char *strend, U32 flags,
20                                     struct re_scream_pos_data_s *data);
21 extern SV*      my_re_intuit_string (pTHX_ regexp *prog);
22 extern char*    my_reg_stringify (pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags,  I32 *haseval);
23
24 #if defined(USE_ITHREADS)
25 extern regexp*  my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
26 #endif
27
28 EXTERN_C const struct regexp_engine my_reg_engine = { 
29         my_regcomp, 
30         my_regexec, 
31         my_re_intuit_start, 
32         my_re_intuit_string, 
33         my_regfree, 
34         my_reg_stringify,
35 #if defined(USE_ITHREADS)
36         my_regdupe 
37 #endif
38 };
39
40 END_EXTERN_C
41
42 MODULE = re     PACKAGE = re
43
44 void
45 install()
46     PPCODE:
47         PL_colorset = 0;        /* Allow reinspection of ENV. */
48         /* PL_debug |= DEBUG_r_FLAG; */
49         XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
50         
51
52 void
53 is_regexp(sv)
54     SV * sv
55 PROTOTYPE: $
56 PREINIT:
57     MAGIC *mg;
58 PPCODE:
59 {
60     if (SvMAGICAL(sv))  
61         mg_get(sv);
62     if (SvROK(sv) && 
63         (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
64         SvTYPE(sv) == SVt_PVMG && 
65         (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
66     {
67         XSRETURN_YES;
68     } else {
69         XSRETURN_NO;
70     }
71     /* NOTREACHED */        
72 }        
73         
74 void
75 regexp_pattern(sv)
76     SV * sv
77 PROTOTYPE: $
78 PREINIT:
79     MAGIC *mg;
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 (SvMAGICAL(sv))  
94         mg_get(sv);
95     if (SvROK(sv) && 
96         (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
97         SvTYPE(sv) == SVt_PVMG && 
98         (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
99     {
100     
101         /* Housten, we have a regex! */
102         SV *pattern;
103         regexp *re = (regexp *)mg->mg_obj;
104         STRLEN patlen = 0;
105         STRLEN left = 0;
106         char reflags[6];
107         
108         if ( GIMME_V == G_ARRAY ) {
109             /*
110                we are in list context so stringify
111                the modifiers that apply. We ignore "negative
112                modifiers" in this scenario. 
113             */
114
115             char *fptr = "msix";
116             char ch;
117             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
118
119             while((ch = *fptr++)) {
120                 if(reganch & 1) {
121                     reflags[left++] = ch;
122                 }
123                 reganch >>= 1;
124             }
125
126             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
127             if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern);
128
129             /* return the pattern and the modifiers */
130             XPUSHs(pattern);
131             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
132             XSRETURN(2);
133         } else {
134             /* Scalar, so use the string that Perl would return */
135             if (!mg->mg_ptr) 
136                 CALLREG_STRINGIFY(mg,0,0);
137             
138             /* return the pattern in (?msix:..) format */
139             pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len));
140             if (re->reganch & ROPT_UTF8) 
141                 SvUTF8_on(pattern);
142             XPUSHs(pattern);
143             XSRETURN(1);
144         }
145     } else {
146         /* It ain't a regexp folks */
147         if ( GIMME_V == G_ARRAY ) {
148             /* return the empty list */
149             XSRETURN_UNDEF;
150         } else {
151             /* Because of the (?:..) wrapping involved in a 
152                stringified pattern it is impossible to get a 
153                result for a real regexp that would evaluate to 
154                false. Therefore we can return PL_sv_no to signify
155                that the object is not a regex, this means that one 
156                can say
157                
158                  if (regex($might_be_a_regex) eq '(?:foo)') { }
159                
160                and not worry about undefined values.
161             */
162             XSRETURN_NO;
163         }    
164     }
165     /* NOT-REACHED */
166 }