Fix bug whereby length on a tied scalar that returned a UTF-8 value

would not be correct the first time. (And for the more pathological
case, would be incorrect if the UTF-8-ness of the returned value
changed.)

p4raw-id: //depot/perl@32968

4 files changed, 71 insertions, 5 deletions

diff --git a/MANIFEST b/MANIFEST
index 222cdebea5..e251bb4283 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4035,6 +4035,7 @@ t/uni/upper.t			See if Unicode casing works
 t/uni/write.t			See if Unicode formats work
 t/win32/system.t		See if system works in Win*
 t/win32/system_tests		Test runner for system.t
+t/uni/tie.t			See if Unicode tie works
 t/x2p/s2p.t			See if s2p/psed work
 uconfig.h			Configuration header for microperl
 uconfig.sh			Configuration script for microperl
diff --git a/mg.c b/mg.c
index 41d283710f..b64a778099 100644
--- a/mg.c
+++ b/mg.c
@@ -308,12 +308,15 @@ Perl_mg_length(pTHX_ SV *sv)
 	}
     }
 
-    if (DO_UTF8(sv)) {
+    {
+	/* You can't know whether it's UTF-8 until you get the string again...
+	 */
         const U8 *s = (U8*)SvPV_const(sv, len);
-	len = utf8_length(s, s + len);
+
+	if (DO_UTF8(sv)) {
+	    len = utf8_length(s, s + len);
+	}
     }
-    else
-        (void)SvPV_const(sv, len);
     return len;
 }
 
diff --git a/t/op/length.t b/t/op/length.t
index 0c444840e5..41d34aee8e 100644
--- a/t/op/length.t
+++ b/t/op/length.t
@@ -2,10 +2,11 @@
 
 BEGIN {
     chdir 't' if -d 't';
+    require './test.pl';
     @INC = '../lib';
 }
 
-print "1..20\n";
+plan (tests => 22);
 
 print "not " unless length("")    == 0;
 print "ok 1\n";
@@ -148,3 +149,15 @@ print "ok 3\n";
     substr($a, 0, 1) = '';
     print length $a == 998 ? "ok 20\n" : "not ok 20\n";
 }
+
+curr_test(21);
+
+require Tie::Scalar;
+
+$u = "ASCII";
+
+tie $u, 'Tie::StdScalar', chr 256;
+
+is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
+is(length $u, 1, "Again! Again!");
+
diff --git a/t/uni/tie.t b/t/uni/tie.t
new file mode 100644
index 0000000000..fa9f268bbf
--- /dev/null
+++ b/t/uni/tie.t
@@ -0,0 +1,49 @@
+#!perl -w
+
+BEGIN {
+    if ($ENV{'PERL_CORE'}){
+        chdir 't';
+        @INC = '../lib';
+    }
+}
+
+use Test::More tests => 9;
+use strict;
+
+{
+    package UTF8Toggle;
+
+    sub TIESCALAR {
+	my $class = shift;
+	my $value = shift;
+	my $state = shift||0;
+	return bless [$value, $state], $class;
+    }
+
+    sub FETCH {
+	my $self = shift;
+	$self->[1] = ! $self->[1];
+	if ($self->[1]) {
+	    utf8::downgrade($self->[0]);
+	} else {
+	    utf8::upgrade($self->[0]);
+	}
+	$self->[0];
+    }
+}
+
+foreach my $t ("ASCII", "B\366se") {
+    my $length = length $t;
+
+    my $u;
+    tie $u, 'UTF8Toggle',  $t;
+    is (length $u, $length, "length of '$t'");
+    is (length $u, $length, "length of '$t'");
+    is (length $u, $length, "length of '$t'");
+    is (length $u, $length, "length of '$t'");
+}
+
+{
+    local $TODO = "Need more tests!";
+    fail();
+}