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 = "msix";
 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             if (!mg->mg_ptr)
 144                 CALLREG_STRINGIFY(mg,0,0);
 145
 146             /* return the pattern in (?msix:..) format */
 147             pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len));
 148             if (re->extflags & RXf_UTF8)
 149                 SvUTF8_on(pattern);
 150             XPUSHs(pattern);
 151             XSRETURN(1);
 152         }
 153     } else {
 154         /* It ain't a regexp folks */
 155         if ( GIMME_V == G_ARRAY ) {
 156             /* return the empty list */
 157             XSRETURN_UNDEF;
 158         } else {
 159             /* Because of the (?:..) wrapping involved in a
 160                stringified pattern it is impossible to get a
 161                result for a real regexp that would evaluate to
 162                false. Therefore we can return PL_sv_no to signify
 163                that the object is not a regex, this means that one
 164                can say
 165
 166                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 167
 168                and not worry about undefined values.
 169             */
 170             XSRETURN_NO;
 171         }
 172     }
 173     /* NOT-REACHED */
 174 }
 175
 176
 177 void
 178 regmust(sv)
 179     SV * sv
 180 PROTOTYPE: $
 181 PREINIT:
 182     regexp *re;
 183 PPCODE:
 184 {
 185     if ( re = get_re_arg( aTHX_ sv, 0, 0) ) /* assign deliberate */
 186     {
 187         SV *an = &PL_sv_no;
 188         SV *fl = &PL_sv_no;
 189         if (re->anchored_substr) {
 190             an = newSVsv(re->anchored_substr);
 191         } else if (re->anchored_utf8) {
 192             an = newSVsv(re->anchored_utf8);
 193         }
 194         if (re->float_substr) {
 195             fl = newSVsv(re->float_substr);
 196         } else if (re->float_utf8) {
 197             fl = newSVsv(re->float_utf8);
 198         }
 199         XPUSHs(an);
 200         XPUSHs(fl);
 201         XSRETURN(2);
 202     }
 203     XSRETURN_UNDEF;
 204 }
 205
 206 void
 207 regname(sv, qr = NULL, all = NULL)
 208     SV * sv
 209     SV * qr
 210     SV * all
 211 PROTOTYPE: ;$$$
 212 PREINIT:
 213     regexp *re = NULL;
 214     SV *bufs = NULL;
 215 PPCODE:
 216 {
 217     re = get_re_arg( aTHX_ qr, 1, NULL);
 218     if (SvPOK(sv) && re && re->paren_names) {
 219         bufs = Perl_reg_named_buff_get(aTHX_ sv, re ,all && SvTRUE(all));
 220         if (bufs) {
 221             if (all && SvTRUE(all))
 222                 XPUSHs(newRV(bufs));
 223             else
 224                 XPUSHs(SvREFCNT_inc(bufs));
 225             XSRETURN(1);
 226         }
 227     }
 228     XSRETURN_UNDEF;
 229 }
 230
 231 void
 232 regnames(sv = NULL, all = NULL)
 233     SV *sv
 234     SV *all
 235 PROTOTYPE: ;$$
 236 PREINIT:
 237     regexp *re = NULL;
 238     IV count = 0;
 239 PPCODE:
 240 {
 241     re = get_re_arg( aTHX_  sv, 1, NULL );
 242     if (re && re->paren_names) {
 243         HV *hv= re->paren_names;
 244         (void)hv_iterinit(hv);
 245         while (1) {
 246             HE *temphe = hv_iternext_flags(hv,0);
 247             if (temphe) {
 248                 IV i;
 249                 IV parno = 0;
 250                 SV* sv_dat = HeVAL(temphe);
 251                 I32 *nums = (I32*)SvPVX(sv_dat);
 252                 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
 253                     if ((I32)(re->lastcloseparen) >= nums[i] &&
 254                         re->startp[nums[i]] != -1 &&
 255                         re->endp[nums[i]] != -1)
 256                     {
 257                         parno = nums[i];
 258                         break;
 259                     }
 260                 }
 261                 if (parno || (all && SvTRUE(all))) {
 262                     STRLEN len;
 263                     char *pv = HePV(temphe, len);
 264                     if ( GIMME_V == G_ARRAY )
 265                         XPUSHs(newSVpvn(pv,len));
 266                     count++;
 267                 }
 268             } else {
 269                 break;
 270             }
 271         }
 272     }
 273     if ( GIMME_V == G_ARRAY )
 274         XSRETURN(count);
 275     else
 276         XSRETURN_UNDEF;
 277 }
 278
 279 void
 280 regnames_iterinit(sv = NULL)
 281     SV * sv
 282 PROTOTYPE: ;$
 283 PREINIT:
 284     regexp *re = NULL;
 285 PPCODE:
 286 {
 287     re = get_re_arg( aTHX_  sv, 1, NULL );
 288     if (re && re->paren_names) {
 289         (void)hv_iterinit(re->paren_names);
 290         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
 291     } else {
 292         XSRETURN_UNDEF;
 293     }
 294 }
 295
 296 void
 297 regnames_iternext(sv = NULL, all = NULL)
 298     SV *sv
 299     SV *all
 300 PROTOTYPE: ;$$
 301 PREINIT:
 302     regexp *re;
 303 PPCODE:
 304 {
 305     re = get_re_arg( aTHX_  sv, 1, NULL );
 306     if (re && re->paren_names) {
 307         HV *hv= re->paren_names;
 308         while (1) {
 309             HE *temphe = hv_iternext_flags(hv,0);
 310             if (temphe) {
 311                 IV i;
 312                 IV parno = 0;
 313                 SV* sv_dat = HeVAL(temphe);
 314                 I32 *nums = (I32*)SvPVX(sv_dat);
 315                 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
 316                     if ((I32)(re->lastcloseparen) >= nums[i] &&
 317                         re->startp[nums[i]] != -1 &&
 318                         re->endp[nums[i]] != -1)
 319                     {
 320                         parno = nums[i];
 321                         break;
 322                     }
 323                 }
 324                 if (parno || (all && SvTRUE(all))) {
 325                     STRLEN len;
 326                     char *pv = HePV(temphe, len);
 327                     XPUSHs(newSVpvn(pv,len));
 328                     XSRETURN(1);
 329                 }
 330             } else {
 331                 break;
 332             }
 333         }
 334     }
 335     XSRETURN_UNDEF;
 336 }
 337
 338 void
 339 regnames_count(sv = NULL)
 340     SV * sv
 341 PROTOTYPE: ;$
 342 PREINIT:
 343     regexp *re = NULL;
 344 PPCODE:
 345 {
 346     re = get_re_arg( aTHX_  sv, 1, NULL );
 347     if (re && re->paren_names) {
 348         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
 349     } else {
 350         XSRETURN_UNDEF;
 351     }
 352 }