This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(perl #134072) allow \&foo = \&bar to work in main::
authorTony Cook <tony@develop-help.com>
Wed, 15 May 2019 05:59:49 +0000 (15:59 +1000)
committerTony Cook <tony@develop-help.com>
Wed, 12 Jun 2019 01:52:08 +0000 (11:52 +1000)
subs in main:: are stored as a RV referring to a CV as a space
optimization, but the pp_refassign code expected to find a glob,
which made the assignment a no-op.

Fix this by upgrading the reference to a glob in the refassign check
function.

Note that this would be an issue in other packages if 1e2cfe157ca
was reverted (allowing the space savings in other packages too.)

op.c
t/op/lvref.t

diff --git a/op.c b/op.c
index f63eead..6ad1923 100644 (file)
--- a/op.c
+++ b/op.c
@@ -12462,7 +12462,16 @@ Perl_ck_refassign(pTHX_ OP *o)
        OP * const kid = cUNOPx(kidparent)->op_first;
        o->op_private |= OPpLVREF_CV;
        if (kid->op_type == OP_GV) {
+            SV *sv = (SV*)cGVOPx_gv(kid);
            varop = kidparent;
+            if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+                /* a CVREF here confuses pp_refassign, so make sure
+                   it gets a GV */
+                CV *const cv = (CV*)SvRV(sv);
+                SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
+                (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
+                assert(SvTYPE(sv) == SVt_PVGV);
+            }
            goto detach_and_stack;
        }
        if (kid->op_type != OP_PADCV)   goto bad;
index 3d5e952..3991a53 100644 (file)
@@ -1,10 +1,11 @@
+#!perl
 BEGIN {
     chdir 't';
     require './test.pl';
     set_up_inc("../lib");
 }
 
-plan 164;
+plan 167;
 
 eval '\$x = \$y';
 like $@, qr/^Experimental aliasing via reference not enabled/,
@@ -291,6 +292,18 @@ package CodeTest {
   my sub bs;
   \(&cs) = expect_list_cx;
   is \&cs, \&ThatSub, '\(&statesub)';
+
+  package main {
+    # this is only a problem in main:: due to 1e2cfe157ca
+    sub sx { "x" }
+    sub sy { "y" }
+    is sx(), "x", "check original";
+    my $temp = \&sx;
+    \&sx = \&sy;
+    is sx(), "y", "aliased";
+    \&sx = $temp;
+    is sx(), "x", "and restored";
+  }
 }
 
 # Mixed List Assignments