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