X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=942517320f5010dcb3dd34e598656ad1a66d36b1;hb=c03ebb54770cfa613d4b706a80e5be231786a5d0;hp=f24829c528a174cc128ed5d126ca16049d45d3f2;hpb=543b6b16b50cd4116b699aa5e09cd90d929c2471;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index f24829c..9425173 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -45,11 +45,13 @@ ;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not ;;;; visible at GENESIS time. -(define-alien-routine wrapped-environ (* c-string)) -(defun posix-environ () +#-win32 (define-alien-routine wrapped-environ (* c-string)) +#-win32 (defun posix-environ () "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs." (c-strings->string-list (wrapped-environ))) +;#+win32 (sb-alien:define-alien-routine msvcrt-environ (* c-string)) + ;;; Convert as best we can from an SBCL representation of a Unix ;;; environment to a CMU CL representation. ;;; @@ -92,12 +94,15 @@ ;;;; Import wait3(2) from Unix. +#-win32 (define-alien-routine ("wait3" c-wait3) sb-alien:int (status sb-alien:int :out) (options sb-alien:int) (rusage sb-alien:int)) +#-win32 (defun wait3 (&optional do-not-hang check-for-stopped) + #+sb-doc "Return any available status information on child process. " (multiple-value-bind (pid status) (c-wait3 (logior (if do-not-hang @@ -134,27 +139,31 @@ (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.") +#-win32 (defvar *active-processes-lock* (sb-thread:make-mutex :name "Lock for active processes.")) ;;; *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) `(without-interrupts (sb-thread:with-mutex (*active-processes-lock*) ,@body))) + (defstruct (process (:copier nil)) pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED exit-code ; either exit code or signal core-dumped ; T if a core image was dumped - pty ; stream to child's pty, or NIL + #-win32 pty ; stream to child's pty, or NIL input ; stream to child's input, or NIL output ; stream from child's output, or NIL error ; stream from child's error output, or NIL @@ -164,7 +173,7 @@ -(defmethod print-object ((process process) stream) +#-win32 (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) (format stream "~W ~S" @@ -172,43 +181,57 @@ (process-status process))) process) +#+sb-doc (setf (documentation 'process-p 'function) "T if OBJECT is a PROCESS, NIL otherwise.") +#+sb-doc (setf (documentation 'process-pid 'function) "The pid of the child process.") +#-win32 (defun process-status (process) + #+sb-doc "Return the current status of PROCESS. The result is one of :RUNNING, :STOPPED, :EXITED, or :SIGNALED." (get-processes-status-changes) (process-%status process)) +#+sb-doc (setf (documentation 'process-exit-code 'function) "The exit code or the signal of a stopped process.") +#+sb-doc (setf (documentation 'process-core-dumped 'function) "T if a core image was dumped by the process.") +#+sb-doc (setf (documentation 'process-pty 'function) "The pty stream of the process or NIL.") +#+sb-doc (setf (documentation 'process-input 'function) "The input stream of the process or NIL.") +#+sb-doc (setf (documentation 'process-output 'function) "The output stream of the process or NIL.") +#+sb-doc (setf (documentation 'process-error 'function) "The error stream of the process or NIL.") +#+sb-doc (setf (documentation 'process-status-hook 'function) "A function that is called when PROCESS changes its status. The function is called with PROCESS as its only argument.") +#+sb-doc (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." @@ -224,7 +247,7 @@ The function is called with PROCESS as its only argument.") (sb-sys:serve-all-events 1)) process) -#-hpux +#-(or hpux win32) ;;; Find the current foreground process group id. (defun find-current-foreground-process (proc) (with-alien ((result sb-alien:int)) @@ -238,7 +261,9 @@ The function is called with PROCESS as its only argument.") result)) (process-pid proc)) +#-win32 (defun process-kill (process signal &optional (whom :pid)) + #+sb-doc "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is :PTY-PROCESS-GROUP deliver the signal to whichever process group is @@ -274,7 +299,9 @@ 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." (let ((status (process-status process))) (if (or (eq status :running) @@ -282,7 +309,9 @@ 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." (macrolet ((frob (stream abort) `(when ,stream (close ,stream :abort ,abort)))) @@ -295,11 +324,11 @@ The function is called with PROCESS as its only argument.") process) ;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes -(defun sigchld-handler (ignore1 ignore2 ignore3) +#-win32 (defun sigchld-handler (ignore1 ignore2 ignore3) (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) -(defun get-processes-status-changes () +#-win32 (defun get-processes-status-changes () (loop (multiple-value-bind (pid what code core) (wait3 t t) @@ -327,12 +356,12 @@ The function is called with PROCESS as its only argument.") (defvar *close-in-parent* nil) ;;; list of handlers installed by RUN-PROGRAM -(defvar *handlers-installed* nil) +#-win32 (defvar *handlers-installed* nil) ;;; Find an unused pty. Return three values: the file descriptor for ;;; 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. -(defun find-a-pty () +#-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)) @@ -352,7 +381,7 @@ The function is called with PROCESS as its only argument.") (sb-unix:unix-close master-fd)))))) (error "could not find a pty")) -(defun open-pty (pty cookie) +#-win32 (defun open-pty (pty cookie) (when pty (multiple-value-bind (master slave name) @@ -367,6 +396,7 @@ The function is called with PROCESS as its only argument.") (copy-descriptor-to-stream new-fd pty cookie))) (values name (sb-sys:make-fd-stream master :input t :output t + :element-type :default :dual-channel-p t))))) (defmacro round-bytes-to-words (n) @@ -421,7 +451,7 @@ The function is called with PROCESS as its only argument.") ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -(sb-alien:define-alien-routine spawn sb-alien:int +#-win32 (sb-alien:define-alien-routine spawn sb-alien:int (program sb-alien:c-string) (argv (* sb-alien:c-string)) (envp (* sb-alien:c-string)) @@ -430,8 +460,16 @@ The function is called with PROCESS as its only argument.") (stdout sb-alien:int) (stderr sb-alien:int)) +#+win32 (sb-alien:define-alien-routine spawn sb-win32::handle + (program sb-alien:c-string) + (argv (* sb-alien:c-string)) + (stdin sb-alien:int) + (stdout sb-alien:int) + (stderr sb-alien:int) + (wait sb-alien:int)) + ;;; Is UNIX-FILENAME the name of a file that we can execute? -(defun unix-filename-is-executable-p (unix-filename) +#-win32 (defun unix-filename-is-executable-p (unix-filename) (declare (type simple-string unix-filename)) (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) @@ -440,8 +478,10 @@ The function is called with PROCESS as its only argument.") (defun find-executable-in-search-path (pathname &optional (search-path (posix-getenv "PATH"))) - "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH" - (loop for end = (position #\: search-path :start (if end (1+ end) 0)) + #+sb-doc + "Find the first executable file matching PATHNAME in any of the +colon-separated list of pathnames SEARCH-PATH" + (loop for end = (position #-win32 #\: #+win32 #\; search-path :start (if end (1+ end) 0)) and start = 0 then (and end (1+ end)) while start ;; the truename of a file naming a directory is the @@ -449,8 +489,9 @@ The function is called with PROCESS as its only argument.") ;; that's noncompliant -- CSR, c. 2003-08-10 for truename = (probe-file (subseq search-path start end)) for fullpath = (when truename (merge-pathnames pathname truename)) - when (and fullpath + when #-win32 (and fullpath (unix-filename-is-executable-p (namestring fullpath))) + #+win32 t return fullpath)) ;;; FIXME: There shouldn't be two semiredundant versions of the @@ -496,7 +537,8 @@ The function is called with PROCESS as its only argument.") ;;; ;;; RUN-PROGRAM returns a PROCESS structure for the process if ;;; the fork worked, and NIL if it did not. -(defun run-program (program args + +#-win32 (defun run-program (program args &key (env nil env-p) (environment (if env-p @@ -513,6 +555,7 @@ The function is called with PROCESS as its only argument.") (error :output) (if-error-exists :error) status-hook) + #+sb-doc "RUN-PROGRAM creates a new Unix process running the Unix program found in the file specified by the PROGRAM argument. ARGS are the standard arguments that can be passed to a Unix program. For no arguments, use NIL @@ -665,6 +708,122 @@ The function is called with PROCESS as its only argument.") (process-wait proc)) proc)) +#+win32 (defun run-program (program args + &key + (wait t) + search + input + if-input-does-not-exist + output + (if-output-exists :error) + (error :output) + (if-error-exists :error) + status-hook) + "RUN-PROGRAM creates a new process specified by the PROGRAM 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 NIL or a PROCESS structure. See the CMU + Common Lisp Users Manual for details about the PROCESS structure. + + The &KEY arguments have the following meanings: + :SEARCH + Look for PROGRAM in each of the directories along the $PATH + environment variable. Otherwise an absolute pathname is required. + (See also FIND-EXECUTABLE-IN-SEARCH-PATH) + :WAIT + If non-NIL (default), wait until the created process finishes. If + 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 + 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 + its output to the process. Defaults to NIL. + :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file) + can be one of: + :ERROR to generate an error + :CREATE to create an empty file + 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 + 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 + be read to get the output. Defaults to NIL. + :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file) + can be one of: + :ERROR (the default) to generate an error + :SUPERSEDE to supersede the file with output from the program + :APPEND to append output from the program to the file + NIL to return NIL from RUN-PROGRAM, without doing anything + :ERROR and :IF-ERROR-EXISTS + Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be + specified as :OUTPUT in which case all error output is routed to the + same place as normal output. + :STATUS-HOOK + This is a function the system calls whenever the status of the + process changes. The function takes the process as an argument." + + ;; Prepend the program to the argument list. + (push (namestring program) args) + (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to + ;; communicate cleanup info. + *close-on-error* + *close-in-parent* + ;; Establish PROC at this level so that we can return it. + 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))) + (unwind-protect + (let ((pfile + (if search + (namestring (find-executable-in-search-path program)) + (namestring program))) + (cookie (list 0))) + (unless pfile + (error "no such program: ~S" program)) + (multiple-value-bind (stdin input-stream) + (get-descriptor-for input cookie + :direction :input + :if-does-not-exist if-input-does-not-exist) + (multiple-value-bind (stdout output-stream) + (get-descriptor-for output cookie + :direction :output + :if-exists if-output-exists) + (multiple-value-bind (stderr error-stream) + (if (eq error :output) + (values stdout output-stream) + (get-descriptor-for error cookie + :direction :output + :if-exists if-error-exists)) + (with-c-strvec (args-vec simple-args) + (let ((iwait (if wait 1 0))) + (declare (type fixnum iwait)) + (let ((child-pid + (without-gcing + (spawn pfile args-vec + stdin stdout stderr + iwait)))) + (when (< child-pid 0) + (error "couldn't spawn program: ~A" + (strerror))) + (setf proc + (if wait + nil + (make-process :pid child-pid + :%status :running + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie))))))))))) + proc)) + ;;; Install a handler for any input that shows up on the file ;;; descriptor. The handler reads the data and writes it to the ;;; stream. @@ -699,9 +858,10 @@ The function is called with PROCESS as its only argument.") (sb-unix:unix-read descriptor (alien-sap buf) 256) - (cond ((or (and (null count) - (eql errno sb-unix:eio)) - (eql count 0)) + (cond (#-win32(or (and (null count) + (eql errno sb-unix:eio)) + (eql count 0)) + #+win32(<= count 0) (sb-sys:remove-fd-handler handler) (setf handler nil) (decf (car cookie)) @@ -738,7 +898,8 @@ The function is called with PROCESS as its only argument.") ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) + (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) @@ -757,12 +918,14 @@ The function is called with PROCESS as its only argument.") (:input (push read-fd *close-in-parent*) (push write-fd *close-on-error*) - (let ((stream (sb-sys:make-fd-stream write-fd :output t))) + (let ((stream (sb-sys:make-fd-stream write-fd :output t + :element-type :default))) (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))) + (let ((stream (sb-sys:make-fd-stream read-fd :input t + :element-type :default))) (values write-fd stream))) (t (sb-unix:unix-close read-fd)