bring G_KEEPERR back to the realm of sanity

Makes the G_KEEPERR logic more consistent, and in particular make it
sensibly handle non-string exceptions.  An exception in a destructor
is now always emitted as a warning, and never copied or merged into
$@ of the surrounding context.  No more clobbering exceptions being
handled elsewhere, and no more double reporting.  This fixes the rest of
[perl #74538].

2 files changed, 63 insertions, 0 deletions

diff --git a/t/lib/warnings/pp_ctl b/t/lib/warnings/pp_ctl
index afaf0a78db..9b3f2982e4 100644
--- a/t/lib/warnings/pp_ctl
+++ b/t/lib/warnings/pp_ctl
@@ -205,6 +205,24 @@ DESTROY { die "@{$_[0]} foo bar" }
 { bless ['B'], 'Foo' for 1..10 }
 EXPECT
 	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) A foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
+	(in cleanup) B foo bar at - line 4.
 	(in cleanup) B foo bar at - line 4.
 ########
 # pp_ctl.c
diff --git a/t/op/die_keeperr.t b/t/op/die_keeperr.t
new file mode 100644
index 0000000000..9b41cb5935
--- /dev/null
+++ b/t/op/die_keeperr.t
@@ -0,0 +1,45 @@
+#!perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    require 'test.pl';
+    plan(20);
+}
+
+sub End::DESTROY { $_[0]->() }
+
+sub end(&) {
+    my($c) = @_;
+    return bless(sub { $c->() }, "End");
+}
+
+foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
+    foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
+	my $warn = "";
+	local $SIG{__WARN__} = sub { $warn .= $_[0] };
+	{
+	    $@ = $outx;
+	    my $e = end { die $inx if $inx };
+	}
+	ok ref($@) eq ref($outx) && $@ eq $outx;
+	$warn =~ s/ at [^\n]*\n\z//;
+	is $warn, $inx ? "\t(in cleanup) $inx" : "";
+    }
+}
+
+{
+    no warnings "misc";
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    { my $e = end { die "aa\n"; }; }
+    is $warn, "";
+}
+
+{
+    my $warn = "";
+    local $SIG{__WARN__} = sub { $warn .= $_[0] };
+    { my $e = end { no warnings "misc"; die "aa\n"; }; }
+    is $warn, "\t(in cleanup) aa\n";
+}
+
+1;