This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Put sub redef warnings in one place
authorFather Chrysostomos <sprout@cpan.org>
Tue, 22 Nov 2011 05:57:21 +0000 (21:57 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 22 Nov 2011 05:57:58 +0000 (21:57 -0800)
The logic surrounding subroutine redefinition warnings (to warn or not
to warn?) was in three places.  Over time, they drifted apart, to the\rpoint that newXS was following completely different rules.  It was
only warning for redefinition of functions in the autouse namespace.
Recent commits have brought it into conformity with the other redefi-
nition warnings.

Obviously it’s about time we put it in one function.

embed.fnc
embed.h
op.c
proto.h
sv.c

index a11606e..559f8cb 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1459,6 +1459,11 @@ p        |void   |report_evil_fh |NULLOK const GV *gv
 p      |void   |report_wrongway_fh|NULLOK const GV *gv|const char have
 : Used in mg.c, pp.c, pp_hot.c, regcomp.c
 XEpd   |void   |report_uninit  |NULLOK const SV *uninit_sv
+#if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
+p      |void   |report_redefined_cv|NN const SV *name \
+                                   |NN const CV *old_cv \
+                                   |NULLOK SV * const *new_const_svp
+#endif
 Apd    |void   |warn_sv        |NN SV *baseex
 Afpd   |void   |warn           |NN const char* pat|...
 Apd    |void   |vwarn          |NN const char* pat|NULLOK va_list* args
diff --git a/embed.h b/embed.h
index 75960ed..42f4da4 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
 #define too_many_arguments(a,b)        S_too_many_arguments(aTHX_ a,b)
 #  endif
+#  if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
+#define report_redefined_cv(a,b,c)     Perl_report_redefined_cv(aTHX_ a,b,c)
+#  endif
 #  if defined(PERL_IN_PAD_C)
 #define pad_alloc_name(a,b,c,d)        S_pad_alloc_name(aTHX_ a,b,c,d)
 #define pad_check_dup(a,b,c)   S_pad_check_dup(aTHX_ a,b,c)
diff --git a/op.c b/op.c
index 096fe48..ea0372d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6583,27 +6583,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                && block->op_type != OP_NULL
 #endif
                ) {
-               const char *hvname;
-               if (   (ckWARN(WARN_REDEFINE)
-                       && !(
-                               CvGV(cv) && GvSTASH(CvGV(cv))
-                            && HvNAMELEN(GvSTASH(CvGV(cv))) == 7
-                            && (hvname = HvNAME(GvSTASH(CvGV(cv))),
-                                strEQ(hvname, "autouse"))
-                      ))
-                   || (CvCONST(cv)
-                       && ckWARN_d(WARN_REDEFINE)
-                       && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
-               {
-                   const line_t oldline = CopLINE(PL_curcop);
-                   if (PL_parser && PL_parser->copline != NOLINE)
+               const line_t oldline = CopLINE(PL_curcop);
+               if (PL_parser && PL_parser->copline != NOLINE)
                        CopLINE_set(PL_curcop, PL_parser->copline);
-                   Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                       CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
-                                   : "Subroutine %"SVf" redefined",
-                                    SVfARG(cSVOPo->op_sv));
-                   CopLINE_set(PL_curcop, oldline);
-               }
+               report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
+               CopLINE_set(PL_curcop, oldline);
 #ifdef PERL_MAD
                if (!PL_minus_c)        /* keep old one around for madskills */
 #endif
@@ -7015,42 +6999,16 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
             }
             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
                 /* already defined (or promised) */
-               const char *redefined_name;
-               if (CvCONST(cv) && const_svp
-                && cv_const_sv(cv) == *const_svp) {
-                   NOOP;
-                   /* They are 2 constant subroutines generated from
-                      the same constant. This probably means that
-                      they are really the "same" proxy subroutine
-                      instantiated in 2 places. Most likely this is
-                      when a constant is exported twice.  Don't warn.
-                   */
-               }
-                else if ((ckWARN(WARN_REDEFINE)
-                    && !(
-                           CvGV(cv) && GvSTASH(CvGV(cv))
-                        && HvNAMELEN(GvSTASH(CvGV(cv))) == 7
-                        && (redefined_name = HvNAME(GvSTASH(CvGV(cv))),
-                            strEQ(redefined_name, "autouse"))
-                        )
-                   )
-                || (CvCONST(cv)
-                       && ckWARN_d(WARN_REDEFINE)
-                       && (  !const_svp
-                          || sv_cmp(cv_const_sv(cv), *const_svp)  )
-                   )
-               ) {
+                /* Reduntant check that allows us to avoid creating an SV
+                   most of the time: */
+                if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
                     const line_t oldline = CopLINE(PL_curcop);
                     if (PL_parser && PL_parser->copline != NOLINE)
                         CopLINE_set(PL_curcop, PL_parser->copline);
-                    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                                      CvCONST(cv)
-                                       ? "Constant subroutine %"SVf
-                                         " redefined"
-                                       : "Subroutine %"SVf" redefined",
-                                      newSVpvn_flags(
+                    report_redefined_cv(newSVpvn_flags(
                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
-                                      ));
+                                        ),
+                                        cv, const_svp);
                     CopLINE_set(PL_curcop, oldline);
                 }
                 SvREFCNT_dec(cv);
@@ -10601,6 +10559,45 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
     }
 }
 
+void
+Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
+                              SV * const *new_const_svp)
+{
+    const char *hvname;
+    bool is_const = !!CvCONST(old_cv);
+    SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
+
+    PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
+
+    if (is_const && new_const_svp && old_const_sv == *new_const_svp)
+       return;
+       /* They are 2 constant subroutines generated from
+          the same constant. This probably means that
+          they are really the "same" proxy subroutine
+          instantiated in 2 places. Most likely this is
+          when a constant is exported twice.  Don't warn.
+       */
+    if (
+       (ckWARN(WARN_REDEFINE)
+        && !(
+               CvGV(old_cv) && GvSTASH(CvGV(old_cv))
+            && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
+            && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
+                strEQ(hvname, "autouse"))
+            )
+       )
+     || (is_const
+        && ckWARN_d(WARN_REDEFINE)
+        && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
+       )
+    )
+       Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                         is_const
+                           ? "Constant subroutine %"SVf" redefined"
+                           : "Subroutine %"SVf" redefined",
+                         name);
+}
+
 #include "XSUB.h"
 
 /* Efficient sub that returns a constant scalar value. */
diff --git a/proto.h b/proto.h
index 19f52d5..0906acf 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5803,6 +5803,14 @@ STATIC void      S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
 
 #  endif
 #endif
+#if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
+PERL_CALLCONV void     Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_REPORT_REDEFINED_CV   \
+       assert(name); assert(old_cv)
+
+#endif
 #if defined(PERL_IN_PAD_C)
 STATIC PADOFFSET       S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
                        __attribute__nonnull__(pTHX_1);
diff --git a/sv.c b/sv.c
index d4f0373..8460152 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3808,48 +3808,26 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            CV* const cv = MUTABLE_CV(*location);
            if (cv) {
                if (!GvCVGEN((const GV *)dstr) &&
-                   (CvROOT(cv) || CvXSUB(cv)))
+                   (CvROOT(cv) || CvXSUB(cv)) &&
+                   /* redundant check that avoids creating the extra SV
+                      most of the time: */
+                   (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
                    {
-                       const char *hvname;
-                       /* Redefining a sub - warning is mandatory if
-                          it was a const and its value changed. */
-                       if (CvCONST(cv) && CvCONST((const CV *)sref)
-                           && cv_const_sv(cv)
-                           == cv_const_sv((const CV *)sref)) {
-                           NOOP;
-                           /* They are 2 constant subroutines generated from
-                              the same constant. This probably means that
-                              they are really the "same" proxy subroutine
-                              instantiated in 2 places. Most likely this is
-                              when a constant is exported twice.  Don't warn.
-                           */
-                       }
-                       else if ((ckWARN(WARN_REDEFINE)
-                                 && !(
-                                  CvGV(cv) && GvSTASH(CvGV(cv)) &&
-                                  HvNAMELEN(GvSTASH(CvGV(cv))) == 7 &&
-                                  (hvname = HvNAME(GvSTASH(CvGV(cv))),
-                                   strEQ(hvname, "autouse"))
-                                 )
-                                )
-                                || (CvCONST(cv)
-                                    && ckWARN_d(WARN_REDEFINE)
-                                    && (!CvCONST((const CV *)sref)
-                                        || sv_cmp(cv_const_sv(cv),
-                                                  cv_const_sv((const CV *)
-                                                              sref))))) {
-                           Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                                       (const char *)
-                                       (CvCONST(cv)
-                                        ? "Constant subroutine %"HEKf
-                                          "::%"HEKf" redefined"
-                                        : "Subroutine %"HEKf"::%"HEKf
-                                          " redefined"),
+                       SV * const new_const_sv =
+                           CvCONST((const CV *)sref)
+                                ? cv_const_sv((const CV *)sref)
+                                : NULL;
+                       report_redefined_cv(
+                          sv_2mortal(newSVpvf(
+                               "%"HEKf"::%"HEKf,
                                HEKfARG(
                                 HvNAME_HEK(GvSTASH((const GV *)dstr))
                                ),
-                               HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))));
-                       }
+                               HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
+                          )),
+                          cv,
+                          CvCONST((const CV *)sref) ? &new_const_sv : NULL
+                       );
                    }
                if (!intro)
                    cv_ckproto_len_flags(cv, (const GV *)dstr,