Fix string corruption with (??{}) and PERL_NO_COW

Commit 9ffd39ab75, which allowed PADTMPs’ string buffers to be stolen,
caused "$a$b" =~ /(??{})/ to cause string corruption with match varia-
bles on some systems, because the buffer from "$a$b"’s return value
was being stolen when ‘copied’ into a new $_ for the code block.

The string copy necessary for $& and $1 to work would happen only
after the code block’s $_ had been freed, and consequently after the
string buffer had been freed.

Whether this would cause observable buggy behaviour (as opposed to
things only memory tools like valgrind would catch) depended on
whether the malloc implementation would modify the string immediately
when freeing it.

Dave Mitchell observed in <20131218113448.GN2490@iabyn.com> that tests
were failing under -DPERL_NO_COW.  The added test will also fail (for
me at least) under copy-on-write, because the string is long enough to
favour swiping the buffer.  (It happens for me only on Linux, not Dar-
win, incidentally.)

Copying the string with _nosteal fixes the problem.

diff --git a/regexec.c b/regexec.c
index 7f6acb2..fab9009 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2409,7 +2409,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
            Not newSVsv, either, as it does not COW.
         */
         reginfo->sv = newSV(0);
            Not newSVsv, either, as it does not COW.
         */
         reginfo->sv = newSV(0);

-        sv_setsv(reginfo->sv, sv);
+        SvSetSV_nosteal(reginfo->sv, sv);

         SAVEFREESV(reginfo->sv);
     }
 
         SAVEFREESV(reginfo->sv);
     }
 

diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index 96614d2..551788b 100644 (file)
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
 }
 
 

-plan tests => 524;  # Update this when adding/deleting tests.
+plan tests => 525;  # Update this when adding/deleting tests.

 
 run_tests() unless caller;
 
 
 run_tests() unless caller;
 


@@ -1215,6 +1215,13 @@ sub run_tests {
        is "@matchsticks", "1 ", 'qr magic is not cached on refs';
     }
 
        is "@matchsticks", "1 ", 'qr magic is not cached on refs';
     }
 

+    {
+       my ($foo, $bar) = ("foo"x1000, "bar"x1000);
+       "$foo$bar" =~ /(??{".*"})/;
+       is "$&", "foo"x1000 . "bar"x1000,
+           'padtmp swiping does not affect "$a$b" =~ /(??{})/'
+    }
+

 } # End of sub run_tests
 
 1;
 } # End of sub run_tests
 
 1;