Clear method caches when unwinding local *foo=sub{}

local *foo=sub{} is done in two stages:

• First the local *foo localises the GP (the glob pointer, or list of
  slots), setting a flag on the GV.
• Then scalar assignment sees the flag on the GV on the LHS and loca-
  lises a single slot.

The slot localisation only stores on the savestack a pointer into the
GP struct and the old value.  There is no reference to the GV.

To restore a method properly, we have to have a reference to the GV
when the slot localisation is undone.

So in this commit I have added a new save type, SAVEt_GVSLOT.  It is
like SAVEt_GENERIC_SV, except it pushes the GV as well.  Currently
it is used only for CVs, but I will need it for HVs and maybe
AVs as well.

It is possible for the unwinding of the slot localisation to affect
only a GV other than the one that is pushed, if glob assignments have
taken place since the local *foo.  So we have to check whether the
pointer is inside the GP and use PL_sub_generation++ if it is not.

4 files changed, 43 insertions, 2 deletions

diff --git a/scope.c b/scope.c
index f96aa45ad3..3d50932bee 100644
--- a/scope.c
+++ b/scope.c
@@ -783,6 +783,23 @@ Perl_leave_scope(pTHX_ I32 base)
 	    SvREFCNT_dec(sv);
 	    SvREFCNT_dec(value);
 	    break;
+	case SAVEt_GVSLOT:			/* any slot in GV */
+	    value = MUTABLE_SV(SSPOPPTR);
+	    ptr = SSPOPPTR;
+	    gv = MUTABLE_GV(SSPOPPTR);
+	    hv = GvSTASH(gv);
+	    if (hv && HvENAME(hv) && (
+		    (value && SvTYPE(value) == SVt_PVCV)
+		 || (*(SV **)ptr && SvTYPE(*(SV**)ptr) == SVt_PVCV)
+	       ))
+	    {
+		if ((char *)ptr < (char *)GvGP(gv)
+		 || (char *)ptr > (char *)GvGP(gv) + sizeof(struct gp)
+		 || GvREFCNT(gv) > 1)
+		    PL_sub_generation++;
+		else mro_method_changed_in(hv);
+	    }
+	    goto restore_svp;
 	case SAVEt_AV:				/* array reference */
 	    av = MUTABLE_AV(SSPOPPTR);
 	    gv = MUTABLE_GV(SSPOPPTR);
diff --git a/scope.h b/scope.h
index 4373eacb3c..f1d1929be7 100644
--- a/scope.h
+++ b/scope.h
@@ -59,6 +59,7 @@
 #define SAVEt_GVSV		49
 #define SAVEt_FREECOPHH		50
 #define SAVEt_CLEARPADRANGE	51
+#define SAVEt_GVSLOT		52
 
 #define SAVEf_SETMAGIC		1
 #define SAVEf_KEEPOLDELEM	2
diff --git a/sv.c b/sv.c
index 8570efb401..35d295e7d5 100644
--- a/sv.c
+++ b/sv.c
@@ -3787,7 +3787,23 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 		    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
 		}
 	    }
-	    SAVEGENERICSV(*location);
+	    /* SAVEt_GVSLOT takes more room on the savestack and has more
+	       overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
+	       leave_scope needs access to the GV so it can reset method
+	       caches.  We must use SAVEt_GVSLOT whenever the type is
+	       SVt_PVCV, even if the stash is anonymous, as the stash may
+	       gain a name somehow before leave_scope. */
+	    if (stype == SVt_PVCV) {
+		/* There is no save_pushptrptrptr.  Creating it for this
+		   one call site would be overkill.  So inline the ss push
+		   routines here. */
+		SSCHECK(4);
+		SSPUSHPTR(dstr);
+		SSPUSHPTR(location);
+		SSPUSHPTR(SvREFCNT_inc(*location));
+		SSPUSHUV(SAVEt_GVSLOT);
+	    }
+	    else SAVEGENERICSV(*location);
 	}
 	dref = *location;
 	if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
@@ -12610,6 +12626,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 	    ptr = POPPTR(ss,ix);
 	    TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
 	    break;
+        case SAVEt_GVSLOT:		/* any slot in GV */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    break;
         case SAVEt_HV:				/* hash reference */
         case SAVEt_AV:				/* array reference */
 	    sv = (const SV *) POPPTR(ss,ix);
diff --git a/t/mro/method_caching.t b/t/mro/method_caching.t
index cbbd655f39..495e12fddc 100644
--- a/t/mro/method_caching.t
+++ b/t/mro/method_caching.t
@@ -37,7 +37,6 @@ my @testsubs = (
     sub { is(MCTest::Derived->foo(0), 5); },
     sub { { local *MCTest::Base::can = sub { "tomatoes" };
             MCTest::Derived->can(0); }
-          local $::TODO = " ";
           is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
               'removing method when unwinding local *method=sub{}'); },
     sub { sub peas { "peas" }