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.

1 files changed, 33 insertions, 1 deletions

diff --git a/t/re/subst.t b/t/re/subst.t
index 09c9a471f2..ae0fe3a441 100644
--- 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');