Add a readonly check to Perl_sv_utf8_upgrade_flags, a regresion test

in utf8.t, and fix 3 bugs it exposed in utfhash.t

p4raw-id: //depot/perl@22463

diff --git a/lib/utf8.t b/lib/utf8.t
index 33cd596..90035e5 100644 (file)
--- a/lib/utf8.t
+++ b/lib/utf8.t
@@ -37,7 +37,7 @@ no utf8; # Ironic, no?
 #
 #
 
-plan tests => 143;
+plan tests => 144;
 
 {
     # bug id 20001009.001
@@ -409,3 +409,9 @@ SKIP: {
     ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
     ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
 }
+
+{
+    eval {utf8::encode("£")};
+    like($@, qr/^Modification of a read-only value attempted/,
+        "utf8::encode should refuse to touch read-only values");
+}

diff --git a/sv.c b/sv.c
index f8bd408..e49ac5e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3470,12 +3470,16 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
             return len;
     }
 
+    if (SvUTF8(sv))
+       return SvCUR(sv);
+
     if (SvIsCOW(sv)) {
         sv_force_normal_flags(sv, 0);
     }
 
-    if (SvUTF8(sv))
-       return SvCUR(sv);
+    if (SvREADONLY(sv)) {
+       Perl_croak(aTHX_ PL_no_modify);
+    }
 
     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
         sv_recode_to_utf8(sv, PL_encoding);

diff --git a/t/op/utfhash.t b/t/op/utfhash.t
index 9e0196b..33909c0 100644 (file)
--- a/t/op/utfhash.t
+++ b/t/op/utfhash.t
@@ -32,8 +32,9 @@ is($hashu{"\xff"},0xFF);
 is($hashu{"\x7f"},0x7F);
 
 # Now try same thing with variables forced into various forms.
-foreach my $a ("\x7f","\xff")
+foreach ("\x7f","\xff")
  {
+  my $a = $_; # Force a copy
   utf8::upgrade($a);
   is($hash8{$a},ord($a));
   is($hashu{$a},ord($a));
@@ -56,8 +57,9 @@ $hash8{chr(0x1ff)} = 0x1ff;
 # Check we have not got an spurious extra keys
 is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
 
-foreach my $a ("\x7f","\xff","\x{1ff}")
+foreach ("\x7f","\xff","\x{1ff}")
  {
+  my $a = $_;
   utf8::upgrade($a);
   is($hash8{$a},ord($a));
   my $b = $a.chr(100);
@@ -69,8 +71,9 @@ foreach my $a ("\x7f","\xff","\x{1ff}")
 is(delete $hashu{chr(0x1ff)},0x1ff);
 is(join('',sort keys %hashu),"\x7f\xff");
 
-foreach my $a ("\x7f","\xff")
+foreach ("\x7f","\xff")
  {
+  my $a = $_;
   utf8::upgrade($a);
   is($hashu{$a},ord($a));
   utf8::downgrade($a);