Indicating if a process can self crash and get signal info

2 files changed, 69 insertions, 19 deletions

diff --git a/ACE/bin/PerlACE/Process_Unix.pm b/ACE/bin/PerlACE/Process_Unix.pm
index 73b2b706665..d04c86bc0ee 100644
--- a/ACE/bin/PerlACE/Process_Unix.pm
+++ b/ACE/bin/PerlACE/Process_Unix.pm
@@ -573,16 +573,20 @@ sub Spawn ()
     return 0;
 }
 
-sub WaitKill ($)
+# The second argument is an optional output argument that, if present,
+# will be passed to check_return_value function to get the signal number
+# the process has received, if any, and/or whether there was a core dump.
+sub WaitKill ($;$)
 {
     my $self = shift;
     my $timeout = shift;
+    my $opts = shift;
 
     if ($self->{RUNNING} == 0) {
         return 0;
     }
 
-    my $status = $self->TimedWait ($timeout);
+    my $status = $self->TimedWait ($timeout, $opts);
 
     if ($status == -1) {
         print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
@@ -636,11 +640,16 @@ sub TerminateWaitKill ($)
     return $self->WaitKill ($timeout);
 }
 
-# really only for internal use
+# Really only for internal use.
+# The second optional argument indicates whether the corresponding process
+# may deliberately send a signal to itself or not. It also contains output
+# data indicating whether there was a core dump and/or the signal nubmer
+# the process has died from, if any.
 sub check_return_value ($)
 {
     my $self = shift;
     my $rc = shift;
+    my $opts = shift // {};
 
     # NSK OSS has a 32-bit waitpid() status
     my $is_NSK = ($^O eq "nonstop_kernel");
@@ -656,8 +665,7 @@ sub check_return_value ($)
         return ($rc >> 8);
     }
     elsif (($rc & 0xff) == 0) {
-        $rc >>= 8;
-        return $rc;
+        return ($rc >> 8);
     }
 
     # Ignore NSK 16-bit completion code
@@ -671,11 +679,24 @@ sub check_return_value ($)
         $dump = 1;
     }
 
-    # check for ABRT, KILL or TERM
-    if ($rc == 6 || $rc == 9 || $rc == 15) {
+    # A undef means the process does not self crash
+    my $self_crash = $opts->{self_crash};
+
+    # ABRT, KILL or TERM can be sent deliberately
+    if ($self_crash && ($rc == 6 || $rc == 9 || $rc == 15)) {
         return 0;
     }
 
+    my $signal_ref = $opts->{signal_ref};
+    if (defined $signal_ref) {
+        ${$signal_ref} = $rc;
+    }
+
+    my $dump_ref = $opts->{dump_ref};
+    if (defined $dump_ref) {
+        ${$dump_ref} = $dump;
+    }
+
     print STDERR "ERROR: <", $self->{EXECUTABLE},
                  "> exited with ";
 
@@ -798,10 +819,14 @@ sub Wait ($)
 
 }
 
-sub TimedWait ($)
+# The second argument is an optional output argument that, if present,
+# will contain the signal number that the process has received, if any,
+# and/or whether there was a core dump.
+sub TimedWait ($;$)
 {
     my $self = shift;
     my $timeout = shift;
+    my $opts = shift;
 
     if (!defined $self->{PROCESS}) {
         return 0;
@@ -817,7 +842,7 @@ sub TimedWait ($)
     while ($timeout-- != 0) {
         my $pid = waitpid ($self->{PROCESS}, &WNOHANG);
         if ($pid != 0 && $? != -1) {
-            return $self->check_return_value ($?);
+            return $self->check_return_value ($?, $opts);
         }
         select(undef, undef, undef, 0.1);
     }
diff --git a/ACE/bin/PerlACE/Process_VMS.pm b/ACE/bin/PerlACE/Process_VMS.pm
index 6c89c3f9e9b..979d22567bd 100644
--- a/ACE/bin/PerlACE/Process_VMS.pm
+++ b/ACE/bin/PerlACE/Process_VMS.pm
@@ -203,11 +203,16 @@ sub Spawn ()
     return 0;
 }
 
-sub WaitKill ($)
+# The second argument is an optional output argument that, if present,
+# will be passed to check_return_value function to get the signal number
+# the process has received, if any, and/or whether there was a core dump.
+sub WaitKill ($;$)
 {
     my $self = shift;
     my $timeout = shift;
-    my $status = $self->TimedWait ($timeout);
+    my $opts = shift;
+
+    my $status = $self->TimedWait ($timeout, $opts);
 
     if ($status == -1) {
         print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
@@ -247,11 +252,16 @@ sub TerminateWaitKill ($)
     return $self->WaitKill ($timeout);
 }
 
-# really only for internal use
+# Really only for internal use.
+# The second optional argument indicates whether the corresponding process
+# may deliberately send a signal to itself or not. It also contains output
+# data indicating whether there was a core dump and/or the signal nubmer
+# the process has died from, if any.
 sub check_return_value ($)
 {
     my $self = shift;
     my $rc = shift;
+    my $opts = shift // {};
 
     if ($rc == 0) {
         return 0;
@@ -262,8 +272,7 @@ sub check_return_value ($)
         return ($rc >> 8);
     }
     elsif (($rc & 0xff) == 0) {
-        $rc >>= 8;
-        return $rc;
+        return ($rc >> 8);
     }
 
     my $dump = 0;
@@ -273,11 +282,23 @@ sub check_return_value ($)
         $dump = 1;
     }
 
-    # check for ABRT, KILL or TERM
-    if ($rc == 6 || $rc == 9 || $rc == 15) {
+    my $self_crash = $opts->{self_crash};
+
+    # ABRT, KILL or TERM can be sent deliberately
+    if ($self_crash && ($rc == 6 || $rc == 9 || $rc == 15)) {
         return 0;
     }
 
+    my $signal_ref = $opts->{signal_ref};
+    if (defined $signal_ref) {
+        ${$signal_ref} = $rc;
+    }
+
+    my $dump_ref = $opts->{dump_ref};
+    if (defined $dump_ref) {
+        ${$dump_ref} = $dump;
+    }
+
     print STDERR "ERROR: <", $self->{EXECUTABLE},
                  "> exited with ";
 
@@ -285,7 +306,7 @@ sub check_return_value ($)
 
     print STDERR "signal $rc : ", $signame[$rc], "\n";
 
-    return 0;
+    return 255;
 }
 
 sub Kill ()
@@ -315,17 +336,21 @@ sub Wait ($)
 
 }
 
-sub TimedWait ($)
+# The second argument is an optional output argument that, if present,
+# will contain the signal number that the process has received, if any,
+# and/or whether there was a core dump.
+sub TimedWait ($;$)
 {
     my $self = shift;
     my $timeout = shift;
+    my $opts = shift;
 
     $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
 
     my $status;
     my $pid = VmsProcess::TimedWaitPid ($self->{PROCESS}, $timeout, $status);
     if ($pid > 0) {
-      return $self->check_return_value ($status);
+      return $self->check_return_value ($status, $opts);
     }
     return -1;
 }