From 89553a3a4532658649b2983b6a855969c4ea6ef9 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 7 Feb 2024 15:40:18 +1100
Subject: [PATCH] sv_setsv_cow: apply the same tests we do for a normal COW
 copy

Previously if you had a successful match against an SV with a
SvLEN() large relative to the SvCUR() the regexp engine would
use sv_setsv_cow() to make a COW copy of the matched SV,
extending the life of the large allocation buffer.

A normal sv_setsv() normally didn't do such a COW copy, but the above
also marked the source SV as COW, so further copies of the SV
could even further extend the lifetime of the buffer, eg:

  while (<>) { # readline tends to make large SvLEN()
    /something/; # some sort of match
    push @save, $_; # with a successful match, the large $_ buffer
                    # survives until @save is released
  }

Fixes part of #21877
---
 regexec.c | 2 +-
 sv.c      | 7 +++++++
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/regexec.c b/regexec.c
index 0c0d38b73797..965a42db3fed 100644
--- a/regexec.c
+++ b/regexec.c
@@ -3547,7 +3547,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
 #endif
         {
 #ifdef PERL_ANY_COW
-        didnt_cow:
+        didnt_cow: ;
 #endif
             SSize_t min = 0;
             SSize_t max = strend - strbeg;
diff --git a/sv.c b/sv.c
index ac5337a33b9c..735775704bd4 100644
--- a/sv.c
+++ b/sv.c
@@ -4912,6 +4912,13 @@ Perl_sv_setsv_cow(pTHX_ SV **pdsv, SV *ssv)
                     sv_dump(dsv);
     }
 #endif
+    if (!SvIsCOW(ssv) &&
+        (!CHECK_COWBUF_THRESHOLD(cur, len)
+         || ! CHECK_COW_THRESHOLD(cur, len))) {
+        DEBUG_C(PerlIO_printf(Perl_debug_log,
+                              "Fast copy on write: Sizes not appropriate to COW\n"));
+        return FALSE;
+    }
     if (dsv) {
         if (SvTHINKFIRST(dsv))
             sv_force_normal_flags(dsv, SV_COW_DROP_PV);