Stop undef &foo from temporarily anonymising

Instead of setting aside the name, calling cv_undef, and then naming
the sub anew, just pass a flag to tell cv_undef not to unname it.

6 files changed, 31 insertions, 19 deletions

diff --git a/cv.h b/cv.h
index c1f4456e11..8ba1c5cbeb 100644
--- a/cv.h
+++ b/cv.h
@@ -270,6 +270,10 @@ typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
 
 #define CALL_CHECKER_REQUIRE_GV	MGf_REQUIRE_GV
 
+#ifdef PERL_CORE
+# define CV_UNDEF_KEEP_NAME	1
+#endif
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/embed.fnc b/embed.fnc
index 09312e9db0..da38ec1285 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -318,6 +318,7 @@ pRn	|SV*	|cv_const_sv_or_av|NULLOK const CV *const cv
 pR	|SV*	|op_const_sv	|NULLOK const OP* o|NULLOK CV* cv
 Ap	|SV *	|cv_name	|NN CV *cv|NULLOK SV *sv
 Apd	|void	|cv_undef	|NN CV* cv
+p	|void	|cv_undef_flags	|NN CV* cv|U32 flags
 p	|void	|cv_forget_slab	|NN CV *cv
 Ap	|void	|cx_dump	|NN PERL_CONTEXT* cx
 Ap	|SV*	|filter_add	|NULLOK filter_t funcp|NULLOK SV* datasv
diff --git a/embed.h b/embed.h
index 66fc634b9d..47a2b0f6b2 100644
--- a/embed.h
+++ b/embed.h
@@ -1128,6 +1128,7 @@
 #define cv_clone_into(a,b)	Perl_cv_clone_into(aTHX_ a,b)
 #define cv_const_sv_or_av	Perl_cv_const_sv_or_av
 #define cv_forget_slab(a)	Perl_cv_forget_slab(aTHX_ a)
+#define cv_undef_flags(a,b)	Perl_cv_undef_flags(aTHX_ a,b)
 #define cvgv_set(a,b)		Perl_cvgv_set(aTHX_ a,b)
 #define cvstash_set(a,b)	Perl_cvstash_set(aTHX_ a,b)
 #define deb_stack_all()		Perl_deb_stack_all(aTHX)
diff --git a/pad.c b/pad.c
index 0b105758d2..a3423499ee 100644
--- a/pad.c
+++ b/pad.c
@@ -319,10 +319,17 @@ children can still follow the full lexical scope chain.
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
+    PERL_ARGS_ASSERT_CV_UNDEF;
+    cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
     const PADLIST *padlist = CvPADLIST(cv);
     bool const slabbed = !!CvSLABBED(cv);
 
-    PERL_ARGS_ASSERT_CV_UNDEF;
+    PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
 	  "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
@@ -365,8 +372,13 @@ Perl_cv_undef(pTHX_ CV *cv)
 #endif
     SvPOK_off(MUTABLE_SV(cv));		/* forget prototype */
     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
-    if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
-    else	     CvGV_set(cv, NULL);
+    if (!(flags & CV_UNDEF_KEEP_NAME)) {
+	if (CvNAMED(cv)) {
+	    CvNAME_HEK_set(cv, NULL);
+	    CvNAMED_off(cv);
+	}
+	else CvGV_set(cv, NULL);
+    }
 
     /* This statement and the subsequence if block was pad_undef().  */
     pad_peg("pad_undef");
@@ -469,10 +481,10 @@ Perl_cv_undef(pTHX_ CV *cv)
 	CvXSUB(cv) = NULL;
     }
     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
-     * ref status of CvOUTSIDE and CvGV, and ANON and
-     * LEXICAL, which pp_entersub uses
-     * to choose an error message */
-    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL);
+     * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+     * LEXICAL, which are used to determine the sub's name.  */
+    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+		   |CVf_NAMED);
 }
 
 /*
diff --git a/pp.c b/pp.c
index 0750ea027b..547731f302 100644
--- a/pp.c
+++ b/pp.c
@@ -1001,19 +1001,8 @@ PP(pp_undef)
                            ));
 	/* FALLTHROUGH */
     case SVt_PVFM:
-	{
 	    /* let user-undef'd sub keep its identity */
-	    GV* const gv = CvGV((const CV *)sv);
-	    HEK * const hek = CvNAME_HEK((CV *)sv);
-	    if (hek) share_hek_hek(hek);
-	    if (gv) SvREFCNT_inc_void_NN(sv_2mortal((SV *)gv));
-	    cv_undef(MUTABLE_CV(sv));
-	    if (gv) CvGV_set(MUTABLE_CV(sv), gv);
-	    else if (hek) {
-		SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
-		CvNAMED_on(sv);
-	    }
-	}
+	cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
 	break;
     case SVt_PVGV:
 	assert(isGV_with_GP(sv));
diff --git a/proto.h b/proto.h
index cca048c66c..4c831581cb 100644
--- a/proto.h
+++ b/proto.h
@@ -835,6 +835,11 @@ PERL_CALLCONV void	Perl_cv_undef(pTHX_ CV* cv)
 #define PERL_ARGS_ASSERT_CV_UNDEF	\
 	assert(cv)
 
+PERL_CALLCONV void	Perl_cv_undef_flags(pTHX_ CV* cv, U32 flags)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_UNDEF_FLAGS	\
+	assert(cv)
+
 PERL_CALLCONV GV *	Perl_cvgv_from_hek(pTHX_ CV* cv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CVGV_FROM_HEK	\