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.

2 files changed, 28 insertions, 5 deletions

diff --git a/lib/Carp.pm b/lib/Carp.pm
index add42d27fe..cb86f9cdd8 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -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,12 @@ 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) {
+      @args = "** Incomplete caller override detected; \@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 1eee4c4731..de9479269c 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 => 49;
 
 ok 1;
 
@@ -270,20 +270,37 @@ cluck_undef (0, "undef", 2, undef, 4);
 
 # check that Carp respects CORE::GLOBAL::caller override after Carp
 # has been compiled
-{
+for my $proper_job (0, 1) {
+    print '# ', ($proper_job ? '' : 'Not '), "setting \@DB::args in caller override\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 ($proper_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 $warning = $proper_job ? ''
+	: "\Q** Incomplete caller override detected; \@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 = $proper_job ? 42 : $warning;
+    like( $got, qr!A::long\($arg\) called at .*lib/Carp.t line \d+!,
+	  'Correct arguments for A' );
 }
 
 # line 1 "A"