[Git][cmucl/cmucl][master] 3 commits: Fix #41: Report proper process status
Raymond Toy
rtoy at common-lisp.net
Sat Sep 16 21:02:44 UTC 2017
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
f05cb10a by Raymond Toy at 2017-09-08T20:38:41-07:00
Fix #41: Report proper process status
The main problem is that we weren't calling wait3 with WCONTINUED so
that we would be signaled when the process continues. And we also
need to check that result of wait call was WCONTINUED>
Replace the wait3 routine with a C routine (prog_status) so we don't
have to deal with the OS-specific flags. This function basically
returns what the lisp function wait3 did.
Use this function in GET-PROCESSES-STATUS-CHANGES.
- runprog.c:
- Add prog_status
- run-program.lisp:
- Use prog_status instead of wait3
- issues.lisp:
- Add basic test
- - - - -
65ce358d by Raymond Toy at 2017-09-15T22:50:47-07:00
Fix up minor issues in implementation
- process-alive-p should return T for continued processes
- Simplify prog-status slightly by making the status code array start
:signaled instead of nil.
- Update prog_status with enum to specify the codes to make it
clearer what they mean and to make it clearer that it matches the
expectations in prog-status.
- - - - -
99ebe80c by Raymond Toy at 2017-09-16T21:02:40+00:00
Merge branch 'rtoy-fix-issue-41' into 'master'
Fix #41: Report proper process status
Closes #41
See merge request !23
- - - - -
3 changed files:
- src/code/run-program.lisp
- src/lisp/runprog.c
- tests/issues.lisp
Changes:
=====================================
src/code/run-program.lisp
=====================================
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -34,6 +34,12 @@
(options c-call:int)
(rusage c-call:int))
+(alien:def-alien-routine ("prog_status" c-prog-status) c-call:void
+ (pid c-call:int :out)
+ (what c-call:int :out)
+ (code c-call:int :out)
+ (corep c-call:int :out))
+
(eval-when (load eval compile)
(defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
(defconstant wait-wuntraced #-svr4 2 #+svr4 4)
@@ -73,6 +79,16 @@
signal
(not (zerop (ldb (byte 1 7) status)))))))))
+(defun prog-status ()
+ (multiple-value-bind (ret pid what code corep)
+ (c-prog-status)
+ (declare (ignore ret))
+ (when (plusp pid)
+ (values pid
+ (aref #(:signaled :stopped :continued :exited) what)
+ code
+ (not (zerop corep))))))
+
;;;; Process control stuff.
@@ -201,7 +217,8 @@
(declare (type process proc))
(let ((status (process-status proc)))
(if (or (eq status :running)
- (eq status :stopped))
+ (eq status :stopped)
+ (eq status :continued))
t
nil)))
@@ -235,7 +252,7 @@
(defun get-processes-status-changes ()
(loop
(multiple-value-bind (pid what code core)
- (wait3 t t)
+ (prog-status)
(unless pid
(return))
(let ((proc (find pid *active-processes* :key #'process-pid)))
=====================================
src/lisp/runprog.c
=====================================
--- a/src/lisp/runprog.c
+++ b/src/lisp/runprog.c
@@ -3,6 +3,8 @@
*
*/
+#include <stdio.h>
+
#include <sys/ioctl.h>
#include <errno.h>
#include <fcntl.h>
@@ -10,6 +12,7 @@
#include <stdlib.h>
#include <termios.h>
#include <unistd.h>
+#include <sys/wait.h>
pid_t
spawn(char *program, char *argv[], char *envp[], char *pty_name,
@@ -70,3 +73,64 @@ spawn(char *program, char *argv[], char *envp[], char *pty_name,
/* The exec didn't work, flame out. */
exit(1);
}
+
+/*
+ * Call waitpid and return appropriate information about what happened.
+ *
+ * what - int taking the values:
+ * 0 - ok
+ * 1 - signaled
+ * 2 - stopped
+ * 3 - continued
+ * 4 - exited
+ * code - the terminating signal
+ * core - true (non-zero) if a core was produced
+ */
+
+/*
+ * Status codes. Must be in the same order as in ext::prog-status in
+ * run-program.lisp
+ */
+enum status_code {
+ SIGNALED,
+ STOPPED,
+ CONTINUED,
+ EXITED
+};
+
+void
+prog_status(pid_t* pid, int* what, int* code, int* corep)
+{
+ pid_t w;
+ int status;
+
+ w = waitpid(-1, &status, WNOHANG | WUNTRACED | WCONTINUED);
+ *pid = w;
+
+ if (w == -1) {
+
+ return;
+ }
+
+ if (WIFEXITED(status)) {
+ *what = EXITED;
+ *code = WEXITSTATUS(status);
+ *corep = 0;
+ } else if (WIFSIGNALED(status)) {
+ *what = SIGNALED;
+ *code = WTERMSIG(status);
+ *corep = WCOREDUMP(status);
+ } else if (WIFSTOPPED(status)) {
+ *what = STOPPED;
+ *code = WSTOPSIG(status);
+ *corep = 0;
+ } else if (WIFCONTINUED(status)) {
+ *what = CONTINUED;
+ *code = 0;
+ *corep = 0;
+ } else {
+ fprintf(stderr, "pid = %d, status = 0x%x\n", *pid, status);
+ }
+
+ return;
+}
=====================================
tests/issues.lisp
=====================================
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -367,3 +367,41 @@
;; get-universal-time only has an accuracy of 1 sec, just verify
;; more than 3 sec have elapsed.
(assert-true (>= (- (get-universal-time) start-time) 3)))))
+
+(defun issue-41-tester (stop-signal)
+ (let* ((p (ext:run-program "/bin/sleep" '("5") :wait nil))
+ (pid (ext:process-pid p)))
+ (flet ((external-kill (pid signal)
+ (ext:run-program "/usr/bin/env"
+ (list "kill"
+ (format nil "-~D" signal)
+ (format nil "~D" pid)))))
+ (assert-eql :running (ext:process-status p))
+
+ (external-kill pid stop-signal)
+ (sleep 1)
+ (assert-eql :stopped (ext:process-status p))
+
+ (external-kill pid unix:sigcont)
+ (sleep 1)
+ (assert-eql :continued (ext:process-status p))
+
+ (external-kill pid stop-signal)
+ (sleep 1)
+ (assert-eql :stopped (ext:process-status p))
+
+ (external-kill pid unix:sigcont)
+ (sleep 1)
+ (assert-eql :continued (ext:process-status p))
+
+ (sleep 5)
+ (assert-eql :exited (ext:process-status p)))))
+
+(define-test issue.41.1
+ (:tag :issues)
+ (issue-41-tester unix:sigstop))
+
+#+nil
+(define-test issue.41.2
+ (:tag :issues)
+ (issue-41-tester unix:sigtstp))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/4acd1d80b63cd3d639fe729183a027fca15e249e...99ebe80cf61a21ea9b2bacf7b1d30e98217e34f6
---
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/4acd1d80b63cd3d639fe729183a027fca15e249e...99ebe80cf61a21ea9b2bacf7b1d30e98217e34f6
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20170916/824a5fd5/attachment-0001.html>
More information about the cmucl-cvs
mailing list