A new try from Dave Mitchell for [perl #23265].

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

diff --git a/sv.c b/sv.c
index 69fbbaa..2c24d26 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -24,6 +24,24 @@
 
 #define FCALL *f
 
+#ifdef PERL_UTF8_CACHE_ASSERT
+/* The cache element 0 is the Unicode offset;
+ * the cache element 1 is the byte offset of the element 0;
+ * the cache element 2 is the Unicode length of the substring;
+ * the cache element 3 is the byte length of the substring;
+ * The checking of the substring side would be good
+ * but substr() has enough code paths to make my head spin;
+ * if adding more checks watch out for the following tests:
+ *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
+ *   lib/utf8.t lib/Unicode/Collate/t/index.t
+ * --jhi
+ */
+#define ASSERT_UTF8_CACHE(cache) \
+       STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
+#else
+#define ASSERT_UTF8_CACHE(cache) NOOP
+#endif
+
 #ifdef PERL_COPY_ON_WRITE
 #define SV_COW_NEXT_SV(sv)     INT2PTR(SV *,SvUVX(sv))
 #define SV_COW_NEXT_SV_SET(current,next)       SvUVX(current) = PTR2UV(next)
@@ -3069,7 +3087,11 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                                    s = "REF";
                                else
                                    s = "SCALAR";               break;
-               case SVt_PVLV:  s = SvROK(sv) ? "REF":"LVALUE"; break;
+               case SVt_PVLV:  s = SvROK(sv) ? "REF"
+                               /* tied lvalues should appear to be
+                                * scalars for backwards compatitbility */
+                               : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+                                   ? "SCALAR" : "LVALUE";      break;
                case SVt_PVAV:  s = "ARRAY";                    break;
                case SVt_PVHV:  s = "HASH";                     break;
                case SVt_PVCV:  s = "CODE";                     break;
@@ -5091,7 +5113,9 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
     else {
        av = newAV();
        sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
-       SvREFCNT_dec(av);           /* for sv_magic */
+       /* av now has a refcnt of 2, which avoids it getting freed
+        * before us during global cleanup. The extra ref is removed
+        * by magic_killbackrefs() when tsv is being freed */
     }
     if (AvFILLp(av) >= AvMAX(av)) {
         SV **svp = AvARRAY(av);
@@ -5285,6 +5309,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
 #endif
     SvREFCNT(sv) = refcnt;
     SvFLAGS(nsv) |= SVTYPEMASK;                /* Mark as freed */
+    SvREFCNT(nsv) = 0;
     del_SV(nsv);
 }
 
@@ -5653,8 +5678,12 @@ Perl_sv_len_utf8(pTHX_ register SV *sv)
        U8 *s = (U8*)SvPV(sv, len);
        MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
 
-       if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
+       if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
            ulen = mg->mg_len;
+#ifdef PERL_UTF8_CACHE_ASSERT
+           assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
+#endif
+       }
        else {
            ulen = Perl_utf8_length(aTHX_ s, s + len);
            if (!mg && !SvREADONLY(sv)) {
@@ -5724,8 +5753,9 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I
            *mgp = mg_find(sv, PERL_MAGIC_utf8);
        if (*mgp && (*mgp)->mg_ptr) {
            *cachep = (STRLEN *) (*mgp)->mg_ptr;
+           ASSERT_UTF8_CACHE(*cachep);
            if ((*cachep)[i] == (STRLEN)uoff)   /* An exact match. */
-                found = TRUE;
+                 found = TRUE;          
            else {                      /* We will skip to the right spot. */
                 STRLEN forw  = 0;
                 STRLEN backw = 0;
@@ -5797,7 +5827,24 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I
                 }
            }
        }
+#ifdef PERL_UTF8_CACHE_ASSERT
+       if (found) {
+            U8 *s = start;
+            I32 n = uoff;
+
+            while (n-- && s < send)
+                 s += UTF8SKIP(s);
+
+            if (i == 0) {
+                 assert(*offsetp == s - start);
+                 assert((*cachep)[0] == (STRLEN)uoff);
+                 assert((*cachep)[1] == *offsetp);
+            }
+            ASSERT_UTF8_CACHE(*cachep);
+       }
+#endif
     }
+
     return found;
 }
  
@@ -5869,12 +5916,14 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
              }
              *lenp = s - start;
         }
+        ASSERT_UTF8_CACHE(cache);
     }
     else {
         *offsetp = 0;
         if (lenp)
              *lenp = 0;
     }
+
     return;
 }
 
@@ -5960,6 +6009,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
                    }
                }
            }
+           ASSERT_UTF8_CACHE(cache);
        }
 
        while (s < send) {
@@ -6573,15 +6623,23 @@ thats_really_all_folks:
     }
    else
     {
-#ifndef EPOC
-       /*The big, slow, and stupid way */
-       STDCHAR buf[8192];
+       /*The big, slow, and stupid way. */
+
+      /* Any stack-challenged places. */
+#if defined(EPOC)
+      /* EPOC: need to work around SDK features.         *
+       * On WINS: MS VC5 generates calls to _chkstk,     *
+       * if a "large" stack frame is allocated.          *
+       * gcc on MARM does not generate calls like these. */
+#   define USEHEAPINSTEADOFSTACK
+#endif
+
+#ifdef USEHEAPINSTEADOFSTACK
+       STDCHAR *buf = 0;
+       New(0, buf, 8192, STDCHAR);
+       assert(buf);
 #else
-       /* Need to work around EPOC SDK features          */
-       /* On WINS: MS VC5 generates calls to _chkstk,    */
-       /* if a `large' stack frame is allocated          */
-       /* gcc on MARM does not generate calls like these */
-       STDCHAR buf[1024];
+       STDCHAR buf[8192];
 #endif
 
 screamer2:
@@ -6630,6 +6688,10 @@ screamer2:
            if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
                goto screamer2;
        }
+
+#ifdef USEHEAPINSTEADOFSTACK
+       Safefree(buf);
+#endif
     }
 
     if (rspara) {              /* have to do this both before and after */
@@ -7801,7 +7863,12 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob)
                                    return "REF";
                                else
                                    return "SCALAR";
-       case SVt_PVLV:          return SvROK(sv) ? "REF" : "LVALUE";
+                               
+       case SVt_PVLV:          return SvROK(sv) ? "REF"
+                               /* tied lvalues should appear to be
+                                * scalars for backwards compatitbility */
+                               : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+                                   ? "SCALAR" : "LVALUE";
        case SVt_PVAV:          return "ARRAY";
        case SVt_PVHV:          return "HASH";
        case SVt_PVCV:          return "CODE";
@@ -10664,7 +10731,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 
 Create and return a new interpreter by cloning the current one.
 
-perl_clone takes these flags as paramters:
+perl_clone takes these flags as parameters:
 
 CLONEf_COPY_STACKS - is used to, well, copy the stacks also, 
 without it we only clone the data and zero the stacks, 
@@ -11429,6 +11496,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regstartp       = (I32*)NULL;
     PL_regendp         = (I32*)NULL;
     PL_reglastparen    = (U32*)NULL;
+    PL_reglastcloseparen       = (U32*)NULL;
     PL_regtill         = Nullch;
     PL_reg_start_tmp   = (char**)NULL;
     PL_reg_start_tmpl  = 0;