[perl #72740]: Blead breaks LEMBARK/LinkedList-Single-0.99.1.tar.gz

f7461760003db2ce68155c97ea6c1658e96fcd27 improved the PL_check hook for
bareword subs, but broke the above module. This is Zefram's followup:

The issue is that speculative function lookups were leaving detritus
consisting of empty GVs in the stash.  These didn't affect normal
functioning, but code that looks inside the stash could see them, and
code that makes unreliable assumptions about the format of the stash
can be broken.  This is the same general mode of failure that we saw
with namespace::clean.

LinkedList-Single's failing test was using direct stash access poorly,
in a way that made for a poor test, quite apart from making too many
assumptions about stash structure.  In the latest version of the package,
0.99.6, the test has been changed to a much better form, which actually
tests what it meant to and incidentally doesn't read the stash at all.

Although they don't affect normal functioning, the empty GVs shouldn't
be there.  It's much like the upgraded constant subs, which we concluded
ought to be downgraded when the upgraded form is no longer required,
in order to save memory.  The solution here is similar: delete the
empty GV when it is detected that a real GV is no longer required.
The present patch does this at the same time as checking for constant-sub
downgradability.

diff --git a/gv.c b/gv.c
index dfcb376..becd1e9 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2364,13 +2364,19 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
 /*
 =for apidoc gv_try_downgrade
 
-If C<gv> is a typeglob containing only a constant sub, and is only
-referenced from its package, and both the typeglob and the sub are
-sufficiently ordinary, replace the typeglob (in the package) with a
-placeholder that more compactly represents the same thing.  This is meant
-to be used when a placeholder has been upgraded, most likely because
-something wanted to look at a proper code object, and it has turned out
-to be a constant sub to which a proper reference is no longer required.
+If the typeglob C<gv> can be expressed more succinctly, by having
+something other than a real GV in its place in the stash, replace it
+with the optimised form.  Basic requirements for this are that C<gv>
+is a real typeglob, is sufficiently ordinary, and is only referenced
+from its package.  This function is meant to be used when a GV has been
+looked up in part to see what was there, causing upgrading, but based
+on what was found it turns out that the real GV isn't required after all.
+
+If C<gv> is a completely empty typeglob, it is deleted from the stash.
+
+If C<gv> is a typeglob containing only a sufficiently-ordinary constant
+sub, the typeglob is replaced with a scalar-reference placeholder that
+more compactly represents the same thing.
 
 =cut
 */
@@ -2383,12 +2389,19 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
     HEK *namehek;
     SV **gvp;
     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
-    if (SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
+    if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
            !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
            isGV_with_GP(gv) && GvGP(gv) &&
-           GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+           !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
            !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
-           GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(gv)) &&
+           GvEGV(gv) == gv && (stash = GvSTASH(gv))))
+       return;
+    cv = GvCV(gv);
+    if (!cv) {
+       HEK *gvnhek = GvNAME_HEK(gv);
+       (void)hv_delete(stash, HEK_KEY(gvnhek),
+           HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
+    } else if (GvMULTI(gv) && cv &&
            !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
            CvSTASH(cv) == stash && CvGV(cv) == gv &&
            CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&

diff --git a/t/op/gv.t b/t/op/gv.t
index 6f16ce2..382e3f0 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 
 require './test.pl';
-plan( tests => 182 );
+plan( tests => 188 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -592,6 +592,28 @@ foreach my $type (qw(integer number string)) {
     );
 }
 
+# [perl #72740] - indirect object syntax, heuristically imputed due to
+# the non-existence of a function, should not cause a stash entry to be
+# created for the non-existent function.
+{
+       package RT72740a;
+       my $f = bless({}, RT72740b);
+       sub s1 { s2 $f; }
+       our $s4;
+       sub s3 { s4 $f; }
+}
+{
+       package RT72740b;
+       sub s2 { "RT72740b::s2" }
+       sub s4 { "RT72740b::s4" }
+}
+ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
+ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
+ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
+ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
+is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
+is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
+
 __END__
 Perl
 Rules