Reset method caches when GPs are shared

The new MRO stuff in 5.10 made PL_sub_generation++ mostly unnecessary,
and almost all uses of it were replaced with mro_method_changed_in.

There is only one problem: That doesn’t actually work properly.  After
glob-to-glob assignment (*foo = *bar), both globs share the same GP
(glob pointer, or list of glob slots).  But there is no list of GVs
associated with any GP.  So there is no way, given a GV whose GP
is shared, to find out what other classes might need their method
caches reset.

sub B::b { "b" }
*A::b = *B::b;
@C::ISA = "A";
print C->b, "\n";  # should print "b"
eval 'sub B::b { "c" }';
print C->b, "\n";  # should print "c"
__END__

$ perl5.8.9 foo
b
c
$ perl5.10.0 foo
b
b

And it continues up to 5.16.x.

If a GP is shared, then those places where mro_method_changed_in is
called after the GP has been modified must do PL_sub_generation++
instead if the GP is shared, which can be detected through its refer-
ence count.

diff --git a/gv.h b/gv.h
index 8e09340..1e17f35 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -264,6 +264,13 @@ Return the CV from the GV.
 #define gv_autoload4(stash, name, len, method) \
        gv_autoload_pvn(stash, name, len, !!(method))
 #define newGVgen(pack)  newGVgen_flags(pack, 0)
+#define gv_method_changed(gv)              \
+    (                                       \
+       assert_(isGV_with_GP(gv))             \
+       GvREFCNT(gv) > 1                       \
+           ? (void)++PL_sub_generation         \
+           : mro_method_changed_in(GvSTASH(gv)) \
+    )
 
 #define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV)
 #define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)

diff --git a/op.c b/op.c
index 0bc9021..c95c8ea 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7548,7 +7548,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            GvCVGEN(gv) = 0;
            if (HvENAME_HEK(GvSTASH(gv)))
                /* sub Foo::bar { (shift)+1 } */
-               mro_method_changed_in(GvSTASH(gv));
+               gv_method_changed(gv);
        }
     }
     if (!CvGV(cv)) {
@@ -7872,7 +7872,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                 GvCV_set(gv,cv);
                 GvCVGEN(gv) = 0;
                 if (HvENAME_HEK(GvSTASH(gv)))
-                    mro_method_changed_in(GvSTASH(gv)); /* newXS */
+                    gv_method_changed(gv); /* newXS */
             }
         }
         if (!name)
@@ -7906,7 +7906,7 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake)
     GvCV_set(gv, cv);
     GvCVGEN(gv) = 0;
     if (!fake && HvENAME_HEK(GvSTASH(gv)))
-       mro_method_changed_in(GvSTASH(gv));
+       gv_method_changed(gv);
     CvGV_set(cv, gv);
     CvFILE_set_from_cop(cv, PL_curcop);
     CvSTASH_set(cv, PL_curstash);

diff --git a/scope.c b/scope.c
index cd342d0..8eca725 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -861,7 +861,7 @@ Perl_leave_scope(pTHX_ I32 base)
            GvGP_set(gv, (GP*)ptr);
             /* putting a method back into circulation ("local")*/
            if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvENAME_get(hv))
-                mro_method_changed_in(hv);
+                gv_method_changed(gv);
            SvREFCNT_dec(gv);
            break;
        case SAVEt_FREESV:

diff --git a/sv.c b/sv.c
index a2d0cbc..8570efb 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3823,7 +3823,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            }
            GvCVGEN(dstr) = 0; /* Switch off cacheness. */
            GvASSUMECV_on(dstr);
-           if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+           if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
        }
        *location = SvREFCNT_inc_simple_NN(sref);
        if (import_flag && !(GvFLAGS(dstr) & import_flag)

diff --git a/t/mro/method_caching.t b/t/mro/method_caching.t
index 733193a..d574cc9 100644 (file)
--- a/t/mro/method_caching.t
+++ b/t/mro/method_caching.t
@@ -1,6 +1,7 @@
 #!./perl
 
 use strict;
+no strict 'refs'; # we do a lot of this
 use warnings;
 no warnings 'redefine'; # we do a lot of this
 no warnings 'prototype'; # we do a lot of this
@@ -57,6 +58,37 @@ my @testsubs = (
     sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
     sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo },
     sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); },
+
+    # Redefining through a glob alias
+    sub { *A = *{'MCTest::Base::foo'}; eval 'sub A { $_[1]+19 }';
+          is(MCTest::Derived->foo(0), 19,
+            'redefining sub through glob alias via decl'); },
+    sub { SKIP: {
+              skip_if_miniperl("no XS"); require XS::APItest;
+              *A = *{'MCTest::Base::foo'};
+              XS::APItest::newCONSTSUB(\%main::, "A", 0, 20);
+              is (MCTest::Derived->foo(0), 20,
+                  'redefining sub through glob alias via newXS');
+        } },
+    sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'};
+          eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96};
+                 MCTest::Derived->foo };
+          ()=\&A;
+          eval { MCTest::Derived->foo };
+          like($@, qr/Undefined subroutine/,
+            'redefining sub through glob alias via stub vivification'); },
+    sub { *A = *{'MCTest::Base::foo'};
+          local *A = sub { 21 };
+          is(MCTest::Derived->foo, 21,
+            'redef sub through glob alias via local cv-to-glob assign'); },
+    sub { *A = *{'MCTest::Base::foo'};
+          eval 'sub MCTest::Base::foo { 22 }';
+          { local *A = sub { 23 }; MCTest::Derived->foo }
+          is(MCTest::Derived->foo, 22,
+            'redef sub through glob alias via localisation unwinding'); },
+    sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 };
+          is(MCTest::Derived->foo(0), 24,
+            'redefining sub through glob alias via cv-to-glob assign'); },
 );
 
 plan(tests => scalar(@testsubs));