From f62bf6966874271a2ee30112d3e4abdc9d18a7bb Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 8 Feb 2024 16:17:25 +1100
Subject: [PATCH] test a regexp doesn't COW an inappropriate SV

---
 MANIFEST                  |  1 +
 ext/XS-APItest/APItest.xs | 11 ++++++++++
 ext/XS-APItest/t/svcow.t  | 46 +++++++++++++++++++++++++++++++++++++++
 sv.c                      |  2 +-
 4 files changed, 59 insertions(+), 1 deletion(-)
 create mode 100644 ext/XS-APItest/t/svcow.t

diff --git a/MANIFEST b/MANIFEST
index c01186624586b..373af399a4dfb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5157,6 +5157,7 @@ ext/XS-APItest/t/sv_numeq.t			Test sv_numeq
 ext/XS-APItest/t/sv_streq.t			Test sv_streq
 ext/XS-APItest/t/svcat.t			Test sv_catpvn
 ext/XS-APItest/t/svcatpvf.t			Test sv_catpvf argument reordering
+ext/XS-APItest/t/svcow.t			Test COW
 ext/XS-APItest/t/sviscow.t			Test SvIsCOW
 ext/XS-APItest/t/svpeek.t			XS::APItest extension
 ext/XS-APItest/t/svpv.t				More generic SvPVbyte and SvPVutf8 tests
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 70b3a57ea2445..1d922998534d9 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3129,6 +3129,17 @@ sv_setsv_cow_hashkey_core()
 bool
 sv_setsv_cow_hashkey_notcore()
 
+void
+sv_grow(SV *sv, UV len)
+    CODE:
+        sv_force_normal(sv);
+        SvGROW(sv, len);
+
+void
+sv_force_normal(SV *sv)
+    CODE:
+        sv_force_normal(sv);
+
 void
 sv_set_deref(SV *sv, SV *sv2, int which)
     CODE:
diff --git a/ext/XS-APItest/t/svcow.t b/ext/XS-APItest/t/svcow.t
new file mode 100644
index 0000000000000..5bd927424613a
--- /dev/null
+++ b/ext/XS-APItest/t/svcow.t
@@ -0,0 +1,46 @@
+#!perl
+use strict;
+use warnings;
+use XS::APItest;
+use B;
+
+use Test::More tests => 11;
+
+{
+    # github #21877
+    # the regexp engine would COW an SV that had a large
+    # SvLEN() in cases where sv_setsv() wouldn't.
+    # This led to some surprises.
+    # - On cywgin this produced some strange performance problems
+    # - In general it meant the (large) buffer of the SV remained
+    #   allocated for longer than it otherwise would.
+    # Also, since the SV became CoW, further copies would also
+    # be CoW, for example, code like:
+    #
+    # while (<>) { # sv_getsv() currently allocates a large-ish buffer
+    #    /regex that (captures)/; # CoW large buffer
+    #    push @save, $_; # copy in @save still has that large buffer
+    # }
+    my $x = "Something\n" x 1000;
+    cmp_ok(length $x, '>=', 1250,
+           "need to be at least 1250 to be COWed");
+    sv_grow($x, 1_000_000);
+    my $ref = B::svref_2object(\$x);
+    cmp_ok($ref->LEN, '>=', 1_000_000,
+           "check we got it longer");
+    ok(!SvIsCOW($x), "not cow before");
+    is($ref->REFCNT, 1, "expected reference count");
+    ok($x =~ /me(.)hing/, "match");
+    ok(!SvIsCOW($x), "not cow after");
+
+    # make sure reasonable SVs are COWed
+    my $y = "Something\n" x 1000;
+    sv_force_normal($y);
+    cmp_ok(length $y, '>=', 1250,
+           "need to be at least 1250 to be COWed");
+    my $ref2 = B::svref_2object(\$y);
+    ok(!SvIsCOW($y), "not cow before");
+    is($ref2->REFCNT, 1, "expected reference count");
+    ok($y =~ /me(.)hing/, "match");
+    ok(SvIsCOW($y), "is cow after");
+}
diff --git a/sv.c b/sv.c
index 6bd32c89ab59d..45255ef2f158f 100644
--- a/sv.c
+++ b/sv.c
@@ -4915,7 +4915,7 @@ Perl_sv_setsv_cow(pTHX_ SV **pdsv, SV *ssv)
     if (!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"));
+                              "Fast copy on write: Sizes %zu/%zu not appropriate to COW\n", cur, len));
         return FALSE;
     }
     if (dsv) {