Add more context information when raising WARN_REDEFINE #16145
Comments
From @atoomicThis is a bug report for perl from atoomic@cpan.org, When a function is redefined, rather than printing the location of the This is an idea introduced by Reini Urban in cperl via I'm aware that adding this behavior, this might break some CPAN unit tests Flags: Site configuration information for perl 5.26.0: Configured by cPanel at Thu Aug 31 17:31:39 CDT 2017. Summary of my perl5 (revision 5 version 26 subversion 0) configuration: Platform: Locally applied patches: @INC for perl 5.26.0: /usr/local/cpanel/3rdparty/perl/526/lib64/perl5/cpanel_lib/x86_64-linux-64int /usr/local/cpanel/3rdparty/perl/526/lib64/perl5/5.26.0/x86_64-linux-64int Environment for perl 5.26.0: PATH=/usr/local/cpanel/3rdparty/perl/526/bin:/usr/local/cpanel/3rdparty/perl/524/bin:/usr/local/cpanel/3rdparty/perl/522/bin:/usr/local/cpanel/3rdparty/perl/514/bin:/usr/local/cpanel/3rdparty/bin:/root/bin/:/opt/local/bin:/opt/local/sbin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/opt/cpanel/composer/bin:/root/.dotfiles/bin:/root/perl5/bin:/root/.rvm/bin:/root/bin |
From @atoomic0001-Improve-WARN_REDEFINE-at-caller-file-line.patchFrom e550d600a26f4fb3211aaa4ae0ba1ce3578df895 Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@cpanel.net>
Date: Wed, 23 Mar 2016 11:24:06 +0100
Subject: [PATCH] Improve WARN_REDEFINE, at caller file:line
When a function is redefined, rather than printing
the location of the redefined function, it would be
better to also know what caused the redefinition
of the function and where.
Adjust some core tests for improved WARN_REDEFINE.
Add a couple of ", called by file:line " strings to the warning.
References: BC-GH #113 https://github.com/perl11/cperl/issues/113
(cherry picked from commit a46cfee0292121906841e17ccfefc6a659509ff9)
(cherry picked from commit a1ee3de7ea8e0ed5246dde11d827df2bb56b0548)
Signed-off-by: Nicolas R <atoomic@cpan.org>
---
ext/XS-APItest/t/newCONSTSUB.t | 6 +++---
op.c | 21 +++++++++++++++++++--
pod/perlsub.pod | 9 +++++++++
t/lib/warnings/op | 10 +++++-----
t/lib/warnings/sv | 8 ++++----
t/op/anonconst.t | 2 +-
t/op/const-optree.t | 2 +-
t/op/lexsub.t | 6 +++---
t/op/stash.t | 2 +-
t/run/fresh_perl.t | 10 ++++++++--
10 files changed, 54 insertions(+), 22 deletions(-)
diff --git a/ext/XS-APItest/t/newCONSTSUB.t b/ext/XS-APItest/t/newCONSTSUB.t
index 2df850e0c0..63d9224186 100644
--- a/ext/XS-APItest/t/newCONSTSUB.t
+++ b/ext/XS-APItest/t/newCONSTSUB.t
@@ -14,7 +14,7 @@ use XS::APItest;
local $SIG{__WARN__} = sub { $w .= shift };
sub frimple() { 78 }
newCONSTSUB_flags(\%::, "frimple", 0, undef);
- like $w, qr/Constant subroutine frimple redefined at /,
+ like $w, qr/Constant subroutine frimple redefined/,
'newCONSTSUB constant redefinition warning is unaffected by $^W=0';
undef $w;
newCONSTSUB_flags(\%::, "frimple", 0, undef);
@@ -62,11 +62,11 @@ eval q{
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
newCONSTSUB_flags(\%foo::, "\x{100}", 0, undef);
- like $w, qr/Subroutine \x{100} redefined at /,
+ like $w, qr/Subroutine \x{100} redefined/,
'newCONSTSUB redefinition warning + utf8';
undef $w;
newCONSTSUB_flags(\%foo::, "\x{100}", 0, 54);
- like $w, qr/Constant subroutine \x{100} redefined at /,
+ like $w, qr/Constant subroutine \x{100} redefined/,
'newCONSTSUB constant redefinition warning + utf8';
}
diff --git a/op.c b/op.c
index 06ec00b1e9..0affc4bf25 100644
--- a/op.c
+++ b/op.c
@@ -15441,12 +15441,29 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
&& ckWARN_d(WARN_REDEFINE)
&& (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
)
- )
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ ) {
+ /* which module/srcline caused this forced require/do/eval redefinition */
+ if (cxstack_ix >= 0) {
+ const COP* const cop = cxstack[cxstack_ix].blk_oldcop;
+ const char* const file = cop ? OutCopFILE(cop) : "";
+ const char* const display_file = file ? file : "";
+ const long line = cop ? (long)CopLINE(cop) : 0;
+
+ if (!*file && !line) goto no_caller;
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ is_const
+ ? "Constant subroutine %" SVf " redefined, called by %s:%ld"
+ : "Subroutine %" SVf " redefined, called by %s:%ld",
+ SVfARG(name), display_file, line);
+ } else {
+ no_caller:
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
is_const
? "Constant subroutine %" SVf " redefined"
: "Subroutine %" SVf " redefined",
SVfARG(name));
+ }
+ }
}
/*
diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index 689d4a3837..ca0b5829f2 100644
--- a/pod/perlsub.pod
+++ b/pod/perlsub.pod
@@ -1769,6 +1769,15 @@ different than the warning for overriding non-inlined subroutines:
$ perl -we 'sub one {1} sub one {2}'
Subroutine one redefined at -e line 1.
+When the redefinition is caused by a wrong action in an upper scope,
+this location is printed also. E.g. by a C<require> and after messing
+with C<%INC>, a C<do FILE> statement, or an C<eval>. You generally
+want to know who caused this error, not where the function is defined.
+
+ $ perl -we 'do "utf8.pm";
+ do "utf8.pm";'
+ Subroutine import redefined, called by -e:2 at lib/utf8.pm line 7.
+
The warning is considered severe enough not to be affected by the
B<-w> switch (or its absence) because previously compiled invocations
of the function will still be using the old value of the function. If
diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index d9116fa9d7..1a701890d6 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -1012,7 +1012,7 @@ Constant subroutine fred redefined at - line 3.
sub fred () { 1 }
*fred = sub () { 2 };
EXPECT
-Constant subroutine main::fred redefined at - line 3.
+Constant subroutine main::fred redefined, called by -:0 at - line 3.
########
# op.c
use feature "lexical_subs", "state";
@@ -1784,7 +1784,7 @@ use open qw( :utf8 :std );
sub fr��d () { 1 }
*fr��d = sub () { 2 };
EXPECT
-Constant subroutine main::fr��d redefined at - line 5.
+Constant subroutine main::fr��d redefined, called by -:0 at - line 5.
########
# op.c
use warnings 'redefine' ;
@@ -1822,7 +1822,7 @@ use open qw( :utf8 :std );
sub �������� () { 1 }
*�������� = sub () { 2 };
EXPECT
-Constant subroutine main::�������� redefined at - line 5.
+Constant subroutine main::�������� redefined, called by -:0 at - line 5.
########
# OPTION regex
sub DynaLoader::dl_error {};
@@ -1841,9 +1841,9 @@ BEGIN {
EOC
EXPECT
OPTION regex
-\ASubroutine DynaLoader::dl_error redefined at \(eval 1\) line 2\.
+\ASubroutine DynaLoader::dl_error redefined, called by \(eval 1\):2 at \(eval 1\) line 2\.
?(?s).*
-Subroutine DynaLoader::dl_error redefined at \(eval 2\) line 2\.
+Subroutine DynaLoader::dl_error redefined, called by \(eval 2\):3 at \(eval 2\) line 2\.
########
# op.c
use warnings;
diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv
index 64f624c5ed..a4036e33d3 100644
--- a/t/lib/warnings/sv
+++ b/t/lib/warnings/sv
@@ -282,7 +282,7 @@ no warnings 'redefine' ;
sub jim {}
*jim = \&joe ;
EXPECT
-Subroutine main::fred redefined at - line 5.
+Subroutine main::fred redefined, called by -:0 at - line 5.
########
# sv.c
use warnings 'printf' ;
@@ -384,7 +384,7 @@ no warnings 'redefine' ;
sub j��m {}
*j��m = \&j���� ;
EXPECT
-Subroutine main::fr��d redefined at - line 7.
+Subroutine main::fr��d redefined, called by -:0 at - line 7.
########
# sv.c
use warnings 'redefine' ;
@@ -397,7 +397,7 @@ no warnings 'redefine' ;
sub ��� {}
*��� = \&����� ;
EXPECT
-Subroutine main::������ redefined at - line 7.
+Subroutine main::������ redefined, called by -:0 at - line 7.
########
# sv.c
my $x = "a_c";
@@ -423,4 +423,4 @@ sub Foo::f {}
undef *Foo::;
*Foo::f =sub {};
EXPECT
-Subroutine f redefined at - line 5.
+Subroutine f redefined, called by -:0 at - line 5.
diff --git a/t/op/anonconst.t b/t/op/anonconst.t
index 89a6acbaba..2bfe08fc7b 100644
--- a/t/op/anonconst.t
+++ b/t/op/anonconst.t
@@ -39,7 +39,7 @@ is &{sub () : const { 42 }}, 42, ':const with truly constant sub';
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
*foo = sub (){};
- like $w, qr/^Constant subroutine main::foo redefined at /,
+ like $w, qr/^Constant subroutine main::foo redefined/,
':const subs are constant';
}
diff --git a/t/op/const-optree.t b/t/op/const-optree.t
index 4d897d247e..015486179e 100644
--- a/t/op/const-optree.t
+++ b/t/op/const-optree.t
@@ -457,7 +457,7 @@ for \%_ (@tests) {
*temp_inlinability_test = sub (){};
my $S = $_{inlinable} ? "Constant s" : "S";
my $not = " not" x! $_{inlinable};
- like $w, qr/^${S}ubroutine .* redefined at /,
+ like $w, qr/^${S}ubroutine .* redefined/,
"$nickname is$not inlinable";
}
if (exists $_{method}) {
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index 3fa17acdda..2e23d9f8ff 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -1,5 +1,5 @@
#!perl
-
+my $file = __FILE__;
BEGIN {
chdir 't' if -d 't';
require './test.pl';
@@ -332,7 +332,7 @@ sub make_anon_with_state_sub{
state $w;
local $SIG{__WARN__} = sub { $w .= shift };
eval "#line 56 pygpyf\nsub redef {}";
- is $w, "Subroutine redef redefined at pygpyf line 56.\n",
+ is $w, "Subroutine redef redefined, called by $file:334 at pygpyf line 56.\n",
"sub redefinition warnings from state subs";
}
{
@@ -669,7 +669,7 @@ sub make_anon_with_my_sub{
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
eval "#line 56 pygpyf\nsub redef {}";
- is $w, "Subroutine redef redefined at pygpyf line 56.\n",
+ is $w, "Subroutine redef redefined, called by $file:671 at pygpyf line 56.\n",
"sub redefinition warnings from my subs";
undef $w;
diff --git a/t/op/stash.t b/t/op/stash.t
index c9634a370a..6c3940da99 100644
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -29,7 +29,7 @@ SKIP: {
skip_if_miniperl('requires XS');
fresh_perl_like(
'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
- qr/^Subroutine mro::get_mro redefined at /,
+ qr/^Subroutine mro::get_mro redefined/,
{ switches => [ '-w' ] },
q(Defining an XSUB over an existing sub with no stash under warnings),
);
diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t
index 411ff04b9c..53b99bf005 100644
--- a/t/run/fresh_perl.t
+++ b/t/run/fresh_perl.t
@@ -52,7 +52,13 @@ foreach my $prog (@prgs) {
$expected =~ s/\n+$//;
- fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
+ # expand temp filename to a regex
+ if ($expected =~ m/^(.*)tmpXXXXXX(.*)$/s) {
+ $expected = qr/\Q$1\Etmp\w+\Q$2\E/;
+ fresh_perl_like($prog, $expected, { switches => [$switch || ''] }, $name);
+ } else {
+ fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
+ }
}
__END__
@@ -336,7 +342,7 @@ foo;
foo;
EXPECT
In foo1
-Subroutine foo redefined at (eval 1) line 1.
+Subroutine foo redefined, called by tmpXXXXXX:4 at (eval 1) line 1.
Exiting foo1
In foo2
########
--
2.14.1
|
From zefram@fysh.orgNicolas R. wrote:
Carp::Always. There's no need for this to be done in core, and no reason -zefram |
|
The RT System itself - Status changed from 'new' to 'open' |
From @atoomicThanks for your answer, I agree with you that we could extend this behavior to other warnings. I was currently mainly focused on the "redefined sub" which is very annoying when you deal with a script using many packages... [ and is compiled ]. I think this we can use an iterative approach by improving similar warnings as we noticed them over time? Feel free to submit extra patches on top of this merge request. That does not sound like a reasonable argument to me, why requiring more than 1Mo of memory when you can have it for free in core? Does not it seem like legitimate by default to know where a code redefined a function? As you can notice Carp::Always comes with its own cost and is not suitable for every scripts. thanks On Tue, 12 Sep 2017 09:40:57 -0700, zefram@fysh.org wrote:
|
From zefram@fysh.orgAtoomic via RT wrote:
No, we should just take advantage of the genericity of the warning
Adding such a thing to the core is not free (in maintenance). Using
It's legitimate to be able to extract that information, which we can,
What is it not suitable for? This ticket should be closed as rejected. -zefram |
From @xsawyerxOn 09/13/2017 06:36 PM, Zefram wrote:
While I concur with the "easier to use Carp::Always or Devel::Confess" |
From @toddrOn Sun, 17 Sep 2017 11:37:46 -0700, xsawyerx@gmail.com wrote:
For me this falls in the "Can't we have nice things?" category. Perl has improved warnings over the years and I applaud the efforts. To my mind, the same should apply here. Just cause CPAN did it, doesn't mean Perl 5 can't steal the idea. Right? If we want to expand the patch to include all the other warnings that need this sort of information, I think atoomic and I would be up for the challenge. If you guys are cool with merging this and asking for more, we could also take that approach. Todd |
From zefram@fysh.orgTodd Rinaldo via RT wrote:
Wouldn't that be all of the warnings? (Either all or none; "need" is a This is absolutely not something to do to specific warning/exception But then you have to decide whether this information is always added or If the objective of coring is more like "batteries included in the core -zefram |
From @xsawyerxIn essence, I think the issues Zefram raises here would need to be On 09/19/2017 05:51 PM, Zefram wrote:
This does not seem to me like a scalable solution. The work on
This is the faster to implement and more sustainable solution moving
Also, whether this is triggered for everything or optionally. The last
Stacktraces are not cheap. Having such a functionality built-in (not |
From @atoomicafter discussion, we are rejecting this idea On Sat, 23 Sep 2017 03:25:46 -0700, xsawyerx@gmail.com wrote:
|
|
@atoomic - Status changed from 'open' to 'rejected' |
Migrated from rt.perl.org#132072 (status was 'rejected')
Searchable as RT132072$
The text was updated successfully, but these errors were encountered: