Given that @optype and @specialsv_name are hard coded tables, it seems

[p5sagit/p5-mst-13.2.git] / regcomp.c

diff --git a/regcomp.c b/regcomp.c
index 80aa335..baa5d99 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -3364,12 +3364,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
                data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
                if (flags & SCF_DO_STCLASS_AND) {
                     for (value = 0; value < 256; value++)
-                        if (!is_LNBREAK_cp(value))                   
+                        if (!is_VERTWS_cp(value))
                             ANYOF_BITMAP_CLEAR(data->start_class, value);  
                 }                                                              
                 else {                                                         
                     for (value = 0; value < 256; value++)
-                        if (is_LNBREAK_cp(value))                    
+                        if (is_VERTWS_cp(value))
                             ANYOF_BITMAP_SET(data->start_class, value);           
                 }                                                              
                 if (flags & SCF_DO_STCLASS_OR)
@@ -4796,7 +4796,7 @@ reStudy:
 
 
 SV*
-Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags)
+Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
 {
     AV *retarray = NULL;
     SV *ret;
@@ -4814,7 +4814,8 @@ Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags)
                        && rx->offs[nums[i]].start != -1
                        && rx->offs[nums[i]].end != -1)
                 {
-                    ret = CALLREG_NUMBUF(rx,nums[i],NULL);
+                    ret = newSVpvs("");
+                    CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
                     if (!retarray)
                         return ret;
                 } else {
@@ -4832,17 +4833,16 @@ Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags)
     return NULL;
 }
 
-SV*
-Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
+void
+Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
 {
     char *s = NULL;
     I32 i = 0;
     I32 s1, t1;
-    SV *sv = usesv ? usesv : newSVpvs("");
         
     if (!rx->subbeg) {
         sv_setsv(sv,&PL_sv_undef);
-        return sv;
+        return;
     } 
     else               
     if (paren == -2 && rx->offs[0].start != -1) {
@@ -4866,7 +4866,7 @@ Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
         s = rx->subbeg + s1;
     } else {
         sv_setsv(sv,&PL_sv_undef);
-        return sv;
+        return;
     }          
     assert(rx->sublen >= (s - rx->subbeg) + i );
     if (i >= 0) {
@@ -4904,12 +4904,79 @@ Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
         }
     } else {
         sv_setsv(sv,&PL_sv_undef);
+        return;
     }
-    return sv;
+}
+
+void
+Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
+                                                        SV const * const value)
+{
+    PERL_UNUSED_ARG(rx);
+    PERL_UNUSED_ARG(paren);
+    PERL_UNUSED_ARG(value);
+
+    if (!PL_localizing)
+        Perl_croak(aTHX_ PL_no_modify);
+}
+
+I32
+Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
+                              const I32 paren)
+{
+    I32 i;
+    I32 s1, t1;
+
+    /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
+       switch (paren) {
+      case -2: /* $` */
+        if (rx->offs[0].start != -1) {
+                       i = rx->offs[0].start;
+                       if (i > 0) {
+                               s1 = 0;
+                               t1 = i;
+                               goto getlen;
+                       }
+           }
+        return 0;
+      case -1: /* $' */
+           if (rx->offs[0].end != -1) {
+                       i = rx->sublen - rx->offs[0].end;
+                       if (i > 0) {
+                               s1 = rx->offs[0].end;
+                               t1 = rx->sublen;
+                               goto getlen;
+                       }
+           }
+        return 0;
+      default: /* $&, $1, $2, ... */
+           if (paren <= (I32)rx->nparens &&
+            (s1 = rx->offs[paren].start) != -1 &&
+            (t1 = rx->offs[paren].end) != -1)
+           {
+            i = t1 - s1;
+            goto getlen;
+        } else {
+            if (ckWARN(WARN_UNINITIALIZED))
+                report_uninit((SV*)sv);
+            return 0;
+        }
+    }
+  getlen:
+    if (i > 0 && RX_MATCH_UTF8(rx)) {
+        const char * const s = rx->subbeg + s1;
+        const U8 *ep;
+        STRLEN el;
+
+        i = t1 - s1;
+        if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
+                       i = el;
+    }
+    return i;
 }
 
 SV*
-Perl_reg_qr_pkg(pTHX_ const REGEXP * const rx)
+Perl_reg_qr_package(pTHX_ REGEXP * const rx)
 {
        PERL_UNUSED_ARG(rx);
        return newSVpvs("Regexp");
@@ -6434,8 +6501,7 @@ S_reg_recode(pTHX_ const char value, SV **encp)
 {
     STRLEN numlen = 1;
     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
-    const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
-                                        : SvPVX(sv);
+    const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
     const STRLEN newlen = SvCUR(sv);
     UV uv = UNICODE_REPLACEMENT;
 
@@ -6446,8 +6512,7 @@ S_reg_recode(pTHX_ const char value, SV **encp)
 
     if (!newlen || numlen != newlen) {
        uv = UNICODE_REPLACEMENT;
-       if (encp)
-           *encp = NULL;
+       *encp = NULL;
     }
     return uv;
 }
@@ -6575,16 +6640,18 @@ tryagain:
     case 0xDF:
     case 0xC3:
     case 0xCE:
-        if (FOLD && is_TRICKYFOLD(RExC_parse,UTF)) {
-            STRLEN len = UTF ? 0 : 1;
-            U32 cp = UTF ? utf8_to_uvchr((U8*)RExC_parse, &len) : (U32)((U8*)RExC_parse)[0];
-            *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
-            RExC_parse+=len;
-            ret = reganode(pRExC_state, FOLDCHAR, cp);
-            Set_Node_Length(ret, 1); /* MJD */
-        } else
-            goto outer_default;
-        break;
+        if (!LOC && FOLD) {
+            U32 len,cp;
+            if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) {
+                *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
+                RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */
+                ret = reganode(pRExC_state, FOLDCHAR, cp);
+                Set_Node_Length(ret, 1); /* MJD */
+                nextchar(pRExC_state); /* kill whitespace under /x */
+                return ret;
+            }
+        }
+        goto outer_default;
     case '\\':
        /* Special Escapes
 
@@ -6885,7 +6952,7 @@ tryagain:
                case 0xDF:
                case 0xC3:
                case 0xCE:
-                          if (!FOLD || !is_TRICKYFOLD(p,UTF))
+                          if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
                                goto normal_default;
                case '^':
                case '$':
@@ -8748,7 +8815,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
 }
 
 SV *
-Perl_re_intuit_string(pTHX_ regexp *prog)
+Perl_re_intuit_string(pTHX_ REGEXP * const prog)
 {                              /* Assume that RE_INTUIT is set */
     dVAR;
     GET_RE_DEBUG_FLAGS_DECL;
@@ -8864,10 +8931,7 @@ Perl_reg_temp_copy (pTHX_ struct regexp *r) {
     }
     RX_MATCH_COPIED_off(ret);
 #ifdef PERL_OLD_COPY_ON_WRITE
-    /* this is broken. */
-    assert(0); 
-    if (ret->saved_copy)
-        ret->saved_copy=NULL;
+    ret->saved_copy = NULL;
 #endif
     ret->mother_re = r; 
     ret->swap = NULL;
@@ -8889,7 +8953,7 @@ Perl_reg_temp_copy (pTHX_ struct regexp *r) {
  */
  
 void
-Perl_regfree_internal(pTHX_ struct regexp *r)
+Perl_regfree_internal(pTHX_ REGEXP * const r)
 {
     dVAR;
     RXi_GET_DECL(r,ri);
@@ -9115,7 +9179,7 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
 */
 
 void *
-Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
+Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param)
 {
     dVAR;
     regexp_internal *reti;