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