From ef4f6a5b4423aa3c2c15f6b81d2952ca9d13cbd0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 19 Apr 2006 13:53:41 +0000 Subject: [PATCH] 0.9.11.39: more RUN-PROGRAM support on Windows * PROCESS-STATUS updates the statuses of running processes on Window. * PROCESS-CLOSE, PROCESS-WAIT and PROCESS-ALIVE-P basically work. --- src/code/run-program.lisp | 95 ++++++++++++++++++++++++++++++--------------- src/runtime/win32-os.c | 5 ++- version.lisp-expr | 2 +- 3 files changed, 68 insertions(+), 34 deletions(-) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index c93a8d4..5b6c87c 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -141,7 +141,6 @@ (not (zerop (ldb (byte 1 7) status))))))))) ;;;; process control stuff -#-win32 (defvar *active-processes* nil #+sb-doc "List of process structures for all active processes.") @@ -153,11 +152,12 @@ ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a ;;; mutex is needed. More importantly the sigchld signal handler also ;;; accesses it, that's why we need without-interrupts. -#-win32 (defmacro with-active-processes-lock (() &body body) + #-win32 `(without-interrupts (sb-thread:with-mutex (*active-processes-lock*) - ,@body))) + ,@body)) + `(progn ,@body)) (defstruct (process (:copier nil)) pid ; PID of child process @@ -187,11 +187,15 @@ #+sb-doc (setf (documentation 'process-pid 'function) "The pid of the child process.") +#+win32 +(define-alien-routine ("GetExitCodeProcess@8" get-exit-code-process) + int + (handle unsigned) (exit-code unsigned :out)) + (defun process-status (process) #+sb-doc "Return the current status of PROCESS. The result is one of :RUNNING, :STOPPED, :EXITED, or :SIGNALED." - #-win32 (get-processes-status-changes) (process-%status process)) @@ -228,12 +232,11 @@ The function is called with PROCESS as its only argument.") (setf (documentation 'process-plist 'function) "A place for clients to stash things.") -#-win32 (defun process-wait (process &optional check-for-stopped) #+sb-doc - "Wait for PROCESS to quit running for some reason. - When CHECK-FOR-STOPPED is T, also returns when PROCESS is - stopped. Returns PROCESS." + "Wait for PROCESS to quit running for some reason. When +CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns +PROCESS." (loop (case (process-status process) (:running) @@ -298,7 +301,6 @@ The function is called with PROCESS as its only argument.") (t t))))) -#-win32 (defun process-alive-p (process) #+sb-doc "Return T if PROCESS is still alive, NIL otherwise." @@ -308,16 +310,19 @@ The function is called with PROCESS as its only argument.") t nil))) -#-win32 (defun process-close (process) #+sb-doc - "Close all streams connected to PROCESS and stop maintaining the status slot." + "Close all streams connected to PROCESS and stop maintaining the +status slot." (macrolet ((frob (stream abort) `(when ,stream (close ,stream :abort ,abort)))) - (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process, .. - (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE. + #-win32 + (frob (process-pty process) t) ; Don't FLUSH-OUTPUT to dead process, + (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE. (frob (process-output process) nil) - (frob (process-error process) nil)) + (frob (process-error process) nil)) + ;; FIXME: Given that the status-slot is no longer updated, + ;; maybe it should be set to :CLOSED, or similar? (with-active-processes-lock () (setf *active-processes* (delete process *active-processes*))) process) @@ -328,25 +333,47 @@ The function is called with PROCESS as its only argument.") (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) -#-win32 (defun get-processes-status-changes () + #-win32 (loop - (multiple-value-bind (pid what code core) - (wait3 t t) - (unless pid - (return)) - (let ((proc (with-active-processes-lock () - (find pid *active-processes* :key #'process-pid)))) - (when proc - (setf (process-%status proc) what) - (setf (process-exit-code proc) code) - (setf (process-core-dumped proc) core) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - (when (position what #(:exited :signaled)) - (with-active-processes-lock () - (setf *active-processes* - (delete proc *active-processes*))))))))) + (multiple-value-bind (pid what code core) + (wait3 t t) + (unless pid + (return)) + (let ((proc (with-active-processes-lock () + (find pid *active-processes* :key #'process-pid)))) + (when proc + (setf (process-%status proc) what) + (setf (process-exit-code proc) code) + (setf (process-core-dumped proc) core) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + (when (position what #(:exited :signaled)) + (with-active-processes-lock () + (setf *active-processes* + (delete proc *active-processes*)))))))) + #+win32 + (let (exited) + (with-active-processes-lock () + (setf *active-processes* + (delete-if (lambda (proc) + (multiple-value-bind (ok code) + (get-exit-code-process (process-pid proc)) + (when (and (plusp ok) (/= code 259)) + (setf (process-%status proc) :exited + (process-exit-code proc) code) + (when (process-status-hook proc) + (push proc exited)) + t))) + *active-processes*))) + ;; Can't call the hooks before all the processes have been deal + ;; with, as calling a hook may cause re-entry to + ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using wait3, + ;; but in the Windows implementation is would be deeply bad. + (dolist (proc exited) + (let ((hook (process-status-hook proc))) + (when hook + (funcall hook proc)))))) ;;;; RUN-PROGRAM and close friends @@ -827,6 +854,12 @@ Common Lisp Users Manual for details about the PROCESS structure. :error error-stream :status-hook status-hook :cookie cookie)))))))))) + ;; FIXME: this should probably use PROCESS-WAIT instead instead + ;; of special argument to SPAWN. + (unless wait + (push proc *active-processes*)) + (when (and wait status-hook) + (funcall status-hook proc)) proc)) ;;; Install a handler for any input that shows up on the file diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 10c51d7..45a4656 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -666,12 +666,13 @@ void scratch(void) GetOEMCP(); LocalFree(0); #ifndef LISP_FEATURE_SB_UNICODE - GetEnvironmentVariableA(0,0,0); + GetEnvironmentVariableA(0, 0, 0); #else - GetEnvironmentVariableW(0,0,0); + GetEnvironmentVariableW(0, 0, 0); #endif GetConsoleCP(); GetConsoleOutputCP(); + GetExitCodeProcess(0, 0); } char * diff --git a/version.lisp-expr b/version.lisp-expr index 44fc425..b07f5a7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.11.38" +"0.9.11.39" -- 1.7.10.4