Call get-magic once for CV-to-GV assignment

pp_rv2gv has already called get-magic, so pp_sassign should not do
it at all.

This is a regression from 5.8.8.

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 41c5d57..82c2460 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -512,6 +512,10 @@ C<setpgrp($foo)> used to be equivalent to C<($foo, setpgrp)>, because
 C<setpgrp> was ignoring its argument if there was just one.  Now it is
 equivalent to C<setpgrp($foo,0)>.
 
+=item *
+
+An assignment like C<*$tied = \&{"..."}> now calls FETCH only once.
+
 =back
 
 =head1 Known Problems

diff --git a/pp_hot.c b/pp_hot.c
index 758d334..6a22452 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -125,6 +125,8 @@ PP(pp_sassign)
        const U32 cv_type = SvTYPE(cv);
        const bool is_gv = isGV_with_GP(right);
        const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
+       STRLEN len = 0;
+       const char *nambeg = is_gv ? NULL : SvPV_nomg_const(right, len);
 
        if (!got_coderef) {
            assert(SvROK(cv));
@@ -135,7 +137,9 @@ PP(pp_sassign)
           context. */
        if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
            /* Is the target symbol table currently empty?  */
-           GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
+           GV * const gv = gv_fetchpvn_flags(
+               nambeg, len, SvUTF8(right)|GV_NOINIT, SVt_PVGV
+           );
            if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
                /* Good. Create a new proxy constant subroutine in the target.
                   The gv becomes a(nother) reference to the constant.  */
@@ -153,7 +157,9 @@ PP(pp_sassign)
        /* Need to fix things up.  */
        if (!is_gv) {
            /* Need to fix GV.  */
-           right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
+           right = MUTABLE_SV(gv_fetchpvn_flags(
+               nambeg, len, SvUTF8(right)|GV_ADD, SVt_PVGV
+           ));
        }
 
        if (!got_coderef) {

diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index f4527a1..adb02f3 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 218);
+    plan (tests => 219);
 }
 
 use strict;
@@ -205,6 +205,15 @@ $dummy  = &$var5        ; check_count '&{}';
 tie my $var8 => 'main', 'main';
 sub bolgy {}
 $var8->bolgy            ; check_count '->method';
+{
+    () = *swibble;
+    # This must be the name of an existing glob to trigger the maximum
+    # number of fetches in 5.14:
+    tie my $var9 => 'main', 'swibble';
+    no strict 'refs';
+    use constant glumscrin => 'shreggleboughet';
+    *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}';
+}
 
 ###############################################
 #        Tests for  $foo binop $foo           #