Detect incomplete caller overrides in Carp, and avoid using bogus @DB::args.
authorNicholas Clark <nick@ccl4.org>
Wed, 21 Jul 2010 19:17:47 +0000 (20:17 +0100)
committerNicholas Clark <nick@ccl4.org>
Wed, 21 Jul 2010 19:24:27 +0000 (20:24 +0100)
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.

lib/Carp.pm
lib/Carp.t

index add42d2..cb86f9c 100644 (file)
@@ -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, '...';
index 1eee4c4..de94792 100644 (file)
@@ -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"