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             char *fptr = INT_PAT_MODS;
 109             char ch;
 110             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
 111
 112             while((ch = *fptr++)) {
 113                 if(match_flags & 1) {
 114                     reflags[left++] = ch;
 115                 }
 116                 match_flags >>= 1;
 117             }
 118
 119             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
 120             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
 121
 122             /* return the pattern and the modifiers */
 123             XPUSHs(pattern);
 124             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
 125             XSRETURN(2);
 126         } else {
 127             /* Scalar, so use the string that Perl would return */
 128             /* return the pattern in (?msix:..) format */
 129             pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
 130             if (re->extflags & RXf_UTF8)
 131                 SvUTF8_on(pattern);
 132             XPUSHs(pattern);
 133             XSRETURN(1);
 134         }
 135     } else {
 136         /* It ain't a regexp folks */
 137         if ( GIMME_V == G_ARRAY ) {
 138             /* return the empty list */
 139             XSRETURN_UNDEF;
 140         } else {
 141             /* Because of the (?:..) wrapping involved in a
 142                stringified pattern it is impossible to get a
 143                result for a real regexp that would evaluate to
 144                false. Therefore we can return PL_sv_no to signify
 145                that the object is not a regex, this means that one
 146                can say
 147
 148                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 149
 150                and not worry about undefined values.
 151             */
 152             XSRETURN_NO;
 153         }
 154     }
 155     /* NOT-REACHED */
 156 }
 157
 158
 159 void
 160 regmust(sv)
 161     SV * sv
 162 PROTOTYPE: $
 163 PREINIT:
 164     REGEXP *re;
 165 PPCODE:
 166 {
 167     if ((re = SvRX(sv))) /* assign deliberate */
 168     {
 169         SV *an = &PL_sv_no;
 170         SV *fl = &PL_sv_no;
 171         if (re->anchored_substr) {
 172             an = newSVsv(re->anchored_substr);
 173         } else if (re->anchored_utf8) {
 174             an = newSVsv(re->anchored_utf8);
 175         }
 176         if (re->float_substr) {
 177             fl = newSVsv(re->float_substr);
 178         } else if (re->float_utf8) {
 179             fl = newSVsv(re->float_utf8);
 180         }
 181         XPUSHs(an);
 182         XPUSHs(fl);
 183         XSRETURN(2);
 184     }
 185     XSRETURN_UNDEF;
 186 }
 187