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_ char* exp, char* xend, PMOP* pm);
  15 extern I32      my_regexec (pTHX_ regexp* 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 *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 *prog);
  23
  24 extern void     my_regfree (pTHX_ struct regexp* r);
  25 #if defined(USE_ITHREADS)
  26 extern void*    my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
  27 #endif
  28
  29 EXTERN_C const struct regexp_engine my_reg_engine;
  30
  31 END_EXTERN_C
  32
  33 const struct regexp_engine my_reg_engine = {
  34         my_re_compile,
  35         my_regexec,
  36         my_re_intuit_start,
  37         my_re_intuit_string,
  38         my_regfree,
  39 #if defined(USE_ITHREADS)
  40         my_regdupe
  41 #endif
  42 };
  43
  44 regexp *
  45 get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
  46     MAGIC *mg;
  47     if (sv) {
  48         if (SvMAGICAL(sv))
  49             mg_get(sv);
  50         if (SvROK(sv) &&
  51             (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
  52             SvTYPE(sv) == SVt_PVMG &&
  53             (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
  54         {
  55             if (mgp) *mgp = mg;
  56             return (regexp *)mg->mg_obj;
  57         }
  58     }
  59     if (mgp) *mgp = NULL;
  60     return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
  61 }
  62
  63 MODULE = re     PACKAGE = re
  64
  65 void
  66 install()
  67     PPCODE:
  68         PL_colorset = 0;        /* Allow reinspection of ENV. */
  69         /* PL_debug |= DEBUG_r_FLAG; */
  70         XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine))));
  71
  72
  73 void
  74 is_regexp(sv)
  75     SV * sv
  76 PROTOTYPE: $
  77 PPCODE:
  78 {
  79     if ( get_re_arg( aTHX_ sv, 0, NULL ) )
  80     {
  81         XSRETURN_YES;
  82     } else {
  83         XSRETURN_NO;
  84     }
  85     /* NOTREACHED */
  86 }
  87
  88 void
  89 regexp_pattern(sv)
  90     SV * sv
  91 PROTOTYPE: $
  92 PREINIT:
  93     MAGIC *mg;
  94     regexp *re;
  95 PPCODE:
  96 {
  97     /*
  98        Checks if a reference is a regex or not. If the parameter is
  99        not a ref, or is not the result of a qr// then returns false
 100        in scalar context and an empty list in list context.
 101        Otherwise in list context it returns the pattern and the
 102        modifiers, in scalar context it returns the pattern just as it
 103        would if the qr// was stringified normally, regardless as
 104        to the class of the variable and any strigification overloads
 105        on the object.
 106     */
 107
 108     if ( re = get_re_arg( aTHX_ sv, 0, &mg) ) /* assign deliberate */
 109     {
 110         /* Housten, we have a regex! */
 111         SV *pattern;
 112         STRLEN patlen = 0;
 113         STRLEN left = 0;
 114         char reflags[6];
 115
 116         if ( GIMME_V == G_ARRAY ) {
 117             /*
 118                we are in list context so stringify
 119                the modifiers that apply. We ignore "negative
 120                modifiers" in this scenario.
 121             */
 122
 123             char *fptr = INT_PAT_MODS;
 124             char ch;
 125             U16 match_flags = (U16)((re->extflags & PMf_COMPILETIME) >> 12);
 126
 127             while((ch = *fptr++)) {
 128                 if(match_flags & 1) {
 129                     reflags[left++] = ch;
 130                 }
 131                 match_flags >>= 1;
 132             }
 133
 134             pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen));
 135             if (re->extflags & RXf_UTF8) SvUTF8_on(pattern);
 136
 137             /* return the pattern and the modifiers */
 138             XPUSHs(pattern);
 139             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
 140             XSRETURN(2);
 141         } else {
 142             /* Scalar, so use the string that Perl would return */
 143             /* return the pattern in (?msix:..) format */
 144             pattern = sv_2mortal(newSVpvn(re->wrapped,re->wraplen));
 145             if (re->extflags & RXf_UTF8)
 146                 SvUTF8_on(pattern);
 147             XPUSHs(pattern);
 148             XSRETURN(1);
 149         }
 150     } else {
 151         /* It ain't a regexp folks */
 152         if ( GIMME_V == G_ARRAY ) {
 153             /* return the empty list */
 154             XSRETURN_UNDEF;
 155         } else {
 156             /* Because of the (?:..) wrapping involved in a
 157                stringified pattern it is impossible to get a
 158                result for a real regexp that would evaluate to
 159                false. Therefore we can return PL_sv_no to signify
 160                that the object is not a regex, this means that one
 161                can say
 162
 163                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 164
 165                and not worry about undefined values.
 166             */
 167             XSRETURN_NO;
 168         }
 169     }
 170     /* NOT-REACHED */
 171 }
 172
 173
 174 void
 175 regmust(sv)
 176     SV * sv
 177 PROTOTYPE: $
 178 PREINIT:
 179     regexp *re;
 180 PPCODE:
 181 {
 182     if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
 183     {
 184         SV *an = &PL_sv_no;
 185         SV *fl = &PL_sv_no;
 186         if (re->anchored_substr) {
 187             an = newSVsv(re->anchored_substr);
 188         } else if (re->anchored_utf8) {
 189             an = newSVsv(re->anchored_utf8);
 190         }
 191         if (re->float_substr) {
 192             fl = newSVsv(re->float_substr);
 193         } else if (re->float_utf8) {
 194             fl = newSVsv(re->float_utf8);
 195         }
 196         XPUSHs(an);
 197         XPUSHs(fl);
 198         XSRETURN(2);
 199     }
 200     XSRETURN_UNDEF;
 201 }
 202
 203 void
 204 regname(sv, qr = NULL, all = NULL)
 205     SV * sv
 206     SV * qr
 207     SV * all
 208 PROTOTYPE: ;$$$
 209 PREINIT:
 210     regexp *re = NULL;
 211     SV *bufs = NULL;
 212 PPCODE:
 213 {
 214     re = get_re_arg( aTHX_ qr, 1, NULL);
 215     if (SvPOK(sv) && re && re->paren_names) {
 216         bufs = Perl_reg_named_buff_get(aTHX_ sv, re ,all && SvTRUE(all));
 217         if (bufs) {
 218             if (all && SvTRUE(all))
 219                 XPUSHs(newRV(bufs));
 220             else
 221                 XPUSHs(SvREFCNT_inc(bufs));
 222             XSRETURN(1);
 223         }
 224     }
 225     XSRETURN_UNDEF;
 226 }
 227
 228 void
 229 regnames(sv = NULL, all = NULL)
 230     SV *sv
 231     SV *all
 232 PROTOTYPE: ;$$
 233 PREINIT:
 234     regexp *re = NULL;
 235     IV count = 0;
 236 PPCODE:
 237 {
 238     re = get_re_arg( aTHX_  sv, 1, NULL );
 239     if (re && re->paren_names) {
 240         HV *hv= re->paren_names;
 241         (void)hv_iterinit(hv);
 242         while (1) {
 243             HE *temphe = hv_iternext_flags(hv,0);
 244             if (temphe) {
 245                 IV i;
 246                 IV parno = 0;
 247                 SV* sv_dat = HeVAL(temphe);
 248                 I32 *nums = (I32*)SvPVX(sv_dat);
 249                 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
 250                     if ((I32)(re->lastcloseparen) >= nums[i] &&
 251                         re->startp[nums[i]] != -1 &&
 252                         re->endp[nums[i]] != -1)
 253                     {
 254                         parno = nums[i];
 255                         break;
 256                     }
 257                 }
 258                 if (parno || (all && SvTRUE(all))) {
 259                     STRLEN len;
 260                     char *pv = HePV(temphe, len);
 261                     if ( GIMME_V == G_ARRAY )
 262                         XPUSHs(newSVpvn(pv,len));
 263                     count++;
 264                 }
 265             } else {
 266                 break;
 267             }
 268         }
 269     }
 270     if ( GIMME_V == G_ARRAY )
 271         XSRETURN(count);
 272     else
 273         XSRETURN_UNDEF;
 274 }
 275
 276 void
 277 regnames_iterinit(sv = NULL)
 278     SV * sv
 279 PROTOTYPE: ;$
 280 PREINIT:
 281     regexp *re = NULL;
 282 PPCODE:
 283 {
 284     re = get_re_arg( aTHX_  sv, 1, NULL );
 285     if (re && re->paren_names) {
 286         (void)hv_iterinit(re->paren_names);
 287         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
 288     } else {
 289         XSRETURN_UNDEF;
 290     }
 291 }
 292
 293 void
 294 regnames_iternext(sv = NULL, all = NULL)
 295     SV *sv
 296     SV *all
 297 PROTOTYPE: ;$$
 298 PREINIT:
 299     regexp *re;
 300 PPCODE:
 301 {
 302     re = get_re_arg( aTHX_  sv, 1, NULL );
 303     if (re && re->paren_names) {
 304         HV *hv= re->paren_names;
 305         while (1) {
 306             HE *temphe = hv_iternext_flags(hv,0);
 307             if (temphe) {
 308                 IV i;
 309                 IV parno = 0;
 310                 SV* sv_dat = HeVAL(temphe);
 311                 I32 *nums = (I32*)SvPVX(sv_dat);
 312                 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
 313                     if ((I32)(re->lastcloseparen) >= nums[i] &&
 314                         re->startp[nums[i]] != -1 &&
 315                         re->endp[nums[i]] != -1)
 316                     {
 317                         parno = nums[i];
 318                         break;
 319                     }
 320                 }
 321                 if (parno || (all && SvTRUE(all))) {
 322                     STRLEN len;
 323                     char *pv = HePV(temphe, len);
 324                     XPUSHs(newSVpvn(pv,len));
 325                     XSRETURN(1);
 326                 }
 327             } else {
 328                 break;
 329             }
 330         }
 331     }
 332     XSRETURN_UNDEF;
 333 }
 334
 335 void
 336 regnames_count(sv = NULL)
 337     SV * sv
 338 PROTOTYPE: ;$
 339 PREINIT:
 340     regexp *re = NULL;
 341 PPCODE:
 342 {
 343     re = get_re_arg( aTHX_  sv, 1, NULL );
 344     if (re && re->paren_names) {
 345         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
 346     } else {
 347         XSRETURN_UNDEF;
 348     }
 349 }