fully implement documented $SIG{__WARN/DIE__} behavior

The documentation for %SIG (in perlvar) states:

> The `__DIE__` handler is explicitly disabled during the call, so that
> you can die from a `__DIE__` handler.  Similarly for `__WARN__`.

This has never really been true.

There were two basic checks to prevent infinite recursion from a __DIE__
or __WARN__ handler:

 1. When an exception is thrown, if $SIG{__DIE__} references a
    subroutine that is currently active (somewhere on the call stack at
    the point of the exception), then die() unwinds the stack directly,
    bypassing the handler. (The same applies mutatis mutandis to
    $SIG{__WARN__}/warn().)
    This behavior is wrong because the subroutine may have been invoked
    normally first (i.e. not via the %SIG machinery), so the handler
    should still kick in. This is bug GH #22984.
    It also causes issues if the subroutine transfers control "sideways"
    via goto &othersub because then the registered handler is no longer
    considered "active" even though Perl code is still executing in the
    context of a __DIE__/__WARN__ handler. Then, if the goto'd &othersub
    triggers a warning/exception, the __DIE__/__WARN__ handler will be
    invoked recursively, eventually leading to a C stack overflow. This
    is bug GH #14527.
 2. The code for $SIG{__WARN__} (since c5be5b4) and $SIG{__DIE__}
    (since 8b4094f) mitigates the latter issue by internally
    unsetting the __DIE__/__WARN__ hooks for the duration of the handler
    call.
    Unfortunately, this is not a complete fix because any modification
    of $SIG{__DIE__}/$SIG{__WARN__} within the handler, even seeming
    no-ops such as $SIG{__DIE__} = $SIG{__DIE__} or { local
    $SIG{__DIE__}; }, will reïnstate the internal hooks, thus reärming
    the __DIE__/__WARN__ handlers. This is bug GH #22987.

This patch adds two interpreter-global variables that record whether we
are currently executing a __DIE__/__WARN__ handler. This fully replaces
the old heuristics by a precise check that prevents recursive handler
invocation and nothing more.

Exporter::Heavy had to be patched because it relied on the old (buggy)
behavior: It registered a $SIG{__WARN__} handler that would reässign
$SIG{__WARN__} and then call warn(), expecting the new handler to be
called (i.e. two (nested) warn hooks to be active simultaneously). This
is no longer possible with the new implementation.

Fixes #22984, #22987.

dist/Exporter/lib/Exporter.pm

@@ -6,7 +6,7 @@ no strict 'refs';
 our $Debug = 0;
 our $ExportLevel = 0;
 our $Verbose ||= 0;
-our $VERSION = '5.78';
+our $VERSION = '5.79';
 our %Cache;
 
 sub as_heavy {

dist/Exporter/lib/Exporter/Heavy.pm

@@ -3,8 +3,7 @@ package Exporter::Heavy;
 use strict;
 no strict 'refs';
 
-# On one line so MakeMaker will see it.
-our $VERSION = '5.78';
+our $VERSION = '5.79';
 
 =head1 NAME
 
@@ -39,20 +38,18 @@ sub _rebuild_cache {
 sub heavy_export {
 
     # Save the old __WARN__ handler in case it was defined
-    my $oldwarn = $SIG{__WARN__};
+    my $oldwarn = $SIG{__WARN__} || sub { warn $_[0] };
 
     # First make import warnings look like they're coming from the "use".
     local $SIG{__WARN__} = sub {
-	# restore it back so proper stacking occurs
-	local $SIG{__WARN__} = $oldwarn;
 	my $text = shift;
 	if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
 	    require Carp;
 	    local $Carp::CarpLevel = 1;	# ignore package calling us too.
-	    Carp::carp($text);
+	    $oldwarn->(Carp::shortmess($text));
 	}
 	else {
-	    warn $text;
+	    $oldwarn->($text);
 	}
     };
     local $SIG{__DIE__} = sub {

intrpvar.h

@@ -1096,6 +1096,9 @@ PERLVARA(I, mem_log, PERL_MEM_LOG_ARYLEN,  char)
  * have to worry about SV refcounts during scope enter/exit. */
 PERLVAR(I, prevailing_version, U16)
 
+PERLVARI(I, in_diehook, bool, FALSE)
+PERLVARI(I, in_warnhook, bool, FALSE)
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 

pod/perldelta.pod

@@ -442,6 +442,16 @@ manager will later use a regex to expand these into links.
 
 =item *
 
+The C<$SIG{__DIE__}> and C<$SIG{__WARN__}> handlers can no longer be invoked
+recursively, either deliberately or by accident, as described in
+L<perlvar/%SIG>. That is, when an exception (or warning) triggers a call to a
+C<$SIG{__DIE__}> (or C<$SIG{__WARN__}>) handler, further exceptions (or
+warnings) are processed directly, ignoring C<%SIG> until the original
+C<$SIG{__DIE__}> (or C<$SIG{__WARN__}>) handler call returns.
+[GH #14527], [GH #22984], [GH #22987]
+
+=item *
+
 The C<ObjectFIELDS()> for an object and C<xhv_class_fields> for the
 object's stash weren't always NULL or not-NULL, confusing sv_dump()
 (and hence Devel::Peek's Dump()) into crashing on an object with no

sv.c

@@ -16410,6 +16410,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
     PL_blockhooks	= av_dup_inc(proto_perl->Iblockhooks, param);
 
+    PL_in_diehook       = FALSE;
+    PL_in_warnhook      = FALSE;
+
     /* Call the ->CLONE method, if it exists, for each of the stashes
        identified by sv_dup() above.
     */

t/op/die_goto.t

@@ -1,39 +1,64 @@
-#!./perl -w
+#!./perl
+use v5.36;
+
 # This test checks for RT #123878/GH #14527, keeping the die handler still
 # disabled into goto'd function. And the other documented
 # exceptions to enable dying from a die handler.
 
-print "1..4\n";
+print "1..6\n";
 
 eval {
-  sub f1 { die "ok 1\n" }
-  $SIG{__DIE__} = \&f1;
-  die;
+    sub f1 { die "ok 1\n" }
+    $SIG{__DIE__} = \&f1;
+    die;
 };
 print $@;
 
 eval {
-  sub loopexit { for (0..2) { next if $_ } }
-  $SIG{__DIE__} = \&loopexit;
-  die "ok 2\n";
+    sub loopexit { for (0..2) { next if $_ } }
+    $SIG{__DIE__} = \&loopexit;
+    die "ok 2\n";
 };
 print $@;
 
 eval {
-  sub foo1 { die "ok 3\n" }
-  sub bar1 { foo1() }
-  $SIG{__DIE__} = \&bar1;
-  die;
+    sub foo1 { die "ok 3\n" }
+    sub bar1 { foo1() }
+    $SIG{__DIE__} = \&bar1;
+    die;
 };
 print $@;
 
+# GH #14527
 eval {
-  sub foo2 { die "ok 4\n" }
-  sub bar2 { goto &foo2 }
-  $SIG{__DIE__} = \&bar2;
-  die;
+    sub foo2 { die "ok 4\n" }
+    sub bar2 { goto &foo2 }
+    $SIG{__DIE__} = \&bar2;
+    die;
 };
 print $@;
+# Deep recursion on subroutine "main::foo2" at t/op/die_goto.t line 35.
+# Segmentation fault (core dumped)
 
-# Deep recursion on subroutine "main::foo2" at t/op/die_goto.t line 32.
+# GH #22987 (die)
+eval {
+    sub foo3 { die "ok 5\n" }
+    sub bar3 { { local $SIG{__DIE__}; } goto &foo3 }
+    $SIG{__DIE__} = \&bar3;
+    die;
+};
+print $@;
+# Deep recursion on subroutine "main::foo3" at t/op/die_goto.t line 46.
 # Segmentation fault (core dumped)
+
+# GH #22984
+eval {
+    my $called = 0;
+    sub hybrid {
+        $called++;
+        die "$called\n";
+    }
+    $SIG{__DIE__} = \&hybrid;
+    hybrid;
+};
+print $@ eq "2\n" ? "ok 6\n" : "not ok 6\n" . "\$\@ = $@" =~ s/^/# /mgr;

t/op/warn.t

@@ -8,7 +8,7 @@ BEGIN {
     require './charset_tools.pl';
 }
 
-plan 33;
+plan 34;
 
 my @warnings;
 my $wa = []; my $ea = [];
@@ -240,3 +240,10 @@ for my $i (1..100) {
 }
 print "OK\n";
 EOF
+
+fresh_perl_is(<<~'EOF', "good\n", {}, "GH #22987 (warn)");
+    sub foo { warn "good\n" }
+    sub bar { { local $SIG{__WARN__}; } goto &foo }
+    $SIG{__WARN__} = \&bar;
+    warn "bad";
+    EOF

util.c

@@ -1718,28 +1718,28 @@ Perl_invoke_exception_hook(pTHX_ SV *ex, bool warn)
     HV *stash;
     GV *gv;
     CV *cv;
-    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
-    SV * const oldhook = *hook;
+    SV *const oldhook = warn ? PL_warnhook : PL_diehook;
+    bool *const in_hook = warn ? &PL_in_diehook : &PL_in_warnhook;
 
-    if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
+    if (!oldhook || oldhook == PERL_WARNHOOK_FATAL || *in_hook)
         return FALSE;
 
     ENTER;
     /* sv_2cv might call Perl_croak() or Perl_warner() */
-    SAVESPTR(*hook);
-    *hook = NULL;
+    SAVEBOOL(*in_hook);
+    *in_hook = TRUE;
     cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
-    if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+    if (cv && (CvROOT(cv) || CvXSUB(cv))) {
         dSP;
         SV *exarg;
 
         ENTER;
         save_re_context();
 
         /* call_sv(cv) might call Perl_croak() or Perl_warner() */
-        SAVESPTR(*hook);
-        *hook = NULL;
+        SAVEBOOL(*in_hook);
+        *in_hook = TRUE;
 
         exarg = newSVsv(ex);
         SvREADONLY_on(exarg);