[perl #52000] Warn/abort on attempted perl exit

diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t
index fb9db91..f47d036 100644 (file)
--- a/lib/ExtUtils/t/Embed.t
+++ b/lib/ExtUtils/t/Embed.t
@@ -17,7 +17,7 @@ print $fh <DATA>;
 close($fh);
 
 $| = 1;
-print "1..9\n";
+print "1..10\n";
 my $cc = $Config{'cc'};
 my $cl  = ($^O eq 'MSWin32' && $cc eq 'cl');
 my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?<!\S)-Zexe\b/;
@@ -136,7 +136,7 @@ my $embed_test = File::Spec->catfile(File::Spec->curdir, $exe);
 $embed_test = "run/nodebug $exe" if $^O eq 'VMS';
 print "# embed_test = $embed_test\n";
 $status = system($embed_test);
-print (($status? 'not ':'')."ok 9 # system returned $status\n");
+print (($status? 'not ':'')."ok 10 # system returned $status\n");
 unlink($exe,"embed_test.c",$obj);
 unlink("$exe.manifest") if $cl and $Config{'ccversion'} =~ /^(\d+)/ and $1 >= 14;
 unlink("$exe$Config{exe_ext}") if $skip_exe;
@@ -154,7 +154,7 @@ __END__
 
 #define my_puts(a) if(puts(a) < 0) exit(666)
 
-static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]", NULL };
+static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]; $SIG{__WARN__} = sub { print qq[ok 6\\n] if $_[0] =~ /Unexpected exit/; }; exit 5;", NULL };
 
 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
 static struct perl_vars *my_plvarsp;
@@ -184,6 +184,7 @@ int main(int argc, char **argv, char **env) {
     my_puts("ok 2");
 
     perl_construct(my_perl);
+    my_perl->Iexit_flags |= PERL_EXIT_WARN;
 
     my_puts("ok 3");
 
@@ -195,15 +196,15 @@ int main(int argc, char **argv, char **env) {
 
     perl_run(my_perl);
 
-    my_puts("ok 6");
+    my_puts("ok 7");
 
     perl_destruct(my_perl);
 
-    my_puts("ok 7");
+    my_puts("ok 8");
 
     perl_free(my_perl);
 
-    my_puts("ok 8");
+    my_puts("ok 9");
 
     PERL_SYS_TERM();
 

diff --git a/perl.c b/perl.c
index 57d51e6..f31c1ed 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -4950,6 +4950,14 @@ void
 Perl_my_exit(pTHX_ U32 status)
 {
     dVAR;
+    if (PL_exit_flags & PERL_EXIT_ABORT) {
+       abort();
+    }
+    if (PL_exit_flags & PERL_EXIT_WARN) {
+       PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+       Perl_warn(aTHX_ "Unexpected exit %u", status);
+       PL_exit_flags &= ~PERL_EXIT_ABORT;
+    }
     switch (status) {
     case 0:
        STATUS_ALL_SUCCESS;
@@ -5047,6 +5055,14 @@ Perl_my_failure_exit(pTHX)
            STATUS_UNIX_SET(255);
     }
 #endif
+    if (PL_exit_flags & PERL_EXIT_ABORT) {
+       abort();
+    }
+    if (PL_exit_flags & PERL_EXIT_WARN) {
+       PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+       Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
+       PL_exit_flags &= ~PERL_EXIT_ABORT;
+    }
     my_exit_jump();
 }
 

diff --git a/perl.h b/perl.h
index cfcf871..d3648e1 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2953,6 +2953,8 @@ typedef pthread_key_t     perl_key;
 /* flags in PL_exit_flags for nature of exit() */
 #define PERL_EXIT_EXPECTED     0x01
 #define PERL_EXIT_DESTRUCT_END  0x02  /* Run END in perl_destruct */
+#define PERL_EXIT_WARN         0x04  /* Warn if Perl_my_exit() or Perl_my_failure_exit() called */
+#define PERL_EXIT_ABORT                0x08  /* Call abort() if Perl_my_exit() or Perl_my_failure_exit() called */
 
 #ifndef PERL_CORE
 /* format to use for version numbers in file/directory names */