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

diff --git a/MANIFEST b/MANIFEST
index 222cdeb..e251bb4 100644 (file)
--- 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 41d2837..b64a778 100644 (file)
--- 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 0c44484..41d34ae 100644 (file)
--- 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 (file)
index 0000000..fa9f268
--- /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();
+}