Make 4-arg substr check SvUTF8(target) after stringfying
authorFather Chrysostomos <sprout@cpan.org>
Sat, 29 Sep 2012 18:27:35 +0000 (11:27 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 1 Oct 2012 19:51:56 +0000 (12:51 -0700)
If it checks the UTF8 flag first, it might be looking at a stale flag,
resulting in malformed UTF8.  Both tests added produced malformed utf8
strings before this commit.

Simply moving this:

    if (!DO_UTF8(sv))
sv_utf8_upgrade(sv);

after the stringification is not enough to fix this, as the string
retrieved will be out of date after we do an upgrade.  To avoid
stringifying twice, we use SvPV_force if there is a replacement.  This
means rearranging if() blocks a little.

The use of SvPV_force also means that string overloading is no longer
called twice on the target scalar.  This rearrangement also means
that targets upgraded to utf8 are no longer exempt from the refer-
ence warning.  (Oh, and the test for that warning was not testing any-
thing in its no warnings test, because the target was no longer a ref-
erence; so I corrected the test.)

pp.c
t/lib/warnings/pp
t/op/substr.t

index eef9483..171cb87 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3017,7 +3017,6 @@ PP(pp_substr)
     STRLEN repl_len;
     int num_args = PL_op->op_private & 7;
     bool repl_need_utf8_upgrade = FALSE;
-    bool repl_is_utf8 = FALSE;
 
     if (num_args > 2) {
        if (num_args > 3) {
@@ -3038,17 +3037,7 @@ PP(pp_substr)
        repl_sv = POPs;
     }
     PUTBACK;
-    if (repl_sv) {
-       repl = SvPV_const(repl_sv, repl_len);
-       repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
-       if (repl_is_utf8) {
-           if (!DO_UTF8(sv))
-               sv_utf8_upgrade(sv);
-       }
-       else if (DO_UTF8(sv))
-           repl_need_utf8_upgrade = TRUE;
-    }
-    else if (lvalue) {
+    if (lvalue && !repl_sv) {
        SV * ret;
        ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
        sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
@@ -3067,7 +3056,24 @@ PP(pp_substr)
        PUSHs(ret);    /* avoid SvSETMAGIC here */
        RETURN;
     }
-    tmps = SvPV_const(sv, curlen);
+    if (repl_sv) {
+       repl = SvPV_const(repl_sv, repl_len);
+       SvGETMAGIC(sv);
+       if (SvROK(sv))
+           Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+                           "Attempt to use reference as lvalue in substr"
+           );
+       tmps = SvPV_force_nomg(sv, curlen);
+       if (DO_UTF8(repl_sv) && repl_len) {
+           if (!DO_UTF8(sv)) {
+               sv_utf8_upgrade(sv);
+               curlen = SvCUR(sv);
+           }
+       }
+       else if (DO_UTF8(sv))
+           repl_need_utf8_upgrade = TRUE;
+    }
+    else tmps = SvPV_const(sv, curlen);
     if (DO_UTF8(sv)) {
         utf8_curlen = sv_len_utf8_nomg(sv);
        if (utf8_curlen == curlen)
@@ -3109,17 +3115,10 @@ PP(pp_substr)
                repl_sv_copy = newSVsv(repl_sv);
                sv_utf8_upgrade(repl_sv_copy);
                repl = SvPV_const(repl_sv_copy, repl_len);
-               repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
            }
-           if (SvROK(sv))
-               Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
-                           "Attempt to use reference as lvalue in substr"
-               );
            if (!SvOK(sv))
                sv_setpvs(sv, "");
            sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
-           if (repl_is_utf8)
-               SvUTF8_on(sv);
            SvREFCNT_dec(repl_sv_copy);
        }
     }
index 89ebcbc..ab8f951 100644 (file)
@@ -37,10 +37,16 @@ use warnings 'substr' ;
 $a = "ab" ; 
 $b = \$a ;  
 substr($b, 1,1) = "ab" ;
+$b = \$a;
+substr($b, 1,1) = "\x{100}" ;
 no warnings 'substr' ;
+$b = \$a;
 substr($b, 1,1) = "ab" ;
+$b = \$a;
+substr($b, 1,1) = "\x{100}" ;
 EXPECT
 Attempt to use reference as lvalue in substr at - line 5.
+Attempt to use reference as lvalue in substr at - line 7.
 ########
 # pp.c
 use warnings 'misc' ;
index 6a84052..a2b24af 100644 (file)
@@ -23,7 +23,7 @@ $SIG{__WARN__} = sub {
 
 BEGIN { require './test.pl'; }
 
-plan(382);
+plan(385);
 
 run_tests() unless caller;
 
@@ -822,10 +822,31 @@ is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
 # assignment.
 # We use overloading for our magic var, but a typeglob would work, too.
 package o {
-    use overload '""' => sub { $_[0][0] }
+    use overload '""' => sub { ++our $count; $_[0][0] }
 }
 my $refee = bless ["\x{100}a"], o::;
 my $substr = \substr $refee, -2;       # UTF8 flag still off for $$substr.
 $$substr = "b";                                # UTF8 flag turns on when setsubstr
 is $refee, "b",                                # magic stringifies $$substr.
      'substr lvalue assignment when stringification turns on UTF8ness';
+
+# Test that changing UTF8-ness does not confuse 4-arg substr.
+$refee = bless [], "\x{100}a";
+# stringify without returning on UTF8 flag on $refee:
+my $string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+  '4-arg substr with target UTF8ness turning on when stringified';
+$refee = bless [], "\x{100}";
+() = "$refee"; # UTF8 flag now on
+bless $refee, "\xff";
+$string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+  '4-arg substr with target UTF8ness turning off when stringified';
+
+# Overload count
+$refee = bless ["foo"], o::;
+$o::count = 0;
+substr $refee, 0, 0, "";
+is $o::count, 1, '4-arg substr calls overloading once on the target';