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