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