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_UTF8(re))
 122                  SvUTF8_on(pattern);
 123
 124             /* return the pattern and the modifiers */
 125             XPUSHs(pattern);
 126             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
 127             XSRETURN(2);
 128         } else {
 129             /* Scalar, so use the string that Perl would return */
 130             /* return the pattern in (?msix:..) format */
 131 #if PERL_VERSION >= 11
 132             pattern = sv_2mortal(newSVsv((SV*)re));
 133 #else
 134             pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
 135             if (RX_UTF8(re))
 136                 SvUTF8_on(pattern);
 137 #endif
 138             XPUSHs(pattern);
 139             XSRETURN(1);
 140         }
 141     } else {
 142         /* It ain't a regexp folks */
 143         if ( GIMME_V == G_ARRAY ) {
 144             /* return the empty list */
 145             XSRETURN_UNDEF;
 146         } else {
 147             /* Because of the (?:..) wrapping involved in a
 148                stringified pattern it is impossible to get a
 149                result for a real regexp that would evaluate to
 150                false. Therefore we can return PL_sv_no to signify
 151                that the object is not a regex, this means that one
 152                can say
 153
 154                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 155
 156                and not worry about undefined values.
 157             */
 158             XSRETURN_NO;
 159         }
 160     }
 161     /* NOT-REACHED */
 162 }
 163
 164
 165 void
 166 regmust(sv)
 167     SV * sv
 168 PROTOTYPE: $
 169 PREINIT:
 170     REGEXP *re;
 171 PPCODE:
 172 {
 173     if ((re = SvRX(sv))) /* assign deliberate */
 174     {
 175         SV *an = &PL_sv_no;
 176         SV *fl = &PL_sv_no;
 177         if (RX_ANCHORED_SUBSTR(re)) {
 178             an = newSVsv(RX_ANCHORED_SUBSTR(re));
 179         } else if (RX_ANCHORED_UTF8(re)) {
 180             an = newSVsv(RX_ANCHORED_UTF8(re));
 181         }
 182         if (RX_FLOAT_SUBSTR(re)) {
 183             fl = newSVsv(RX_FLOAT_SUBSTR(re));
 184         } else if (RX_FLOAT_UTF8(re)) {
 185             fl = newSVsv(RX_FLOAT_UTF8(re));
 186         }
 187         XPUSHs(an);
 188         XPUSHs(fl);
 189         XSRETURN(2);
 190     }
 191     XSRETURN_UNDEF;
 192 }
 193