This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix a s/non-utf8/is-utf8/ bit of nastiness
authorDavid Mitchell <davem@iabyn.com>
Sun, 6 Feb 2011 19:48:34 +0000 (19:48 +0000)
committerDavid Mitchell <davem@iabyn.com>
Sun, 6 Feb 2011 21:34:44 +0000 (21:34 +0000)
Commit 3e462cdc2087ddf90984010fabd80c30db92bfa0 provided a fix
for the  s/non-utf8/is-utf8/ case by upgrading TARG to UTF8 after the
match, but before the substitution. It used sv_utf8_upgrade() rather than
sv_utf8_upgrade_nomg(), so for example, with a tied variable, FETCH would
get called again, and all the char* pointers such as s would be left
dangling. If the length of the string was unchanged, the code wouldn't
notice this.

Fix by using the _nomg() variant, and by checking whether the string
has been reallocated

pp_hot.c
t/re/subst.t

index 5a920d4..7316c5a 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2185,12 +2185,13 @@ PP(pp_subst)
         * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
         */
        if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
-           const STRLEN new_len = sv_utf8_upgrade(TARG);
+           char * const orig_pvx =  SvPVX(TARG);
+           const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
 
            /* If the lengths are the same, the pattern contains only
             * invariants, can keep going; otherwise, various internal markers
             * could be off, so redo */
-           if (new_len != len) {
+           if (new_len != len || orig_pvx != SvPVX(TARG)) {
                goto setup_match;
            }
        }
index 8ea53a2..2a3e3fc 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 174 );
+plan( tests => 176 );
 
 # Stolen from re/ReTest.pl. Can't just use the file since it doesn't support
 # like() and it conflicts with test.pl
@@ -751,3 +751,21 @@ fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'a
   'Match vars reflect the last match after s/pat/$a{m|pat|}/ without /e'
  );
 }
+
+{
+    # a tied scalar that returned a plain string, got messed up
+    # when substituted with a UTF8 replacement string, due to
+    # magic getting called multiple times, and pointers now pointing
+    # to stale/freed strings
+    package FOO;
+    my $fc;
+    sub TIESCALAR { bless [ "abcdefgh" ] }
+    sub FETCH { $fc++; $_[0][0] }
+    sub STORE { $_[0][0] = $_[1] }
+
+    my $s;
+    tie $s, 'FOO';
+    $s =~ s/..../\x{101}/;
+    ::is($fc, 1, "tied UTF8 stuff FETCH count");
+    ::is("$s", "\x{101}efgh", "tied UTF8 stuff");
+}