From 799fd3b94fb5c431b24ee141e32a0b09d56f303c Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 20 Nov 2011 23:46:48 -0800 Subject: [PATCH 1/1] =?utf8?q?Restore=20autouse=E2=80=99s=20exemption=20fr?= =?utf8?q?om=20redef=20warnings?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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 2f34f9d4825ac9262ece854fc4c50479f4838ff8 Author: Ilya Zakharevich 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 e476b1b5c29f354cf8dad61a9fc6d855bdfb5b7d Author: Gurusamy Sarathy 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 66a1b24beb76ea873ad4caa57ee3ab9df945afbf Author: Andy Lester Date: Mon Jun 6 05:11:07 2005 -0500 Random cleanups #47 Message-ID: <20050606151107.GC7022@petdance.com> p4raw-id: //depot/perl@24735 I’ve basically reinstated the changes in 2f34f9d4, 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. --- MANIFEST | 1 + dist/autouse/t/autouse.t | 33 ++++++++++++++++++++++++++++++++- dist/autouse/t/lib/MyTestModule2.pm | 12 ++++++++++++ op.c | 28 +++++++++++++++++++--------- sv.c | 10 +++++++++- t/op/stash.t | 4 ++-- 6 files changed, 75 insertions(+), 13 deletions(-) create mode 100644 dist/autouse/t/lib/MyTestModule2.pm diff --git a/MANIFEST b/MANIFEST index e0044df..40dc175 100644 --- a/MANIFEST +++ b/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 diff --git a/dist/autouse/t/autouse.t b/dist/autouse/t/autouse.t index 53e1740..59374c2 100644 --- a/dist/autouse/t/autouse.t +++ b/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'; +} diff --git a/dist/autouse/t/lib/MyTestModule2.pm b/dist/autouse/t/lib/MyTestModule2.pm new file mode 100644 index 0000000..e2b551b --- /dev/null +++ b/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; diff --git a/op.c b/op.c index 3071440..2deedd1 100644 --- a/op.c +++ b/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,6 +7012,7 @@ 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); @@ -7012,18 +7020,20 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, 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; } diff --git a/sv.c b/sv.c index 50d774d..ba656a9 100644 --- a/sv.c +++ b/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), diff --git a/t/op/stash.t b/t/op/stash.t index 9e223eb..3c31525 100644 --- a/t/op/stash.t +++ b/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), ); -- 1.8.3.1