X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=807f32c58a9e5ba88c8dd1a5d3d0717874792131;hb=4f4906712a4fa98880fb0f8f036ca2add541b8a1;hp=b854e3109faf78fa1f20c52f79ff4d2f2877bb26;hpb=7e0235c6f230d9e07a710a33479697f174f393fb;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index b854e31..807f32c 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -145,7 +145,6 @@ #+sb-doc "List of process structures for all active processes.") -#-win32 (defvar *active-processes-lock* (sb-thread:make-mutex :name "Lock for active processes.")) @@ -153,16 +152,13 @@ ;;; mutex is needed. More importantly the sigchld signal handler also ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) - #-win32 `(sb-thread::with-system-mutex (*active-processes-lock*) - ,@body) - #+win32 - `(progn ,@body)) + ,@body)) (defstruct (process (:copier nil)) pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED - exit-code ; either exit code or signal + %exit-code ; either exit code or signal core-dumped ; T if a core image was dumped #-win32 pty ; stream to child's pty, or NIL input ; stream to child's input, or NIL @@ -176,7 +172,7 @@ (print-unreadable-object (process stream :type t) (let ((status (process-status process))) (if (eq :exited status) - (format stream "~S ~S" status (process-exit-code process)) + (format stream "~S ~S" status (process-%exit-code process)) (format stream "~S ~S" (process-pid process) status))) process)) @@ -188,10 +184,17 @@ (setf (documentation 'process-pid 'function) "The pid of the child process.") #+win32 -(define-alien-routine ("GetExitCodeProcess@8" get-exit-code-process) +(define-alien-routine ("GetExitCodeProcess" get-exit-code-process) int (handle unsigned) (exit-code unsigned :out)) +(defun process-exit-code (process) + #+sb-doc + "Return the exit code of PROCESS." + (or (process-%exit-code process) + (progn (get-processes-status-changes) + (process-%exit-code process)))) + (defun process-status (process) #+sb-doc "Return the current status of PROCESS. The result is one of :RUNNING, @@ -237,6 +240,16 @@ The function is called with PROCESS as its only argument.") "Wait for PROCESS to quit running for some reason. When CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns PROCESS." + (declare (ignorable check-for-stopped)) + #+win32 + (let ((pid (process-pid process))) + (when (and pid (plusp pid)) + (without-interrupts + (do () + ((= 0 + (with-local-interrupts + (sb-win32:wait-object-or-signal pid)))))))) + #-win32 (loop (case (process-status process) (:running) @@ -287,7 +300,7 @@ PROCESS." ((and (eql pid (process-pid process)) (= signal sb-unix:sigcont)) (setf (process-%status process) :running) - (setf (process-exit-code process) nil) + (setf (process-%exit-code process) nil) (when (process-status-hook process) (funcall (process-status-hook process) process)) t) @@ -318,6 +331,11 @@ status slot." ;; maybe it should be set to :CLOSED, or similar? (with-active-processes-lock () (setf *active-processes* (delete process *active-processes*))) + #+win32 + (let ((handle (shiftf (process-pid process) nil))) + (when (and handle (plusp handle)) + (or (sb-win32:close-handle handle) + (sb-win32::win32-error 'process-close)))) process) (defun get-processes-status-changes () @@ -335,21 +353,23 @@ status slot." (waitpid (process-pid proc) t t) (when pid (setf (process-%status proc) what) - (setf (process-exit-code proc) code) + (setf (process-%exit-code proc) code) (setf (process-core-dumped proc) core) (when (process-status-hook proc) (push proc exited)) t))) #+win32 (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))) + (let ((pid (process-pid proc))) + (when pid + (multiple-value-bind (ok code) + (sb-win32::get-exit-code-process pid) + (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 @@ -386,14 +406,16 @@ status slot." ;; 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 + (logior sb-unix:o_rdwr + sb-unix:o_noctty) #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 + (logior sb-unix:o_rdwr + sb-unix:o_noctty) #o666))) (when slave-fd (return-from find-a-pty @@ -408,13 +430,15 @@ status slot." (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 + (logior sb-unix:o_rdwr + sb-unix:o_noctty) #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 + (logior sb-unix:o_rdwr + sb-unix:o_noctty) #o666))) (when slave-fd (return-from find-a-pty @@ -507,14 +531,18 @@ status slot." (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0)) (values vec-sap (sap+ vec-sap bytes-per-word) total-bytes))) -(defmacro with-c-strvec ((var str-list) &body body) - (with-unique-names (sap size) - `(multiple-value-bind (,sap ,var ,size) - (string-list-to-c-strvec ,str-list) - (unwind-protect - (progn - ,@body) - (sb-sys:deallocate-system-memory ,sap ,size))))) +(defmacro with-c-strvec ((var str-list &key null) &body body) + (once-only ((null null)) + (with-unique-names (sap size) + `(multiple-value-bind (,sap ,var ,size) + (if ,null + (values nil (sb-sys:int-sap 0)) + (string-list-to-c-strvec ,str-list)) + (unwind-protect + (progn + ,@body) + (unless ,null + (sb-sys:deallocate-system-memory ,sap ,size))))))) (sb-alien:define-alien-routine spawn #-win32 sb-alien:int @@ -527,7 +555,8 @@ status slot." (search sb-alien:int) (envp (* sb-alien:c-string)) (pty-name sb-alien:c-string) - (wait sb-alien:int)) + (wait sb-alien:int) + (pwd sb-alien:c-string)) ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the @@ -576,9 +605,8 @@ status slot." &key #-win32 (env nil env-p) #-win32 (environment - (if env-p - (unix-environment-sbcl-from-cmucl env) - (posix-environ)) + (when env-p + (unix-environment-sbcl-from-cmucl env)) environment-p) (wait t) search @@ -590,7 +618,8 @@ status slot." (error :output) (if-error-exists :error) status-hook - (external-format :default)) + (external-format :default) + (directory nil directory-p)) #+sb-doc #.(concatenate 'string @@ -675,7 +704,10 @@ Users Manual for details about the PROCESS structure."#-win32" This is a function the system calls whenever the status of the process changes. The function takes the process as an argument. :EXTERNAL-FORMAT - The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.") + The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs. + :DIRECTORY + Specifies the directory in which the program should be run. + NIL (the default) means the directory is unchanged.") #-win32 (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) @@ -717,7 +749,15 @@ Users Manual for details about the PROCESS structure."#-win32" ;; expand into UNWIND-PROTECT forms. They're just ;; syntactic sugar to make the rest of the routine slightly ;; easier to read. - (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args) + (macrolet ((with-no-with + ((&optional no) + (&whole form with-something parameters &body body)) + (declare (ignore with-something parameters)) + (typecase no + (keyword `(progn ,@body)) + (null form) + (t `(let ,no (declare (ignorable ,@no)) ,@body)))) + (with-fd-and-stream-for (((fd stream) which &rest args) &body body) `(multiple-value-bind (,fd ,stream) ,(ecase which @@ -729,20 +769,24 @@ Users Manual for details about the PROCESS structure."#-win32" ;; hard-coded symbols here. (values stdout output-stream) (get-descriptor-for ,@args)))) + (unless ,fd + (return-from run-program)) ,@body)) (with-open-pty (((pty-name pty-stream) (pty cookie)) &body body) - #+win32 `(declare (ignore ,pty ,cookie)) - #+win32 `(let (,pty-name ,pty-stream) ,@body) - #-win32 `(multiple-value-bind (,pty-name ,pty-stream) - (open-pty ,pty ,cookie :external-format external-format) - ,@body)) + `(multiple-value-bind (,pty-name ,pty-stream) + (open-pty ,pty ,cookie :external-format external-format) + ,@body)) (with-args-vec ((vec args) &body body) `(with-c-strvec (,vec ,args) ,@body)) - (with-environment-vec ((vec env) &body body) + (with-environment-vec ((vec) &body body) #+win32 `(let (,vec) ,@body) - #-win32 `(with-c-strvec (,vec ,env) ,@body))) + #-win32 + `(with-c-strvec + (,vec environment + :null (not (or environment environment-p))) + ,@body))) (with-fd-and-stream-for ((stdin input-stream) :input input cookie :direction :input @@ -759,47 +803,66 @@ Users Manual for details about the PROCESS structure."#-win32" :direction :output :if-exists if-error-exists :external-format external-format) - (with-open-pty ((pty-name pty-stream) (pty cookie)) - ;; Make sure we are not notified about the child - ;; death before we have installed the PROCESS - ;; structure in *ACTIVE-PROCESSES*. - (let (child) - (with-active-processes-lock () - (with-args-vec (args-vec simple-args) - (with-environment-vec (environment-vec environment) - (setq child (without-gcing - (spawn progname args-vec - stdin stdout stderr - (if search 1 0) - environment-vec pty-name - (if wait 1 0)))) - (unless (minusp child) - (setf proc - (apply - #'make-process - :pid child - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie - #-win32 (list :pty pty-stream - :%status :running) - #+win32 (if wait - (list :%status :exited - :exit-code child) - (list :%status :running)))) - (push proc *active-processes*))))) - ;; Report the error outside the lock. - #+win32 - (when (minusp child) - (error "Couldn't execute ~S: ~A" progname (strerror))) - #-win32 - (case child - (-2 - (error "Couldn't execute ~S: ~A" progname (strerror))) - (-1 - (error "Couldn't fork child process: ~A" (strerror)))))))))) + (with-no-with (#+win32 (pty-name pty-stream)) + (with-open-pty ((pty-name pty-stream) (pty cookie)) + ;; Make sure we are not notified about the child + ;; death before we have installed the PROCESS + ;; structure in *ACTIVE-PROCESSES*. + (let (child) + (with-active-processes-lock () + (with-no-with (#+win32 (args-vec)) + (with-args-vec (args-vec simple-args) + (with-no-with (#+win32 (environment-vec)) + (with-environment-vec (environment-vec) + (let ((pwd-string + (and directory-p (native-namestring directory)))) + (setq child + #+win32 + (sb-win32::mswin-spawn + progname + (with-output-to-string (argv) + (dolist (arg simple-args) + (write-string arg argv) + (write-char #\Space argv))) + stdin stdout stderr + search nil wait pwd-string) + #-win32 + (without-gcing + (spawn progname args-vec + stdin stdout stderr + (if search 1 0) + environment-vec pty-name + (if wait 1 0) + pwd-string)))) + (unless (minusp child) + (setf proc + (apply + #'make-process + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie + #-win32 (list :pty pty-stream + :%status :running + :pid child) + #+win32 (if wait + (list :%status :exited + :%exit-code child) + (list :%status :running + :pid child)))) + (push proc *active-processes*))))))) + ;; Report the error outside the lock. + (case child + (-1 + (error "Couldn't fork child process: ~A" + (strerror))) + (-2 + (error "Couldn't execute ~S: ~A" + progname (strerror))) + (-3 + (error "Couldn't change directory to ~S: ~A" + directory (strerror))))))))))) (dolist (fd *close-in-parent*) (sb-unix:unix-close fd)) (unless proc @@ -930,6 +993,12 @@ Users Manual for details about the PROCESS structure."#-win32" (get-stream-fd-and-external-format (two-way-stream-output-stream stream) direction)))))) +(defun get-temporary-directory () + #-win32 (or (sb-ext:posix-getenv "TMPDIR") + "/tmp") + #+win32 (or (sb-ext:posix-getenv "TEMP") + "C:/Temp")) + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created @@ -948,77 +1017,88 @@ Users Manual for details about the PROCESS structure."#-win32" ;; run afoul of disk quotas or to choke on small /tmp file systems. (flet ((make-temp-fd () (multiple-value-bind (fd name/errno) - (sb-unix:sb-mkstemp "/tmp/.run-program-XXXXXX" #o0600) + (sb-unix:sb-mkstemp (format nil "~a/.run-program-XXXXXX" + (get-temporary-directory)) + #o0600) (unless fd (error "could not open a temporary file: ~A" (strerror name/errno))) + ;; Can't unlink an opened file on Windows + #-win32 (unless (sb-unix:unix-unlink name/errno) (sb-unix:unix-close fd) (error "failed to unlink ~A" name/errno)) fd))) - (cond ((eq object t) - ;; No new descriptor is needed. - (values -1 nil)) - ((or (eq object nil) - (and (typep object 'broadcast-stream) - (not (broadcast-stream-streams object)))) - ;; Use /dev/null. - (multiple-value-bind - (fd errno) - (sb-unix:unix-open #-win32 #.(coerce "/dev/null" 'base-string) - #+win32 #.(coerce "nul" 'base-string) - (case direction - (:input sb-unix:o_rdonly) - (:output sb-unix:o_wronly) - (t sb-unix:o_rdwr)) - #o666) - (unless fd - (error #-win32 "~@" - #+win32 "~@" - (strerror errno))) - (push fd *close-in-parent*) - (values fd nil))) - ((eq object :stream) - (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe) - (unless read-fd - (error "couldn't create pipe: ~A" (strerror write-fd))) - (case direction - (:input - (push read-fd *close-in-parent*) - (push write-fd *close-on-error*) - (let ((stream (sb-sys:make-fd-stream write-fd :output t - :element-type :default - :external-format - external-format))) - (values read-fd stream))) - (:output - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (let ((stream (sb-sys:make-fd-stream read-fd :input t - :element-type :default - :external-format - external-format))) - (values write-fd stream))) - (t - (sb-unix:unix-close read-fd) - (sb-unix:unix-close write-fd) - (error "Direction must be either :INPUT or :OUTPUT, not ~S." - direction))))) - ((or (pathnamep object) (stringp object)) - ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather - ;; than munge the &rest list for OPEN, just disable keyword - ;; validation there. - (with-open-stream (file (apply #'open object :allow-other-keys t - keys)) + (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string))) + (cond ((eq object t) + ;; No new descriptor is needed. + (values -1 nil)) + ((or (eq object nil) + (and (typep object 'broadcast-stream) + (not (broadcast-stream-streams object)))) + ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) - (cond (fd - (push fd *close-in-parent*) - (values fd nil)) - (t - (error "couldn't duplicate file descriptor: ~A" - (strerror errno))))))) + (sb-unix:unix-open dev-null + (case direction + (:input sb-unix:o_rdonly) + (:output sb-unix:o_wronly) + (t sb-unix:o_rdwr)) + #o666) + (unless fd + (error "~@" + dev-null (strerror errno))) + #+win32 + (setf (sb-win32::inheritable-handle-p fd) t) + (push fd *close-in-parent*) + (values fd nil))) + ((eq object :stream) + (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~A" (strerror write-fd))) + #+win32 + (setf (sb-win32::inheritable-handle-p read-fd) + (eq direction :input) + (sb-win32::inheritable-handle-p write-fd) + (eq direction :output)) + (case direction + (:input + (push read-fd *close-in-parent*) + (push write-fd *close-on-error*) + (let ((stream (sb-sys:make-fd-stream write-fd :output t + :element-type :default + :external-format + external-format))) + (values read-fd stream))) + (:output + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (let ((stream (sb-sys:make-fd-stream read-fd :input t + :element-type :default + :external-format + external-format))) + (values write-fd stream))) + (t + (sb-unix:unix-close read-fd) + (sb-unix:unix-close write-fd) + (error "Direction must be either :INPUT or :OUTPUT, not ~S." + direction))))) + ((or (pathnamep object) (stringp object)) + ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather + ;; than munge the &rest list for OPEN, just disable keyword + ;; validation there. + (with-open-stream (file (apply #'open object :allow-other-keys t + keys)) + (when file + (multiple-value-bind + (fd errno) + (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) + (cond (fd + (push fd *close-in-parent*) + (values fd nil)) + (t + (error "couldn't duplicate file descriptor: ~A" + (strerror errno)))))))) ((streamp object) (ecase direction (:input @@ -1102,6 +1182,6 @@ Users Manual for details about the PROCESS structure."#-win32" external-format) (push read-fd *close-on-error*) (push write-fd *close-in-parent*) - (return (values write-fd nil))))))) - (t - (error "invalid option to RUN-PROGRAM: ~S" object))))) + (return (values write-fd nil))))) + (t + (error "invalid option to RUN-PROGRAM: ~S" object))))))))