For s///r, don't call SvPV_force() on the original value. Resolves #97954.

8ca8a454f60a417f optimised the implementation of s///r by avoiding an
unconditional copy of the original value. However, it introduced a behaviour
regression where if original value happened to be one of a few particular
types, it could be modified by being forced to a string using SvPV_force().
The substitution was (correctly) performed on a copy of this string.

diff --git a/pp_hot.c b/pp_hot.c
index 6abbf19..758d334 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2294,6 +2294,14 @@ PP(pp_subst)
     else {
        if (force_on_match) {
            force_on_match = 0;
+           if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+               /* I feel that it should be possible to avoid this mortal copy
+                  given that the code below copies into a new destination.
+                  However, I suspect it isn't worth the complexity of
+                  unravelling the C<goto force_it> for the small number of
+                  cases where it would be viable to drop into the copy code. */
+               TARG = sv_2mortal(newSVsv(TARG));
+           }
            s = SvPV_force(TARG, len);
            goto force_it;
        }

diff --git a/t/re/subst.t b/t/re/subst.t
index 09c9a47..ae0fe3a 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 176 );
+plan( tests => 188 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -758,3 +758,35 @@ fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'a
     ::is($fc, 1, "tied UTF8 stuff FETCH count");
     ::is("$s", "\x{101}efgh", "tied UTF8 stuff");
 }
+
+# RT #97954
+{
+    my $count;
+
+    sub bam::DESTROY {
+       --$count;
+    }
+
+    my $z_zapp = bless [], 'bam';
+    ++$count;
+
+    is($count, 1, '1 object');
+    is($z_zapp =~ s/.*/R/r, 'R', 'substitution happens');
+    is(ref $z_zapp, 'bam', 'still 1 object');
+    is($count, 1, 'still 1 object');
+    undef $z_zapp;
+    is($count, 0, 'now 0 objects');
+
+    $z_zapp = bless [], 'bam';
+    ++$count;
+
+    is($count, 1, '1 object');
+    like($z_zapp =~ s/./R/rg, qr/\AR{8,}\z/, 'substitution happens');
+    is(ref $z_zapp, 'bam', 'still 1 object');
+    is($count, 1, 'still 1 object');
+    undef $z_zapp;
+    is($count, 0, 'now 0 objects');
+}
+
+is(*bam =~ s/\*//r, 'main::bam', 'Can s///r a tyepglob');
+is(*bam =~ s/\*//rg, 'main::bam', 'Can s///rg a tyepglob');