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 extern SV*      my_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv);
  26 extern SV*      my_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags);
  27 #if defined(USE_ITHREADS)
  28 extern void*    my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
  29 #endif
  30
  31 EXTERN_C const struct regexp_engine my_reg_engine;
  32
  33 END_EXTERN_C
  34
  35 const struct regexp_engine my_reg_engine = {
  36         my_re_compile,
  37         my_regexec,
  38         my_re_intuit_start,
  39         my_re_intuit_string,
  40         my_regfree,
  41         my_reg_numbered_buff_get,
  42         my_reg_named_buff_get,
  43 #if defined(USE_ITHREADS)
  44         my_regdupe
  45 #endif
  46 };
  47
  48 regexp *
  49 get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
  50     MAGIC *mg;
  51     if (sv) {
  52         if (SvMAGICAL(sv))
  53             mg_get(sv);
  54         if (SvROK(sv) &&
  55             (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
  56             SvTYPE(sv) == SVt_PVMG &&
  57             (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
  58         {
  59             if (mgp) *mgp = mg;
  60             return (regexp *)mg->mg_obj;
  61         }
  62     }
  63     if (mgp) *mgp = NULL;
  64     return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
  65 }
  66
  67 MODULE = re     PACKAGE = re
  68
  69 void
  70 install()
  71     PPCODE:
  72         PL_colorset = 0;        /* Allow reinspection of ENV. */
  73         /* PL_debug |= DEBUG_r_FLAG; */
  74         XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
  75
  76
  77 void
  78 regexp_pattern(sv)
  79     SV * sv
  80 PROTOTYPE: $
  81 PREINIT:
  82     MAGIC *mg;
  83     regexp *re;
  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 ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
  98     {
  99         /* Housten, we have a regex! */
 100         SV *pattern;
 101         STRLEN patlen = 0;
 102         STRLEN left = 0;
 103         char reflags[6];
 104
 105         if ( GIMME_V == G_ARRAY ) {
 106             /*
 107                we are in list context so stringify
 108                the modifiers that apply. We ignore "negative
 109                modifiers" in this scenario.
 110             */
 111
 112             char *fptr = INT_PAT_MODS;
 113             char ch;
 114             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
 115
 116             while((ch = *fptr++)) {
 117                 if(match_flags & 1) {
 118                     reflags[left++] = ch;
 119                 }
 120                 match_flags >>= 1;
 121             }
 122
 123             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
 124             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
 125
 126             /* return the pattern and the modifiers */
 127             XPUSHs(pattern);
 128             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
 129             XSRETURN(2);
 130         } else {
 131             /* Scalar, so use the string that Perl would return */
 132             /* return the pattern in (?msix:..) format */
 133             pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
 134             if (re->extflags & RXf_UTF8)
 135                 SvUTF8_on(pattern);
 136             XPUSHs(pattern);
 137             XSRETURN(1);
 138         }
 139     } else {
 140         /* It ain't a regexp folks */
 141         if ( GIMME_V == G_ARRAY ) {
 142             /* return the empty list */
 143             XSRETURN_UNDEF;
 144         } else {
 145             /* Because of the (?:..) wrapping involved in a
 146                stringified pattern it is impossible to get a
 147                result for a real regexp that would evaluate to
 148                false. Therefore we can return PL_sv_no to signify
 149                that the object is not a regex, this means that one
 150                can say
 151
 152                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 153
 154                and not worry about undefined values.
 155             */
 156             XSRETURN_NO;
 157         }
 158     }
 159     /* NOT-REACHED */
 160 }
 161
 162
 163 void
 164 regmust(sv)
 165     SV * sv
 166 PROTOTYPE: $
 167 PREINIT:
 168     regexp *re;
 169 PPCODE:
 170 {
 171     if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
 172     {
 173         SV *an = &PL_sv_no;
 174         SV *fl = &PL_sv_no;
 175         if (re->anchored_substr) {
 176             an = newSVsv(re->anchored_substr);
 177         } else if (re->anchored_utf8) {
 178             an = newSVsv(re->anchored_utf8);
 179         }
 180         if (re->float_substr) {
 181             fl = newSVsv(re->float_substr);
 182         } else if (re->float_utf8) {
 183             fl = newSVsv(re->float_utf8);
 184         }
 185         XPUSHs(an);
 186         XPUSHs(fl);
 187         XSRETURN(2);
 188     }
 189     XSRETURN_UNDEF;
 190 }
 191