protect CvSTASH weakref with backrefs

Each CV usually has a pointer, CvSTASH, back to the stash that it was
complied in. This pointer isn't reference counted, to avoid loops. Which
can leave it dangling if the stash is deleted.

There is already protection for the similar GvSTASH field in GVs: the
stash has an array of backrefs, xhv_backreferences, pointing to the GVs
whose GvSTASHes point to it, and which is used to zero all the GvSTASH
fields should the stash be deleted.

All this patch does is also add the CVs with CvSTASH to that stash's
backref list too.

10 files changed, 68 insertions, 17 deletions

diff --git a/embed.fnc b/embed.fnc
index a1e8ecdcb7..295b6b2fc7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1852,7 +1852,7 @@ s	|SV*	|pm_description	|NN const PMOP *pm
 s	|SV*	|save_scalar_at	|NN SV **sptr|const U32 flags
 #endif
 
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 : Used in gv.c
 po	|void	|sv_add_backref	|NN SV *const tsv|NN SV *const sv
 #endif
@@ -1862,12 +1862,12 @@ po	|void	|sv_add_backref	|NN SV *const tsv|NN SV *const sv
 poM	|int	|sv_kill_backrefs	|NN SV *const sv|NN AV *const av
 #endif
 
+pX	|void	|sv_del_backref	|NN SV *const tsv|NN SV *const sv
 #if defined(PERL_IN_SV_C)
 nsR	|char *	|uiv_2buf	|NN char *const buf|const IV iv|UV uv|const int is_uv|NN char **const peob
 s	|void	|sv_unglob	|NN SV *const sv
 s	|void	|not_a_number	|NN SV *const sv
 s	|I32	|visit		|NN SVFUNC_t f|const U32 flags|const U32 mask
-s	|void	|sv_del_backref	|NN SV *const tsv|NN SV *const sv
 sR	|SV *	|varname	|NULLOK const GV *const gv|const char gvtype \
 				|PADOFFSET targ|NULLOK const SV *const keyname \
 				|I32 aindex|int subscript_type
diff --git a/embed.h b/embed.h
index f62a803a7a..a425f46853 100644
--- a/embed.h
+++ b/embed.h
@@ -1558,17 +1558,19 @@
 #define save_scalar_at		S_save_scalar_at
 #endif
 #endif
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 #endif
 #if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C)
 #endif
+#ifdef PERL_CORE
+#define sv_del_backref		Perl_sv_del_backref
+#endif
 #if defined(PERL_IN_SV_C)
 #ifdef PERL_CORE
 #define uiv_2buf		S_uiv_2buf
 #define sv_unglob		S_sv_unglob
 #define not_a_number		S_not_a_number
 #define visit			S_visit
-#define sv_del_backref		S_sv_del_backref
 #define varname			S_varname
 #endif
 #  ifdef DEBUGGING
@@ -4004,7 +4006,7 @@
 #define save_scalar_at(a,b)	S_save_scalar_at(aTHX_ a,b)
 #endif
 #endif
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 #ifdef PERL_CORE
 #endif
 #endif
@@ -4012,13 +4014,15 @@
 #ifdef PERL_CORE
 #endif
 #endif
+#ifdef PERL_CORE
+#define sv_del_backref(a,b)	Perl_sv_del_backref(aTHX_ a,b)
+#endif
 #if defined(PERL_IN_SV_C)
 #ifdef PERL_CORE
 #define uiv_2buf		S_uiv_2buf
 #define sv_unglob(a)		S_sv_unglob(aTHX_ a)
 #define not_a_number(a)		S_not_a_number(aTHX_ a)
 #define visit(a,b,c)		S_visit(aTHX_ a,b,c)
-#define sv_del_backref(a,b)	S_sv_del_backref(aTHX_ a,b)
 #define varname(a,b,c,d,e,f)	S_varname(aTHX_ a,b,c,d,e,f)
 #endif
 #  ifdef DEBUGGING
diff --git a/global.sym b/global.sym
index db01b92891..cfdb93dd9b 100644
--- a/global.sym
+++ b/global.sym
@@ -752,6 +752,7 @@ Perl_sv_nounlocking
 Perl_nothreadhook
 Perl_Slab_Alloc
 Perl_Slab_Free
+Perl_sv_del_backref
 Perl_sv_setsv_flags
 Perl_sv_catpvn_flags
 Perl_sv_catsv_flags
diff --git a/gv.c b/gv.c
index 7f32ec6708..fce31b7af6 100644
--- a/gv.c
+++ b/gv.c
@@ -269,6 +269,8 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 	CvGV(cv) = gv;
 	CvFILE_set_from_cop(cv, PL_curcop);
 	CvSTASH(cv) = PL_curstash;
+	if (PL_curstash)
+	    Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
 	if (proto) {
 	    sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 			    SV_HAS_TRAILING_NUL);
@@ -742,6 +744,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          * pass along the same data via some unused fields in the CV
          */
         CvSTASH(cv) = stash;
+	if (stash)
+	    Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv));
         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
         SvCUR_set(cv, len);
         return gv;
diff --git a/hv.c b/hv.c
index f94d6d45dd..b47b83a185 100644
--- a/hv.c
+++ b/hv.c
@@ -1709,7 +1709,7 @@ S_hfreeentries(pTHX_ HV *hv)
 	    HE *entry;
             struct mro_meta *meta;
 	    struct xpvhv_aux * const iter = HvAUX(hv);
-	    SV *const av = iter->xhv_backreferences;
+	    AV *const av = iter->xhv_backreferences;
 
 	    if (av) {
 		Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
diff --git a/op.c b/op.c
index d832c997de..bd7b84bd36 100644
--- a/op.c
+++ b/op.c
@@ -5844,6 +5844,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
 	    if (PERLDB_INTER)/* Advice debugger on the new sub. */
 	      ++PL_sub_generation;
+	    if (CvSTASH(cv))
+		sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
 	}
 	else {
 	    /* Might have had built-in attributes applied -- propagate them. */
@@ -5872,6 +5874,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	CvGV(cv) = gv;
 	CvFILE_set_from_cop(cv, PL_curcop);
 	CvSTASH(cv) = PL_curstash;
+	if (PL_curstash)
+	    Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
     }
     if (attrs) {
 	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
diff --git a/pad.c b/pad.c
index e8ba139434..92f4041398 100644
--- a/pad.c
+++ b/pad.c
@@ -1573,6 +1573,8 @@ Perl_cv_clone(pTHX_ CV *proto)
 #endif
     CvGV(cv)		= CvGV(proto);
     CvSTASH(cv)		= CvSTASH(proto);
+    if (CvSTASH(cv))
+	Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
     OP_REFCNT_LOCK;
     CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;
diff --git a/proto.h b/proto.h
index 688a2f03a9..727d3d5b0e 100644
--- a/proto.h
+++ b/proto.h
@@ -5735,7 +5735,7 @@ STATIC SV*	S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
 
 #endif
 
-#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C)
+#if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 PERL_CALLCONV void	Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
@@ -5753,6 +5753,12 @@ PERL_CALLCONV int	Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 
 #endif
 
+PERL_CALLCONV void	Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DEL_BACKREF	\
+	assert(tsv); assert(sv)
+
 #if defined(PERL_IN_SV_C)
 STATIC char *	S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
 			__attribute__warn_unused_result__
@@ -5776,12 +5782,6 @@ STATIC I32	S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 #define PERL_ARGS_ASSERT_VISIT	\
 	assert(f)
 
-STATIC void	S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
-			__attribute__nonnull__(pTHX_1)
-			__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_DEL_BACKREF	\
-	assert(tsv); assert(sv)
-
 STATIC SV *	S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type)
 			__attribute__warn_unused_result__;
 
diff --git a/sv.c b/sv.c
index 504bc1537d..c841dc90ec 100644
--- a/sv.c
+++ b/sv.c
@@ -5363,8 +5363,8 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
  * with the SV we point to.
  */
 
-STATIC void
-S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
 {
     dVAR;
     AV *av = NULL;
@@ -5429,6 +5429,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 		SV *const referrer = *svp;
 		if (SvWEAKREF(referrer)) {
 		    /* XXX Should we check that it hasn't changed? */
+		    assert(SvROK(referrer));
 		    SvRV_set(referrer, 0);
 		    SvOK_off(referrer);
 		    SvWEAKREF_off(referrer);
@@ -5439,6 +5440,11 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
 		    assert(GvSTASH(referrer));
 		    assert(GvSTASH(referrer) == (const HV *)sv);
 		    GvSTASH(referrer) = 0;
+		} else if (SvTYPE(referrer) == SVt_PVCV) {
+		    /* You lookin' at me?  */
+		    assert(CvSTASH(referrer));
+		    assert(CvSTASH(referrer) == (const HV *)sv);
+		    CvSTASH(referrer) = 0;
 		} else {
 		    Perl_croak(aTHX_
 			       "panic: magic_killbackrefs (flags=%"UVxf")",
@@ -5763,6 +5769,10 @@ Perl_sv_clear(pTHX_ register SV *const sv)
     case SVt_PVCV:
     case SVt_PVFM:
 	cv_undef(MUTABLE_CV(sv));
+	/* If we're in a stash, we don't own a reference to it. However it does
+	   have a back reference to us, which needs to be cleared.  */
+	if ((stash = CvSTASH(sv)))
+	    sv_del_backref(MUTABLE_SV(stash), sv);
 	goto freescalar;
     case SVt_PVHV:
 	if (PL_last_swash_hv == (const HV *)sv) {
@@ -11342,9 +11352,22 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 		if (!(param->flags & CLONEf_COPY_STACKS)) {
 		    CvDEPTH(dstr) = 0;
 		}
+		/*FALLTHROUGH*/
 	    case SVt_PVFM:
 		/* NOTE: not refcounted */
 		CvSTASH(dstr)	= hv_dup(CvSTASH(dstr), param);
+		if(param->flags & CLONEf_JOIN_IN && CvSTASH(dstr)) {
+		    const HEK * const hvname
+		     = HvNAME_HEK(CvSTASH(dstr));
+		    if( hvname
+		     && CvSTASH(dstr) == gv_stashpvn(
+			 HEK_KEY(hvname), HEK_LEN(hvname), 0
+			)
+		      )
+			Perl_sv_add_backref(
+			 aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr
+			);
+		}
 		OP_REFCNT_LOCK;
 		if (!CvISXSUB(dstr))
 		    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
diff --git a/t/op/stash.t b/t/op/stash.t
index 8eb50515cf..676c26c8c2 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 31 );
+plan( tests => 32 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -168,4 +168,17 @@ SKIP: {
         {},
         "no segfault with overload/deleted stash entry [#58530]",
     );
+
+    # CvSTASH should be null on a nmed sub if the stash has been deleted
+    {
+	package FOO;
+	sub foo {}
+	my $rfoo = \&foo;
+	package main;
+	delete $::{'FOO::'};
+	my $cv = B::svref_2object($rfoo);
+	# XXX is there a better way of testing for NULL ?
+	my $stash = $cv->STASH;
+	like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
+    }
 }