In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/bf236c8ee5b1b47df84e2e196fb90a43c6abd5a2?hp=8af6f9854c44f2d52182097da3cf09138646e6a2>
- Log ----------------------------------------------------------------- commit bf236c8ee5b1b47df84e2e196fb90a43c6abd5a2 Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 20:54:39 2010 +0100 In Carp, if B is loaded use it to get the name of the bad caller override. M lib/Carp.pm M lib/Carp.t commit eff7e72c3d4dda827de2e7b972c08a37cbcf607e Author: Nicholas Clark <[email protected]> Date: Wed Jul 21 20:17:47 2010 +0100 Detect incomplete caller overrides in Carp, and avoid using bogus @DB::args. To get arguments into its backtraces, Carp relies on caller setting @DB::args when called from package DB. @DB::args isn't refcounted (and can't be). Not all overriders of &CORE::GLOBAL::caller set @DB::args properly, with the result that @DB::arg can become "stale", with strange errors, at a distance. However, it is possible to detect that @DB::args has not been updated, and take evasive action. This is preferable to presenting the user (or logfile) with silently wrong backtraces, and much preferable to the occasional "Bizarre copy" exception. M lib/Carp.pm M lib/Carp.t ----------------------------------------------------------------------- Summary of changes: lib/Carp.pm | 20 ++++++++++++++++++-- lib/Carp.t | 50 ++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 64 insertions(+), 6 deletions(-) diff --git a/lib/Carp.pm b/lib/Carp.pm index add42d2..31e57d3 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -1,6 +1,6 @@ package Carp; -our $VERSION = '1.17'; +our $VERSION = '1.18'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -69,6 +69,7 @@ sub caller_info { my %call_info; { package DB; + @args = \$i; # A sentinal, which no-one else has the address of @call_info{ qw(pack file line sub has_args wantarray evaltext is_require) } = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i); @@ -80,7 +81,22 @@ sub caller_info { my $sub_name = Carp::get_subname(\%call_info); if ($call_info{has_args}) { - my @args = map {Carp::format_arg($_)} @DB::args; + my @args; + if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) { + local $@; + my $where = eval { + my $gv = B::svref_2object(\&CORE::GLOBAL::caller)->GV; + my $package = $gv->STASH->NAME; + my $subname = $gv->NAME; + return unless defined $package && defined $subname; + # returning CORE::GLOBAL::caller isn't useful for tracing the cause: + return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; + " in &${package}::$subname"; + } // ''; + @args = "** Incomplete caller override detected$where; \...@db::args were not set **"; + } else { + @args = map {Carp::format_arg($_)} @DB::args; + } if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? $#args = $MaxArgNums; push @args, '...'; diff --git a/lib/Carp.t b/lib/Carp.t index 1eee4c4..1541341 100644 --- a/lib/Carp.t +++ b/lib/Carp.t @@ -11,7 +11,7 @@ my $Is_VMS = $^O eq 'VMS'; use Carp qw(carp cluck croak confess); -plan tests => 39; +plan tests => 56; ok 1; @@ -270,21 +270,60 @@ cluck_undef (0, "undef", 2, undef, 4); # check that Carp respects CORE::GLOBAL::caller override after Carp # has been compiled -{ +for my $bodge_job (2, 1, 0) { + print '# ', ($bodge_job ? 'Not ' : ''), "setting \...@db::args in caller override\n"; + if ($bodge_job == 1) { + require B; + print "# required B\n"; + } my $accum = ''; local *CORE::GLOBAL::caller = sub { local *__ANON__="fakecaller"; my @c=CORE::caller(@_); $c[0] ||= 'undef'; $accum .= "@c[0..3]\n"; - return CORE::caller(($_[0]||0)+1); + if (!$bodge_job && CORE::caller() eq 'DB') { + package DB; + return CORE::caller(($_[0]||0)+1); + } else { + return CORE::caller(($_[0]||0)+1); + } }; eval "scalar caller()"; like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval"); $accum = ''; - A::long(); + my $got = A::long(42); like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp"); + my $package = 'A'; + my $where = $bodge_job == 1 ? ' in &main::__ANON__' : ''; + my $warning = $bodge_job ? + "\Q** Incomplete caller override detected$where; \...@db::args were not set **\E" + : ''; + for (0..2) { + my $previous_package = $package; + ++$package; + like( $got, qr/${package}::long\($warning\) called at $previous_package line 7/, "Correct arguments for $package" ); + } + my $arg = $bodge_job ? $warning : 42; + like( $got, qr!A::long\($arg\) called at .*lib/Carp.t line \d+!, + 'Correct arguments for A' ); +} + +eval <<'EOT'; +no warnings 'redefine'; +sub CORE::GLOBAL::caller { + my $height = $_[0]; + $height++; + return CORE::caller($height); } +EOT + +my $got = A::long(42); + +like( $got, qr!A::long\(\Q** Incomplete caller override detected; \...@db::args\Q were not set **\E\) called at .*lib/Carp.t line \d+!, + 'Correct arguments for A' ); + +# New tests go here # line 1 "A" package A; @@ -327,3 +366,6 @@ sub long { eval{ Carp::confess("Error") }; return $@; } + +# Put new tests at "new tests go here" +__END__ -- Perl5 Master Repository
