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 }