Define a CvREFCOUNTED_ANYSV flag

If this flag is set, then the CvXSUBANY(cv).any_sv pointer will have its
reference count decremented when the CV itself is freed. This is useful
for XS extensions that wish to store extra data in here. Without this
flag, such extensions have to resort to using magic with a 'free'
function to perform this work.

8 files changed, 89 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index c0ca549c13..e340d8d1aa 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4559,6 +4559,7 @@ ext/XS-APItest/t/copstash.t	test alloccopstash
 ext/XS-APItest/t/copyhints.t	test hv_copy_hints_hv() API
 ext/XS-APItest/t/customop.t	XS::APItest: tests for custom ops
 ext/XS-APItest/t/cv_name.t	test cv_name
+ext/XS-APItest/t/cv_refcounted_anysv.t	test CvREFCOUNTED_ANYSV
 ext/XS-APItest/t/delimcpy.t	test delimcpy
 ext/XS-APItest/t/eval-filter.t	Simple source filter/eval test
 ext/XS-APItest/t/exception.t	XS::APItest extension
diff --git a/cv.h b/cv.h
index ac2fb82e5a..e8a15c0e7d 100644
--- a/cv.h
+++ b/cv.h
@@ -134,6 +134,7 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CVf_LEXICAL	0x10000 /* Omit package from name */
 #define CVf_ANONCONST	0x20000 /* :const - create anonconst op */
 #define CVf_SIGNATURE   0x40000 /* CV uses a signature */
+#define CVf_REFCOUNTED_ANYSV 0x80000 /* CvXSUBANY().any_sv is refcounted */
 
 /* This symbol for optimised communication between toke.c and op.c: */
 #define CVf_BUILTIN_ATTRS	(CVf_NOWARN_AMBIGUOUS|CVf_LVALUE|CVf_ANONCONST)
@@ -227,6 +228,33 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvSIGNATURE_on(cv)	(CvFLAGS(cv) |= CVf_SIGNATURE)
 #define CvSIGNATURE_off(cv)	(CvFLAGS(cv) &= ~CVf_SIGNATURE)
 
+/*
+
+=for apidoc m|bool|CvREFCOUNTED_ANYSV|CV *cv
+
+If true, indicates that the C<CvXSUBANY(cv).any_sv> member contains an SV
+pointer whose reference count should be decremented when the CV itself is
+freed.  In addition, C<cv_clone()> will increment the reference count, and
+C<sv_dup()> will duplicate the entire pointed-to SV if this flag is set.
+
+Any CV that wraps an XSUB has an C<ANY> union that the XSUB function is free
+to use for its own purposes.  It may be the case that the code wishes to store
+an SV in the C<any_sv> member of this union.  By setting this flag, this SV
+reference will be properly reclaimed or duplicated when the CV itself is.
+
+=for apidoc m|void|CvREFCOUNTED_ANYSV_on|CV *cv
+
+Helper macro to turn on the C<CvREFCOUNTED_ANYSV> flag.
+
+=for apidoc m|void|CvREFCOUNTED_ANYSV_off|CV *cv
+
+Helper macro to turn off the C<CvREFCOUNTED_ANYSV> flag.
+*/
+
+#define CvREFCOUNTED_ANYSV(cv)          (CvFLAGS(cv) & CVf_REFCOUNTED_ANYSV)
+#define CvREFCOUNTED_ANYSV_on(cv)       (CvFLAGS(cv) |= CVf_REFCOUNTED_ANYSV)
+#define CvREFCOUNTED_ANYSV_off(cv)      (CvFLAGS(cv) &= ~CVf_REFCOUNTED_ANYSV)
+
 /* Back-compat */
 #ifndef PERL_CORE
 #  define CVf_METHOD            CVf_NOWARN_AMBIGUOUS
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 8563aa6c7f..1d30c60a82 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.24';
+our $VERSION = '1.25';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 5a3ecc330e..fc899929d8 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -7791,3 +7791,28 @@ test_bool_internals()
     OUTPUT:
         RETVAL
 
+MODULE = XS::APItest            PACKAGE = XS::APItest::CvREFCOUNTED_ANYSV
+
+UV
+test_CvREFCOUNTED_ANYSV()
+    CODE:
+    {
+        U32 failed = 0;
+
+        /* Doesn't matter what actual function we wrap because we're never
+         * actually going to call it. */
+        CV *cv = newXS("XS::APItest::(test-cv-1)", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
+        SV *sv = newSV(0);
+        CvXSUBANY(cv).any_sv = SvREFCNT_inc(sv);
+        CvREFCOUNTED_ANYSV_on(cv);
+        TEST_EXPR(SvREFCNT(sv) == 2);
+
+        SvREFCNT_dec((SV *)cv);
+        TEST_EXPR(SvREFCNT(sv) == 1);
+
+        SvREFCNT_dec(sv);
+
+        RETVAL = failed;
+    }
+    OUTPUT:
+        RETVAL
diff --git a/ext/XS-APItest/t/cv_refcounted_anysv.t b/ext/XS-APItest/t/cv_refcounted_anysv.t
new file mode 100644
index 0000000000..d754e01f72
--- /dev/null
+++ b/ext/XS-APItest/t/cv_refcounted_anysv.t
@@ -0,0 +1,18 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use XS::APItest;
+
+is(test_CvREFCOUNTED_ANYSV(), 0, "Bulk test internal CvREFCOUNTED_ANYSV API");
+
+# TODO: A test of operating via cv_clone()
+#   Unfortunately that's very difficult to arrange, because cv_clone() itself
+#   requires the CV to have a CvPADLIST, and that macro requires !CvISXSUB.
+#   We could instead go via cv_clone_into() but that isn't exposed outside of
+#   perl core.
+#   I don't know how to unit-test that one.
+
+done_testing;
diff --git a/pad.c b/pad.c
index f999cb324a..61bacc2376 100644
--- a/pad.c
+++ b/pad.c
@@ -457,8 +457,11 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
         Safefree(padlist);
         CvPADLIST_set(&cvbody, NULL);
     }
-    else if (CvISXSUB(&cvbody))
+    else if (CvISXSUB(&cvbody)) {
+        if (CvREFCOUNTED_ANYSV(&cvbody))
+            SvREFCNT_dec(CvXSUBANY(&cvbody).any_sv);
         CvHSCXT(&cvbody) = NULL;
+    }
     /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
 
 
@@ -2201,6 +2204,8 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
     if (UNLIKELY(CvISXSUB(proto))) {
         CvXSUB(cv)    = CvXSUB(proto);
         CvXSUBANY(cv) = CvXSUBANY(proto);
+        if (CvREFCOUNTED_ANYSV(cv))
+            SvREFCNT_inc(CvXSUBANY(cv).any_sv);
     }
     else {
         OP_REFCNT_LOCK;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 5120e3125b..8478362878 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -385,6 +385,13 @@ constructed to call the C<VERSION>, C<import> and C<unimport> methods
 as part of a C<use> statement and attribute application, nor when
 assigning to an C<:lvalue> subroutine.
 
+=item *
+
+A new CV flag C<CVf_REFCOUNTED_ANYSV> has been added, which indicates that the
+CV is an XSUB and stores an SV pointer in the C<CvXSUBANY.any_sv> union field.
+Perl core operations such as cloning or destroying the CV will maintain the
+reference count of the pointed-to SV, destroying it when required.
+
 =back
 
 =head1 Selected Bug Fixes
diff --git a/sv.c b/sv.c
index 6ffca6678c..3bda95ce7a 100644
--- a/sv.c
+++ b/sv.c
@@ -14633,6 +14633,9 @@ S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param)
                 } else if (CvCONST(dsv)) {
                     CvXSUBANY(dsv).any_ptr =
                         sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param);
+                } else if (CvREFCOUNTED_ANYSV(dsv)) {
+                    CvXSUBANY(dsv).any_sv =
+                        sv_dup_inc((const SV *)CvXSUBANY(dsv).any_sv, param);
                 }
                 assert(!CvSLABBED(dsv));
                 if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv));