X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=ea4fe4c97a47dbdacbd54ac953db925df7f1c605;hb=00a72df911b4089d1bce75684d2ee8da9937447d;hp=c93a8d47dcbdb71b15dd579d4110eacf78bdb810;hpb=833f66a5363cf6c3a4082afcf9d76cec72e7cdf8;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index c93a8d4..ea4fe4c 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,13 @@ ;;; *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)) + #+win32 + `(progn ,@body)) (defstruct (process (:copier nil)) pid ; PID of child process @@ -187,11 +188,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 +233,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 +302,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 +311,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 +334,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 @@ -364,25 +392,52 @@ The function is called with PROCESS as its only argument.") ;;; the master side of the pty, the file descriptor for the slave side ;;; of the pty, and the name of the tty device for the slave side. #-win32 -(defun find-a-pty () - (dolist (char '(#\p #\q)) - (dotimes (digit 16) - (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) - (master-fd (sb-unix:unix-open master-name - sb-unix:o_rdwr - #o666))) - (when master-fd - (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) - (slave-fd (sb-unix:unix-open slave-name - sb-unix:o_rdwr - #o666))) - (when slave-fd - (return-from find-a-pty - (values master-fd - slave-fd - slave-name))) - (sb-unix:unix-close master-fd)))))) - (error "could not find a pty")) +(progn + (define-alien-routine ptsname c-string (fd int)) + (define-alien-routine grantpt boolean (fd int)) + (define-alien-routine unlockpt boolean (fd int)) + + (defun find-a-pty () + ;; First try to use the Unix98 pty api. + (let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string)) + (master-fd (sb-unix:unix-open master-name + sb-unix:o_rdwr + #o666))) + (when master-fd + (grantpt master-fd) + (unlockpt master-fd) + (let* ((slave-name (ptsname master-fd)) + (slave-fd (sb-unix:unix-open slave-name + sb-unix:o_rdwr + #o666))) + (when slave-fd + (return-from find-a-pty + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)) + (error "could not find a pty"))) + ;; No dice, try using the old-school method. + (dolist (char '(#\p #\q)) + (dotimes (digit 16) + (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) + 'base-string)) + (master-fd (sb-unix:unix-open master-name + sb-unix:o_rdwr + #o666))) + (when master-fd + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) + 'base-string)) + (slave-fd (sb-unix:unix-open slave-name + sb-unix:o_rdwr + #o666))) + (when slave-fd + (return-from find-a-pty + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)))))) + (error "could not find a pty"))) #-win32 (defun open-pty (pty cookie) @@ -404,7 +459,9 @@ The function is called with PROCESS as its only argument.") :dual-channel-p t))))) (defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) + (let ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))) + `(logandc2 (the fixnum (+ (the fixnum ,n) + (1- ,bytes-per-word))) (1- ,bytes-per-word)))) (defun string-list-to-c-strvec (string-list) ;; Make a pass over STRING-LIST to calculate the amount of memory @@ -412,7 +469,7 @@ The function is called with PROCESS as its only argument.") (let ((string-bytes 0) ;; We need an extra for the null, and an extra 'cause exect ;; clobbers argv[-1]. - (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits) + (vec-bytes (* #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits) (+ (length string-list) 2)))) (declare (fixnum string-bytes vec-bytes)) (dolist (s string-list) @@ -422,7 +479,7 @@ The function is called with PROCESS as its only argument.") (let* ((total-bytes (+ string-bytes vec-bytes)) (vec-sap (sb-sys:allocate-system-memory total-bytes)) (string-sap (sap+ vec-sap vec-bytes)) - (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))) + (i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))) (declare (type (and unsigned-byte fixnum) total-bytes i) (type sb-sys:system-area-pointer vec-sap string-sap)) (dolist (s string-list) @@ -438,11 +495,11 @@ The function is called with PROCESS as its only argument.") ;; Blast the pointer to the string into place. (setf (sap-ref-sap vec-sap i) string-sap) (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))) + (incf i #.(/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits)))) ;; Blast in the last null pointer. (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits - sb-vm::n-byte-bits)) + (values vec-sap (sap+ vec-sap #.(/ sb-vm:n-machine-word-bits + sb-vm:n-byte-bits)) total-bytes)))) (defmacro with-c-strvec ((var str-list) &body body) @@ -476,7 +533,7 @@ The function is called with PROCESS as its only argument.") ;;; Is UNIX-FILENAME the name of a file that we can execute? (defun unix-filename-is-executable-p (unix-filename) - (let ((filename (coerce unix-filename 'base-string))) + (let ((filename (coerce unix-filename 'string))) (values (and (eq (sb-unix:unix-file-kind filename) :file) #-win32 (sb-unix:unix-access filename sb-unix:x_ok))))) @@ -731,7 +788,7 @@ argument. ARGS are the standard arguments that can be passed to a program. For no arguments, use NIL (which means that just the name of the program is passed as arg 0). -RUN-PROGRAM will either return a PROCESS structure. See the CMU +RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp Users Manual for details about the PROCESS structure. The &KEY arguments have the following meanings: @@ -744,7 +801,7 @@ Common Lisp Users Manual for details about the PROCESS structure. NIL, continue running Lisp until the program finishes. :INPUT Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null + input for the current process is inherited. If NIL, nul is used. If a pathname, the file so specified is used. If a stream, all the input is read from that stream and send to the subprocess. If :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends @@ -756,7 +813,7 @@ Common Lisp Users Manual for details about the PROCESS structure. NIL (the default) to return NIL from RUN-PROGRAM :OUTPUT Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - output for the current process is inherited. If NIL, /dev/null + output for the current process is inherited. If NIL, nul is used. If a pathname, the file so specified is used. If a stream, all the output from the process is written to this stream. If :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can @@ -784,7 +841,17 @@ Common Lisp Users Manual for details about the PROCESS structure. proc ;; It's friendly to allow the caller to pass any string ;; designator, but internally we'd like SIMPLE-STRINGs. - (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) + (simple-args + (mapcar + (lambda (x) + (coerce + ;; Apparently any spaces or double quotes in the arguments + ;; need to be escaped on win32. + (if (position-if (lambda (c) (find c '(#\" #\Space))) x) + (write-to-string x) + x) + 'simple-string)) + args))) (unwind-protect (let ((pfile (if search @@ -814,11 +881,17 @@ Common Lisp Users Manual for details about the PROCESS structure. (spawn pfile args-vec stdin stdout stderr (if wait 1 0))))) - (when (< handle 0) + (when (= handle -1) (error "Couldn't spawn program: ~A" (strerror))) (setf proc (if wait - (make-process :%status :exited + (make-process :pid handle + :%status :exited + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie :exit-code handle) (make-process :pid handle :%status :running @@ -826,7 +899,14 @@ Common Lisp Users Manual for details about the PROCESS structure. :output output-stream :error error-stream :status-hook status-hook - :cookie cookie)))))))))) + :cookie cookie))) + (push proc *active-processes*))))))) + (dolist (fd *close-in-parent*) + (sb-unix:unix-close fd))) + (unless proc + (dolist (fd *close-on-error*) + (sb-unix:unix-close fd))) + proc)) ;;; Install a handler for any input that shows up on the file @@ -888,6 +968,19 @@ Common Lisp Users Manual for details about the PROCESS structure. (write-string string stream :end count))))))))))) +(defun get-stream-fd (stream direction) + (typecase stream + (sb-sys:fd-stream + (values (sb-sys:fd-stream-fd stream) nil)) + (synonym-stream + (get-stream-fd (symbol-value (synonym-stream-symbol stream)) direction)) + (two-way-stream + (ecase direction + (:input + (get-stream-fd (two-way-stream-input-stream stream) direction)) + (:output + (get-stream-fd (two-way-stream-output-stream stream) direction)))))) + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created ;;; stream as the second value. @@ -911,7 +1004,8 @@ Common Lisp Users Manual for details about the PROCESS structure. (t sb-unix:o_rdwr)) #o666) (unless fd - (error "~@" + (error #-win32 "~@" + #+win32 "~@" (strerror errno))) (push fd *close-in-parent*) (values fd nil))) @@ -948,56 +1042,56 @@ Common Lisp Users Manual for details about the PROCESS structure. (t (error "couldn't duplicate file descriptor: ~A" (strerror errno))))))) - ((sb-sys:fd-stream-p object) - (values (sb-sys:fd-stream-fd object) nil)) ((streamp object) (ecase direction (:input - ;; FIXME: We could use a better way of setting up - ;; temporary files, both here and in LOAD-FOREIGN. - (dotimes (count - 256 - (error "could not open a temporary file in /tmp")) - (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) - 'base-string)) - (fd (sb-unix:unix-open name - (logior sb-unix:o_rdwr - sb-unix:o_creat - sb-unix:o_excl) - #o666))) - (sb-unix:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (sb-unix:unix-write - fd - ;; FIXME: this really should be - ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). - ;; RUN-PROGRAM should take an - ;; external-format argument, which should - ;; be passed down to here. Something - ;; similar should happen on :OUTPUT, too. - (map '(vector (unsigned-byte 8)) #'char-code line) - 0 (length line)) - (if no-cr - (return) - (sb-unix:unix-write fd newline 0 1))))) - (sb-unix:unix-lseek fd 0 sb-unix:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) + (or (get-stream-fd object :input) + ;; FIXME: We could use a better way of setting up + ;; temporary files + (dotimes (count + 256 + (error "could not open a temporary file in /tmp")) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) + 'base-string)) + (fd (sb-unix:unix-open name + (logior sb-unix:o_rdwr + sb-unix:o_creat + sb-unix:o_excl) + #o666))) + (sb-unix:unix-unlink name) + (when fd + (let ((newline (string #\Newline))) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (sb-unix:unix-write + fd + ;; FIXME: this really should be + ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). + ;; RUN-PROGRAM should take an + ;; external-format argument, which should + ;; be passed down to here. Something + ;; similar should happen on :OUTPUT, too. + (map '(vector (unsigned-byte 8)) #'char-code line) + 0 (length line)) + (if no-cr + (return) + (sb-unix:unix-write fd newline 0 1))))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) + (push fd *close-in-parent*) + (return (values fd nil))))))) (:output - (multiple-value-bind (read-fd write-fd) - (sb-unix:unix-pipe) - (unless read-fd - (error "couldn't create pipe: ~S" (strerror write-fd))) - (copy-descriptor-to-stream read-fd object cookie) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil))))) + (or (get-stream-fd object :output) + (multiple-value-bind (read-fd write-fd) + (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~S" (strerror write-fd))) + (copy-descriptor-to-stream read-fd object cookie) + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (values write-fd nil)))))) (t (error "invalid option to RUN-PROGRAM: ~S" object))))