From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 17 Mar 2006 22:12:27 +0000 (+0000)
Subject: Make Perl_sv_len_utf8 honour the new ${^UTF8CACHE}.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=263464574f2ea8aa016791622811118aec3970fc;p=p5sagit%2Fp5-mst-13.2.git

Make Perl_sv_len_utf8 honour the new ${^UTF8CACHE}.
If PERL_UTF8_CACHE_ASSERT is defined, default ${^UTF8CACHE} to -1
(assertion mode). Need a way to turn this on with existing command
line flags.

p4raw-id: //depot/perl@27538
---

diff --git a/intrpvar.h b/intrpvar.h
index aa31aaf..3908e5b 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -553,7 +553,11 @@ PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */
 PERLVAR(Imemory_debug_header, struct perl_memory_debug_header)
 #endif
 
-PERLVARI(Iutf8cache, signed char, 1)	/* Is the utf8 caching code enabled? */
+#ifdef PERL_UTF8_CACHE_ASSERT
+PERLVARI(Iutf8cache, I8, -1)	/* Is the utf8 caching code enabled? */
+#else
+PERLVARI(Iutf8cache, I8, 1)	/* Is the utf8 caching code enabled? */
+#endif
 
 /* New variables must be added to the very end, before this comment,
  * for binary compatibility (the offsets of the old members must not change).
diff --git a/sv.c b/sv.c
index d981d88..78e0d24 100644
--- a/sv.c
+++ b/sv.c
@@ -5285,28 +5285,43 @@ Perl_sv_len_utf8(pTHX_ register SV *sv)
 	return mg_length(sv);
     else
     {
-	STRLEN len, ulen;
+	STRLEN len;
 	const U8 *s = (U8*)SvPV_const(sv, len);
-	MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
 
-	if (mg && mg->mg_len != -1) {
-	    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 (!SvREADONLY(sv)) {
-		if (!mg) {
-		    sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
-		    mg = mg_find(sv, PERL_MAGIC_utf8);
+	if (PL_utf8cache) {
+	    STRLEN ulen;
+	    MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
+
+	    if (mg && mg->mg_len != -1) {
+		ulen = mg->mg_len;
+		if (PL_utf8cache < 0) {
+		    const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
+		    if (real != ulen) {
+			/* Need to turn the assertions off otherwise we may
+			   recurse infinitely while printing error messages.
+			*/
+			SAVEI8(PL_utf8cache);
+			PL_utf8cache = 0;
+			Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf
+				   "real %"UVf" for %"SVf,
+				   (UV) ulen, (UV) real, sv);
+		    }
+		}
+	    }
+	    else {
+		ulen = Perl_utf8_length(aTHX_ s, s + len);
+		if (!SvREADONLY(sv)) {
+		    if (!mg) {
+			mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
+					 &PL_vtbl_utf8, 0, 0);
+		    }
 		    assert(mg);
+		    mg->mg_len = ulen;
 		}
-		mg->mg_len = ulen;
 	    }
+	    return ulen;
 	}
-	return ulen;
+	return Perl_utf8_length(aTHX_ s, s + len);
     }
 }