diff options
| -rw-r--r-- | lib/Carp.pm | 8 | ||||
| -rw-r--r-- | lib/Carp.t | 25 |
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" |