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 35125d9..baa5d99 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4796,7 +4796,7 @@ reStudy:
 
 
 SV*
-Perl_reg_named_buff_get(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
+Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
 {
     AV *retarray = NULL;
     SV *ret;
@@ -4815,7 +4815,7 @@ Perl_reg_named_buff_get(pTHX_ REGEXP * const rx, SV * const namesv, const U32 fl
                        && rx->offs[nums[i]].end != -1)
                 {
                     ret = newSVpvs("");
-                    CALLREG_NUMBUF(rx,nums[i],ret);
+                    CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
                     if (!retarray)
                         return ret;
                 } else {
@@ -4834,7 +4834,7 @@ Perl_reg_named_buff_get(pTHX_ REGEXP * const rx, SV * const namesv, const U32 fl
 }
 
 void
-Perl_reg_numbered_buff_get(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
+Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
 {
     char *s = NULL;
     I32 i = 0;
@@ -4908,6 +4908,73 @@ Perl_reg_numbered_buff_get(pTHX_ REGEXP * const rx, const I32 paren, SV * const
     }
 }
 
+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_package(pTHX_ REGEXP * const rx)
 {
@@ -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,9 +6640,9 @@ tryagain:
     case 0xDF:
     case 0xC3:
     case 0xCE:
-        if (FOLD) {
+        if (!LOC && FOLD) {
             U32 len,cp;
-            if (cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len)) {
+            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);
@@ -6887,7 +6952,7 @@ tryagain:
                case 0xDF:
                case 0xC3:
                case 0xCE:
-                          if (!FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
+                          if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
                                goto normal_default;
                case '^':
                case '$':
@@ -8866,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;
@@ -8891,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);