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_regcomp (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 extern void     my_regfree (pTHX_ struct regexp* r);
  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 extern char*    my_reg_stringify (pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags,  I32 *haseval);
  24
  25 #if defined(USE_ITHREADS)
  26 extern regexp*  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_regcomp,
  35         my_regexec,
  36         my_re_intuit_start,
  37         my_re_intuit_string,
  38         my_regfree,
  39         my_reg_stringify,
  40 #if defined(USE_ITHREADS)
  41         my_regdupe
  42 #endif
  43 };
  44
  45 MODULE = re     PACKAGE = re
  46
  47 void
  48 install()
  49     PPCODE:
  50         PL_colorset = 0;        /* Allow reinspection of ENV. */
  51         /* PL_debug |= DEBUG_r_FLAG; */
  52         XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
  53
  54
  55 void
  56 is_regexp(sv)
  57     SV * sv
  58 PROTOTYPE: $
  59 PREINIT:
  60     MAGIC *mg;
  61 PPCODE:
  62 {
  63     if (SvMAGICAL(sv))
  64         mg_get(sv);
  65     if (SvROK(sv) &&
  66         (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
  67         SvTYPE(sv) == SVt_PVMG &&
  68         (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
  69     {
  70         XSRETURN_YES;
  71     } else {
  72         XSRETURN_NO;
  73     }
  74     /* NOTREACHED */
  75 }
  76
  77 void
  78 regexp_pattern(sv)
  79     SV * sv
  80 PROTOTYPE: $
  81 PREINIT:
  82     MAGIC *mg;
  83 PPCODE:
  84 {
  85     /*
  86        Checks if a reference is a regex or not. If the parameter is
  87        not a ref, or is not the result of a qr// then returns false
  88        in scalar context and an empty list in list context.
  89        Otherwise in list context it returns the pattern and the
  90        modifiers, in scalar context it returns the pattern just as it
  91        would if the qr// was stringified normally, regardless as
  92        to the class of the variable and any strigification overloads
  93        on the object.
  94     */
  95
  96     if (SvMAGICAL(sv))
  97         mg_get(sv);
  98     if (SvROK(sv) &&
  99         (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
 100         SvTYPE(sv) == SVt_PVMG &&
 101         (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
 102     {
 103
 104         /* Housten, we have a regex! */
 105         SV *pattern;
 106         regexp *re = (regexp *)mg->mg_obj;
 107         STRLEN patlen = 0;
 108         STRLEN left = 0;
 109         char reflags[6];
 110
 111         if ( GIMME_V == G_ARRAY ) {
 112             /*
 113                we are in list context so stringify
 114                the modifiers that apply. We ignore "negative
 115                modifiers" in this scenario.
 116             */
 117
 118             char *fptr = "msix";
 119             char ch;
 120             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
 121
 122             while((ch = *fptr++)) {
 123                 if(match_flags & 1) {
 124                     reflags[left++] = ch;
 125                 }
 126                 match_flags >>= 1;
 127             }
 128
 129             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
 130             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
 131
 132             /* return the pattern and the modifiers */
 133             XPUSHs(pattern);
 134             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
 135             XSRETURN(2);
 136         } else {
 137             /* Scalar, so use the string that Perl would return */
 138             if (!mg->mg_ptr)
 139                 CALLREG_STRINGIFY(mg,0,0);
 140
 141             /* return the pattern in (?msix:..) format */
 142             pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len));
 143             if (re->extflags & RXf_UTF8)
 144                 SvUTF8_on(pattern);
 145             XPUSHs(pattern);
 146             XSRETURN(1);
 147         }
 148     } else {
 149         /* It ain't a regexp folks */
 150         if ( GIMME_V == G_ARRAY ) {
 151             /* return the empty list */
 152             XSRETURN_UNDEF;
 153         } else {
 154             /* Because of the (?:..) wrapping involved in a
 155                stringified pattern it is impossible to get a
 156                result for a real regexp that would evaluate to
 157                false. Therefore we can return PL_sv_no to signify
 158                that the object is not a regex, this means that one
 159                can say
 160
 161                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 162
 163                and not worry about undefined values.
 164             */
 165             XSRETURN_NO;
 166         }
 167     }
 168     /* NOT-REACHED */
 169 }
 170
 171
 172 void
 173 regmust(sv)
 174     SV * sv
 175 PROTOTYPE: $
 176 PREINIT:
 177     MAGIC *mg;
 178 PPCODE:
 179 {
 180     if (SvMAGICAL(sv))
 181         mg_get(sv);
 182     if (SvROK(sv) &&
 183         (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
 184         SvTYPE(sv) == SVt_PVMG &&
 185         (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
 186     {
 187         SV *an = &PL_sv_no;
 188         SV *fl = &PL_sv_no;
 189         regexp *re = (regexp *)mg->mg_obj;
 190         if (re->anchored_substr) {
 191             an = newSVsv(re->anchored_substr);
 192         } else if (re->anchored_utf8) {
 193             an = newSVsv(re->anchored_utf8);
 194         }
 195         if (re->float_substr) {
 196             fl = newSVsv(re->float_substr);
 197         } else if (re->float_utf8) {
 198             fl = newSVsv(re->float_utf8);
 199         }
 200         XPUSHs(an);
 201         XPUSHs(fl);
 202         XSRETURN(2);
 203     }
 204     XSRETURN_UNDEF;
 205 }