Fix crash in leave_scope when my sub has CvGV

Sub declaration can reuse an existing stub.  So it is possible to define
a package sub using a stub that was originally lexical.  Hence,
leave_scope needs to take into account that a my-sub may not have a
name hek any more.

diff --git a/gv.c b/gv.c
index e4d6aca..7cc2c1e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -232,7 +232,10 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
            sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
        }
     }
-    else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
+    else if ((hek = CvNAME_HEK(cv))) {
+       unshare_hek(hek);
+       CvNAMED_off(cv);
+    }
 
     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
     assert(!CvCVGV_RC(cv));

diff --git a/scope.c b/scope.c
index 5cfd78b..66589ab 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1029,7 +1029,15 @@ Perl_leave_scope(pTHX_ I32 base)
                         break;
                     case SVt_PVCV:
                     {
-                        HEK * const hek = CvNAME_HEK((CV *)sv);
+                        HEK *hek =
+                           CvNAME_HEK((CV *)(
+                             CvNAMED(sv)
+                               ? sv
+                               : mg_find(PadlistNAMESARRAY(
+                                               CvPADLIST(find_runcv(NULL))
+                                         )[svp-PL_curpad],
+                                         PERL_MAGIC_proto
+                                        )->mg_obj));
                         assert(hek);
                         share_hek_hek(hek);
                         cv_undef((CV *)sv);
@@ -1059,9 +1067,15 @@ Perl_leave_scope(pTHX_ I32 base)
                         *svp = newSV_type(SVt_PVCV);
 
                         /* Share name */
-                        assert(CvNAMED(sv));
                         CvNAME_HEK_set(*svp,
-                            share_hek_hek(CvNAME_HEK((CV *)sv)));
+                            share_hek_hek(CvNAME_HEK((CV *)(
+                             CvNAMED(sv)
+                               ? sv
+                               : mg_find(PadlistNAMESARRAY(
+                                               CvPADLIST(find_runcv(NULL))
+                                         )[svp-PL_curpad],
+                                         PERL_MAGIC_proto
+                                        )->mg_obj))));
                         break;
                     }
                     default:   *svp = newSV(0);                break;

diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index 774357b..8ff4927 100644 (file)
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -7,7 +7,7 @@ BEGIN {
     *bar::is = *is;
     *bar::like = *like;
 }
-plan 124;
+plan 127;
 
 # -------------------- Errors with feature disabled -------------------- #
 
@@ -327,6 +327,13 @@ like runperl(
   package o { use overload qr => \&quire }
   ok "quires" =~ bless([], o::), 'state sub used as overload method';
 }
+{
+  state sub foo;
+  *cvgv = \&foo;
+  local *cvgv2 = *cvgv;
+  eval 'sub cvgv2 {42}'; # uses the stub already present
+  is foo, 42, 'defining state sub body via package sub declaration';
+}
 
 # -------------------- my -------------------- #
 
@@ -634,6 +641,22 @@ like runperl(
   package mo { use overload qr => \&quire }
   ok "quires" =~ bless([], mo::), 'my sub used as overload method';
 }
+{
+  my sub foo;
+  *mcvgv = \&foo;
+  local *mcvgv2 = *mcvgv;
+  eval 'sub mcvgv2 {42}'; # uses the stub already present
+  is foo, 42, 'defining my sub body via package sub declaration';
+}
+{
+  my sub foo;
+  *mcvgv3 = \&foo;
+  local *mcvgv4 = *mcvgv3;
+  eval 'sub mcvgv4 {42}'; # uses the stub already present
+  undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference
+}
+# We would have crashed by now if it weren’t fixed.
+pass "pad taking ownership once more of packagified my-sub";
 
 # -------------------- Interactions (and misc tests) -------------------- #