Re: [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc)

Message-Id: <20060225180934.FCC3.BQW10602@nifty.com>

p4raw-id: //depot/perl@27329

diff --git a/pp.c b/pp.c
index 1724ab0..b1fa7bc 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3350,7 +3350,8 @@ PP(pp_ucfirst)
            if (slen > ulen)
                sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
            SvUTF8_on(TARG);
-           SETs(TARG);
+           sv = TARG;
+           SETs(sv);
        }
        else {
            s = (U8*)SvPV_force_nomg(sv, slen);
@@ -3402,7 +3403,8 @@ PP(pp_uc)
        if (!len) {
            SvUTF8_off(TARG);                           /* decontaminate */
            sv_setpvn(TARG, "", 0);
-           SETs(TARG);
+           sv = TARG;
+           SETs(sv);
        }
        else {
            STRLEN min = len + 1;
@@ -3435,7 +3437,8 @@ PP(pp_uc)
            *d = '\0';
            SvUTF8_on(TARG);
            SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
-           SETs(TARG);
+           sv = TARG;
+           SETs(sv);
        }
     }
     else {
@@ -3487,7 +3490,8 @@ PP(pp_lc)
        if (!len) {
            SvUTF8_off(TARG);                           /* decontaminate */
            sv_setpvn(TARG, "", 0);
-           SETs(TARG);
+           sv = TARG;
+           SETs(sv);
        }
        else {
            STRLEN min = len + 1;
@@ -3540,7 +3544,8 @@ PP(pp_lc)
            *d = '\0';
            SvUTF8_on(TARG);
            SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
-           SETs(TARG);
+           sv = TARG;
+           SETs(sv);
        }
     }
     else {

diff --git a/t/op/lc.t b/t/op/lc.t
index 460fed2..95cf019 100644 (file)
--- a/t/op/lc.t
+++ b/t/op/lc.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 59;
+plan tests => 77;
 
 $a = "HELLO.* world";
 $b = "hello.* WORLD";
@@ -163,3 +163,39 @@ for my $a (0,1) {
        is($a, v10, "[perl #18857]");
     } 
 }
+
+
+# [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc)
+
+for ("a\x{100}", "xyz\x{100}") {
+    is(substr(uc($_), 0), uc($_), "[perl #38619] uc");
+}
+for ("A\x{100}", "XYZ\x{100}") {
+    is(substr(lc($_), 0), lc($_), "[perl #38619] lc");
+}
+for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length)
+    is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst");
+}
+
+# Related to [perl #38619]
+# the original report concerns PERL_MAGIC_utf8.
+# these cases concern PERL_MAGIC_regex_global.
+
+for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") {
+    chop; # get ("a", "abc", "") in utf8
+    my $return =  uc($_) =~ /\G(.?)/g;
+    my $result = $return ? $1 : "not";
+    my $expect = (uc($_) =~ /(.?)/g)[0];
+    is($return, 1,       "[perl #38619]");
+    is($result, $expect, "[perl #38619]");
+}
+
+for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") {
+    chop; # get ("A", "ABC", "") in utf8
+    my $return =  lc($_) =~ /\G(.?)/g;
+    my $result = $return ? $1 : "not";
+    my $expect = (lc($_) =~ /(.?)/g)[0];
+    is($return, 1,       "[perl #38619]");
+    is($result, $expect, "[perl #38619]");
+}
+