Make const redef warnings default in newXS

There is no reason why constant redefinition warnings should be
default warnings for sub foo(){1}, but not for newCONSTSUB (which
calls newXS, which triggers the warning).

To make this work properly, I also had to import sv.c’s ‘are these
const subs from the same SV originally?’ logic.  Constants created
with XS can have NULL for the SV (they return an empty list or
&PL_sv_undef), which means sv.c’s logic will stop *this=\&that from
warning if both this and that are such XS-created constants.
newCONSTSUB needed to be consistent with that.  It required tweaking a
test I added a few commits ago, which arguably shouldn’t have warned
the way it was written.

As of this commit (and before it, too, come to think of it),
newXS_len_flags’s calling convention is quite awful and would need to
be throughly re-thunk before being made into an API, or probably sim-
ply never made into an API.

6 files changed, 61 insertions, 18 deletions

diff --git a/embed.fnc b/embed.fnc
index 16cc090ca1..a11606ed6f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -877,7 +877,8 @@ Abm	|CV*	|newSUB		|I32 floor|NULLOK OP* o|NULLOK OP* proto \
 p	|CV *	|newXS_len_flags|NULLOK const char *name|STRLEN len \
 				|NN XSUBADDR_t subaddr\
 				|NN const char *const filename \
-				|NULLOK const char *const proto|U32 flags
+				|NULLOK const char *const proto \
+				|NULLOK SV **const_svp|U32 flags
 ApM	|CV *	|newXS_flags	|NULLOK const char *name|NN XSUBADDR_t subaddr\
 				|NN const char *const filename \
 				|NULLOK const char *const proto|U32 flags
diff --git a/embed.h b/embed.h
index e591762917..75960ede9e 100644
--- a/embed.h
+++ b/embed.h
@@ -1137,7 +1137,7 @@
 #define my_stat_flags(a)	Perl_my_stat_flags(aTHX_ a)
 #define my_swabn		Perl_my_swabn
 #define my_unexec()		Perl_my_unexec(aTHX)
-#define newXS_len_flags(a,b,c,d,e,f)	Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f)
+#define newXS_len_flags(a,b,c,d,e,f,g)	Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
 #define nextargv(a)		Perl_nextargv(aTHX_ a)
 #define oopsAV(a)		Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)		Perl_oopsHV(aTHX_ a)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 46cc458d52..4f84c60d3e 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1878,11 +1878,12 @@ call_method(methname, flags, ...)
 	PUSHs(sv_2mortal(newSViv(i)));
 
 void
-newCONSTSUB_type(stash, name, flags, type)
+newCONSTSUB_type(stash, name, flags, type, sv)
     HV* stash
     SV* name
     I32 flags
     int type
+    SV* sv
     PREINIT:
 	CV* cv;
 	STRLEN len;
@@ -1890,10 +1891,12 @@ newCONSTSUB_type(stash, name, flags, type)
     PPCODE:
         switch (type) {
            case 0:
-	       cv = newCONSTSUB(stash, pv, NULL);
+	       cv = newCONSTSUB(stash, pv, SvOK(sv) ? sv : NULL);
                break;
            case 1:
-               cv = newCONSTSUB_flags(stash, pv, len, flags | SvUTF8(name), NULL);
+               cv = newCONSTSUB_flags(
+                 stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? sv : NULL
+               );
                break;
         }
         EXTEND(SP, 2);
diff --git a/ext/XS-APItest/t/newCONSTSUB.t b/ext/XS-APItest/t/newCONSTSUB.t
index b6e672d986..afd44262da 100644
--- a/ext/XS-APItest/t/newCONSTSUB.t
+++ b/ext/XS-APItest/t/newCONSTSUB.t
@@ -1,24 +1,46 @@
 #!perl
 
 use strict;
-use warnings;
 use utf8;
 use open qw( :utf8 :std );
-use Test::More tests => 11;
+use Test::More tests => 14;
 
 use XS::APItest;
 
-my ($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0);
+# This test must happen outside of any warnings scope
+{
+ local $^W;
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ sub frimple() { 78 }
+ newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
+ like $w, qr/Constant subroutine frimple redefined at /,
+   'newCONSTSUB constant redefinition warning is unaffected by $^W=0';
+ undef $w;
+ newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
+ is $w, undef, '...unless the const SVs are the same';
+ eval 'sub frimple() { 78 }';
+ undef $w;
+ newCONSTSUB_type(\%::, "frimple", 0, 1, "78");
+ is $w, undef, '...or the const SVs have the same value';
+}
+
+use warnings;
+
+my ($const, $glob) =
+ XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0, undef);
 
 ok $const;
 ok *{$glob}{CODE};
 
-($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0);
+($const, $glob) =
+  XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0, undef);
 ok $const, "newCONSTSUB generates the constant,";
 ok *{$glob}{CODE}, "..and the glob,";
 ok !$::{"\x{30cb}"}, "...but not the right one";
 
-($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1);
+($const, $glob) =
+  XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1, undef);
 ok $const, "newCONSTSUB_flags generates the constant,";
 ok *{$glob}{CODE}, "..and the glob,";
 ok $::{"\x{30cd}"}, "...the right one!";
@@ -29,7 +51,7 @@ eval q{
   my $w;
   local $SIG{__WARN__} = sub { $w .= shift };
   *foo = sub(){123};
-  newCONSTSUB_type(\%::, "foo", 0, 1);
+  newCONSTSUB_type(\%::, "foo", 0, 1, undef);
   is $w, undef, 'newCONSTSUB uses calling scope for redefinition warnings';
  }
 };
@@ -39,11 +61,11 @@ eval q{
  *{"foo::\x{100}"} = sub(){return 123};
  my $w;
  local $SIG{__WARN__} = sub { $w .= shift };
- newCONSTSUB_type(\%foo::, "\x{100}", 0, 1);
+ newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, undef);
  like $w, qr/Subroutine \x{100} redefined at /,
    'newCONSTSUB redefinition warning + utf8';
  undef $w;
- newCONSTSUB_type(\%foo::, "\x{100}", 0, 1);
+ newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, 54);
  like $w, qr/Constant subroutine \x{100} redefined at /,
    'newCONSTSUB constant redefinition warning + utf8';
 }
diff --git a/op.c b/op.c
index 1dcfcad45a..096fe48950 100644
--- a/op.c
+++ b/op.c
@@ -6961,7 +6961,7 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
        processor __FILE__ directive). But we need a dynamically allocated one,
        and we need it to get freed.  */
     cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
-		     XS_DYNAMIC_FILENAME | flags);
+			 &sv, XS_DYNAMIC_FILENAME | flags);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
 
@@ -6981,14 +6981,15 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
 {
     PERL_ARGS_ASSERT_NEWXS_FLAGS;
     return newXS_len_flags(
-	name, name ? strlen(name) : 0, subaddr, filename, proto, flags
+       name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
     );
 }
 
 CV *
 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 			   XSUBADDR_t subaddr, const char *const filename,
-			   const char *const proto, U32 flags)
+			   const char *const proto, SV **const_svp,
+			   U32 flags)
 {
     CV *cv;
 
@@ -7015,13 +7016,29 @@ 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 (ckWARN(WARN_REDEFINE)
+		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)  )
+		    )
 		) {
                     const line_t oldline = CopLINE(PL_curcop);
                     if (PL_parser && PL_parser->copline != NOLINE)
diff --git a/proto.h b/proto.h
index 8bec0b273b..19f52d58aa 100644
--- a/proto.h
+++ b/proto.h
@@ -2781,7 +2781,7 @@ PERL_CALLCONV CV *	Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
 #define PERL_ARGS_ASSERT_NEWXS_FLAGS	\
 	assert(subaddr); assert(filename)
 
-PERL_CALLCONV CV *	Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
+PERL_CALLCONV CV *	Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, U32 flags)
 			__attribute__nonnull__(pTHX_3)
 			__attribute__nonnull__(pTHX_4);
 #define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS	\