diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | dist/Carp/lib/Carp.pm | 36 | ||||
| -rw-r--r-- | dist/Carp/lib/Carp/Heavy.pm | 2 | ||||
| -rw-r--r-- | dist/Carp/t/stash_deletion.t | 111 |
4 files changed, 143 insertions, 7 deletions
@@ -3068,6 +3068,7 @@ dist/Carp/lib/Carp.pm Error message extension dist/Carp/Makefile.PL makefile writer for Carp dist/Carp/t/Carp.t See if Carp works dist/Carp/t/heavy.t See if Carp::Heavy works +dist/Carp/t/stash_deletion.t See if Carp handles stash deletion dist/Carp/t/swash.t See if Carp avoids breaking swash loading dist/Carp/t/vivify_gv.t See if Carp leaves utf8:: stuff alone dist/Carp/t/vivify_stash.t See if Carp leaves utf8:: stash alone diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index ba351ec714..b35ab69578 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -24,7 +24,7 @@ BEGIN { } } -our $VERSION = '1.27'; +our $VERSION = '1.28'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -130,7 +130,7 @@ sub caller_info { = $cgc ? $cgc->($i) : caller($i); } - unless ( defined $call_info{pack} ) { + unless ( defined $call_info{file} ) { return (); } @@ -232,6 +232,12 @@ sub get_subname { } } + # this can happen on older perls when the sub (or the stash containing it) + # has been deleted + if ( !defined( $info->{sub} ) ) { + return '__ANON__::__ANON__'; + } + return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; } @@ -253,9 +259,14 @@ sub long_error_loc { last; } else { - - # OK, now I am irritated. - return 2; + # this can happen when the stash has been deleted + # in that case, just assume that it's a reasonable place to + # stop (the file and line data will still be intact in any + # case) - the only issue is that we can't detect if the + # deleted package was internal (so don't do that then) + # -doy + redo unless 0 > --$lvl; + last; } } redo if $CarpInternal{$pkg}; @@ -334,7 +345,20 @@ sub short_error_loc { $i++; my $caller = $cgc ? $cgc->($i) : caller($i); - return 0 unless defined($caller); # What happened? + if (!defined($caller)) { + my @caller = $cgc ? $cgc->($i) : caller($i); + if (@caller) { + # if there's no package but there is other caller info, then + # the package has been deleted - treat this as a valid package + # in this case + redo if defined($called) && $CarpInternal{$called}; + redo unless 0 > --$lvl; + last; + } + else { + return 0; + } + } redo if $Internal{$caller}; redo if $CarpInternal{$caller}; redo if $CarpInternal{$called}; diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm index 5620dc9d74..5b2b4487bd 100644 --- a/dist/Carp/lib/Carp/Heavy.pm +++ b/dist/Carp/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.27'; +our $VERSION = '1.28'; 1; diff --git a/dist/Carp/t/stash_deletion.t b/dist/Carp/t/stash_deletion.t new file mode 100644 index 0000000000..9d1c786f97 --- /dev/null +++ b/dist/Carp/t/stash_deletion.t @@ -0,0 +1,111 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 15; + +use Carp; + +{ + my $sub = eval <<'EVAL'; +package Die; +sub { +#line 1 foo + die "blah"; +} +EVAL + ok(!$@); + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); + { + no strict 'refs'; + delete ${'::'}{'Die::'}; + } + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); +} + +{ + my $sub = eval <<'EVAL'; +package Confess; +sub { +#line 1 foo + Carp::confess("blah"); +} +EVAL + ok(!$@); + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); + { + no strict 'refs'; + delete ${'::'}{'Confess::'}; + } + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); +} + +{ + my $sub = eval <<'EVAL'; +package CroakHelper; +sub x { + Carp::croak("blah"); +} +package Croak; +sub { +#line 1 foo + CroakHelper::x(); +} +EVAL + ok(!$@); + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); + { + no strict 'refs'; + delete ${'::'}{'Croak::'}; + } + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); + { + no strict 'refs'; + delete ${'::'}{'CroakHelper::'}; + } + eval { $sub->() }; + like($@, qr/^blah at foo line 1/); +} + +{ + # the amount of information available and how it is displayed varies quite + # a bit depending on the version of perl (specifically, what caller returns + # in that version), so there is a bit of fiddling around required to handle + # that + my $unknown_pat = qr/__ANON__::/; + $unknown_pat = qr/$unknown_pat|\(unknown\)/ + if $] < 5.014; + + my $sub = eval <<'EVAL'; +package SubHelper; +sub x { + Carp::confess("blah"); +} +package Sub; +sub { +#line 1 foo + SubHelper::x(); +} +EVAL + ok(!$@); + eval { $sub->() }; + unlike($@, qr/$unknown_pat/); + { + no strict 'refs'; + delete ${'::'}{'Sub::'}; + } + eval { $sub->() }; + like($@, qr/$unknown_pat|Sub::/); + unlike($@, qr/$unknown_pat.*$unknown_pat/s); + { + no strict 'refs'; + delete ${'::'}{'SubHelper::'}; + } + eval { $sub->() }; + like($@, qr/(?:$unknown_pat|SubHelper::).*(?:$unknown_pat|Sub::)/s); +} |