fix Carp stacktraces after deleting a stash

When a stash is deleted, caller() will return undef in the package slot
for any stack level for which the deleted stash was the current package.
This made Carp confused in some cases, so fix that.

3 files changed, 142 insertions, 7 deletions

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);
+}