test a regexp doesn't COW an inappropriate SV

Author: tonycoz

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

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:

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");
+}

sv.c

@@ -4916,7 +4916,7 @@ Perl_sv_setsv_cow(pTHX_ SV **pdsv, SV *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"));
+                              "Fast copy on write: Sizes %zu/%zu not appropriate to COW\n", cur, len));
         return FALSE;
     }
     if (dsv) {