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.

diff --git a/scope.c b/scope.c
index f96aa45..3d50932 100644 (file)
--- 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 4373eac..f1d1929 100644 (file)
--- 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 8570efb..35d295e 100644 (file)
--- 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 cbbd655..495e12f 100644 (file)
--- 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" }