From 248ae9a50ac9959cef3e64dbc204644da4b8761a Mon Sep 17 00:00:00 2001 From: David Golden Date: Fri, 6 Nov 2009 23:38:27 -0500 Subject: [PATCH] refine Carp caller() fix and add tests --- lib/Carp.pm | 12 ++++++------ lib/Carp.t | 14 +++++++++++++- 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/lib/Carp.pm b/lib/Carp.pm index d7129da..be27c6a 100644 --- 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 --- 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 { -- 2.7.4