Restore autouse’s exemption from redef warnings

This also restores the subroutine redefinition warning for newly-cre-
ated XSUBs outside the autouse package.  See below.

This commit added the exemption to fix a known bug, that loading a
module and importing from it would cause a redefinition warning if
there were an autouse stub:

perl-5.004_03-1092-g2f34f9d
commit 2f34f9d
Author: Ilya Zakharevich <[email protected]>
Date:   Mon Mar 2 16:36:02 1998 -0500

    Make autouse -w-safe

    p4raw-id: //depot/perl@781

The subroutine redefinition warning occurs in three places.
This commit removed the autouse exemption from two
of them.  I can’t see how it wasn’t a mistake, as <5104D4DBC598D211B5FE0000F8FE7EB202D49EE9@mbtlipnt02.btlabs.bt.co.uk>
(the apparent source of the patch, makes no mention of it:

perl-5.005_02-2920-ge476b1b
commit e476b1b
Author: Gurusamy Sarathy <[email protected]>
Date:   Sun Feb 20 22:58:09 2000 +0000

    lexical warnings update, ability to inspect bitmask in calling
    scope, among other things (from Paul Marquess)

    p4raw-id: //depot/perl@5170

This commit refactored things to remove some compiler warnings, but
in doing so reversed the logic of the condition, causing redefini-
tion warnings for newly-created XSUBs to apply only to subs from the
autouse package:

perl-5.8.0-5131-g66a1b24
commit 66a1b24
Author: Andy Lester <[email protected]>
Date:   Mon Jun 6 05:11:07 2005 -0500

    Random cleanups #47
    Message-ID: <[email protected]>

    p4raw-id: //depot/perl@24735

I’ve basically reinstated the changes in 2f34f9d, but with tests
this time.

It may not make sense for autouse to be exempt for newATTRSUB and
newXS, but keeping the logic surrounding the warning as close as
possible to being the same could allow future refactorings to
merge them.

Author: Father Chrysostomos

MANIFEST

@@ -2983,6 +2983,7 @@ dist/Attribute-Handlers/t/linerep.t			See if Attribute::Handlers works
 dist/Attribute-Handlers/t/multi.t			See if Attribute::Handlers works
 dist/autouse/lib/autouse.pm		Load and call a function only when it's used
 dist/autouse/t/autouse.t		See if autouse works
+dist/autouse/t/lib/MyTestModule2.pm	Test module for autouse
 dist/autouse/t/lib/MyTestModule.pm	Test module for autouse
 dist/base/Changes		base.pm changelog
 dist/base/lib/base.pm		Establish IS-A relationship at compile time

dist/autouse/t/autouse.t

@@ -8,7 +8,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 12;
+use Test::More tests => 15;
 
 BEGIN {
     require autouse;
@@ -69,3 +69,34 @@ autouse->import("MyTestModule" => 'test_function');
 my $ret = test_function();
 is( $ret, 'works' );
 
+# Test that autouse is exempt from all methods of triggering the subroutine
+# redefinition warning.
+SKIP: {
+    skip "Fails in 5.15.5 and below (perl bug)", 2 if $] < 5.0150051;
+    use warnings; local $^W = 1;
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    use autouse MyTestModule2 => 'test_function2';
+    *MyTestModule2::test_function2 = \&test_function2;
+    require MyTestModule2;
+    is $w, undef,
+       'no redefinition warning when clobbering autouse stub with new sub';
+    undef $w;
+    import MyTestModule2 'test_function2';
+    is $w, undef,
+       'no redefinition warning when clobbering autouse stub via *a=\&b';
+}
+SKIP: {
+    skip "Fails from 5.10 to 5.15.5 (perl bug)", 1
+	if $] < 5.0150051 and $] > 5.0099;
+    use Config;
+    skip "no B", 1 unless $Config{extensions} =~ /\bB\b/;
+    use warnings; local $^W = 1;
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    use autouse B => "sv_undef";
+    *B::sv_undef = \&sv_undef;
+    require B;
+    is $w, undef,
+      'no redefinition warning when clobbering autouse stub with new XSUB';
+}

dist/autouse/t/lib/MyTestModule2.pm

@@ -0,0 +1,12 @@
+package MyTestModule2;
+use warnings;
+
+@ISA = Exporter;
+require Exporter;
+@EXPORT_OK = 'test_function2';
+
+sub test_function2 {
+  return 'works';
+}
+
+1;

op.c

@@ -6583,7 +6583,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 		&& block->op_type != OP_NULL
 #endif
 		) {
-		if (ckWARN(WARN_REDEFINE)
+		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)
 			&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
 		{
@@ -7005,25 +7012,28 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
                 /* already defined (or promised) */
                 if (ckWARN(WARN_REDEFINE)) {
+                    const line_t oldline = CopLINE(PL_curcop);
                     GV * const gvcv = CvGV(cv);
                     if (gvcv) {
                         HV * const stash = GvSTASH(gvcv);
                         if (stash) {
                             const char *redefined_name = HvNAME_get(stash);
                             if ( redefined_name &&
                                  strEQ(redefined_name,"autouse") ) {
-                                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 %s redefined"
-                                                        : "Subroutine %s redefined"
-                                            ,name);
-                                CopLINE_set(PL_curcop, oldline);
+                                goto nope;
                             }
                         }
                     }
+                    if (PL_parser && PL_parser->copline != NOLINE)
+                        CopLINE_set(PL_curcop, PL_parser->copline);
+                    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                                      CvCONST(cv)
+                                       ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined"
+                                     ,name);
+                    CopLINE_set(PL_curcop, oldline);
                 }
+	      nope:
                 SvREFCNT_dec(cv);
                 cv = NULL;
             }

sv.c

@@ -3810,6 +3810,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 		if (!GvCVGEN((const GV *)dstr) &&
 		    (CvROOT(cv) || CvXSUB(cv)))
 		    {
+			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)
@@ -3823,7 +3824,14 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 			       when a constant is exported twice.  Don't warn.
 			    */
 			}
-			else if (ckWARN(WARN_REDEFINE)
+			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)
 				     && (!CvCONST((const CV *)sref)
 					 || sv_cmp(cv_const_sv(cv),

t/op/stash.t

@@ -28,9 +28,9 @@ fresh_perl_is(
 # Used to segfault, too
 SKIP: {
  skip_if_miniperl('requires XS');
-  fresh_perl_is(
+  fresh_perl_like(
     'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
-    '',
+     qr/^Subroutine mro::get_mro redefined at /,
     { switches => [ '-w' ] },
     q(Defining an XSUB over an existing sub with no stash under warnings),
   );