Stop undef &foo from temporarily anonymising
authorFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 22:53:31 +0000 (15:53 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 23:47:50 +0000 (16:47 -0700)
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.

cv.h
embed.fnc
embed.h
pad.c
pp.c
proto.h

diff --git a/cv.h b/cv.h
index c1f4456..8ba1c5c 100644 (file)
--- 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
index 09312e9..da38ec1 100644 (file)
--- 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 66fc634..47a2b0f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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 0b10575..a342349 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -318,11 +318,18 @@ 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 0750ea0..547731f 100644 (file)
--- 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 cca048c..4c83158 100644 (file)
--- 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 \