From 3a482d8d6250628185cb4de79a85f353ba799a58 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 22 Jan 2012 22:39:47 -0800
Subject: [PATCH] =?utf8?q?sv=5Fforce=5Fnormal:=20Don=E2=80=99t=20confuse?=
 =?utf8?q?=20regexps=20with=20cows?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

Otherwise we get assertion failures and possibly corrupt
string tables.
---
 sv.c              |  2 +-
 sv.h              |  3 ++-
 t/lib/universal.t | 14 +++++++++++++-
 3 files changed, 16 insertions(+), 3 deletions(-)

diff --git a/sv.c b/sv.c
index 6e8ed66..3736e27 100644
--- a/sv.c
+++ b/sv.c
@@ -4797,7 +4797,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
     }
 #else
     if (SvREADONLY(sv)) {
-	if (SvFAKE(sv) && !isGV_with_GP(sv)) {
+	if (SvIsCOW(sv)) {
 	    const char * const pvx = SvPVX_const(sv);
 	    const STRLEN len = SvCUR(sv);
 	    SvFAKE_off(sv);
diff --git a/sv.h b/sv.h
index 48b05ec..935f4ff 100644
--- a/sv.h
+++ b/sv.h
@@ -1745,7 +1745,8 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
 #endif /* __GNU__ */
 
 #define SvIsCOW(sv)	((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
-			   (SVf_FAKE | SVf_READONLY) && !isGV_with_GP(sv))
+			   (SVf_FAKE | SVf_READONLY) && !isGV_with_GP(sv) \
+			   && SvTYPE(sv) != SVt_REGEXP)
 #define SvIsCOW_shared_hash(sv)	(SvIsCOW(sv) && SvLEN(sv) == 0)
 
 #define SvSHARED_HEK_FROM_PV(pvx) \
diff --git a/t/lib/universal.t b/t/lib/universal.t
index 1576470..a52e019 100644
--- a/t/lib/universal.t
+++ b/t/lib/universal.t
@@ -6,7 +6,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 10 );
+    plan( tests => 13 );
 }
 
 for my $arg ('', 'q[]', qw( 1 undef )) {
@@ -37,6 +37,18 @@ Internals::SvREADONLY($x,0);
 $x = 42;
 is $x, 42, 'Internals::SvREADONLY can turn off readonliness on globs';
 
+# Same thing with regexps
+$x = ${qr//};
+Internals::SvREADONLY $x, 1;
+ok Internals::SvREADONLY($x),
+         'read-only regexps are read-only acc. to Internals::';
+eval { $x = [] };
+like $@, qr/Modification of a read-only value attempted at/,
+    'read-only regexps';
+Internals::SvREADONLY($x,0);
+$x = 42;
+is $x, 42, 'Internals::SvREADONLY can turn off readonliness on regexps';
+
 $h{a} = __PACKAGE__;
 Internals::SvREADONLY $h{a}, 1;
 eval { $h{a} = 3 };
-- 
2.7.4