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