refine Carp caller() fix and add tests

diff --git a/lib/Carp.pm b/lib/Carp.pm
index d7129da..be27c6a 100644 (file)
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -43,7 +43,7 @@ sub longmess {
     # number of call levels to go back, so calls to longmess were off
     # by one.  Other code began calling longmess and expecting this
     # behaviour, so the replacement has to emulate that behaviour.
-    my $call_pack = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->() : caller();
+    my $call_pack = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->() : caller();
     if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
       return longmess_heavy(@_);
     }
@@ -55,7 +55,7 @@ sub longmess {
 
 sub shortmess {
     # Icky backwards compatibility wrapper. :-(
-    local @CARP_NOT = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->() : caller();
+    local @CARP_NOT = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->() : caller();
     shortmess_heavy(@_);
 };
 
@@ -70,7 +70,7 @@ sub caller_info {
   my %call_info;
   @call_info{
     qw(pack file line sub has_args wantarray evaltext is_require)
-  } = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->($i) : caller($i);
+  } = defined (*CORE::GLOBAL::caller::{CODE}) ? *CORE::GLOBAL::{caller}->($i) : caller($i);
   
   unless (defined $call_info{pack}) {
     return ();
@@ -150,7 +150,7 @@ sub long_error_loc {
   my $lvl = $CarpLevel;
   {
     ++$i;
-    my $pkg = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->($i) : caller($i);
+    my $pkg = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i);
     unless(defined($pkg)) {
       # This *shouldn't* happen.
       if (%Internal) {
@@ -226,9 +226,9 @@ sub short_error_loc {
   my $lvl = $CarpLevel;
   {
 
-    my $called = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->($i) : caller($i);
+    my $called = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i);
     $i++;
-    my $caller = exists $CORE::GLOBAL::{caller} ? $CORE::GLOBAL::{caller}->($i) : caller($i);
+    my $caller = defined (*CORE::GLOBAL::caller{CODE}) ? *CORE::GLOBAL::caller{CODE}->($i) : caller($i);
 
     return 0 unless defined($caller); # What happened?
     redo if $Internal{$caller};

diff --git a/lib/Carp.t b/lib/Carp.t
index af07ed6..63b43b2 100644 (file)
--- a/lib/Carp.t
+++ b/lib/Carp.t
@@ -8,7 +8,7 @@ my $Is_VMS = $^O eq 'VMS';
 
 use Carp qw(carp cluck croak confess);
 
-plan tests => 37;
+plan tests => 39;
 
 ok 1;
 
@@ -266,6 +266,18 @@ cluck "Bang!"
 
 cluck_undef (0, "undef", 2, undef, 4);
 
+# check that Carp respects CORE::GLOBAL::caller override after Carp
+# has been compiled
+{
+    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) };
+    eval "scalar caller()";
+    like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval");
+    $accum = '';
+    A::long();
+    like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp");
+}
+
 # line 1 "A"
 package A;
 sub short {