X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=0f31a0fa9e8115a274969cd8f5ad6aec3d1186a2;hb=6bc7c19167d7bf98ff6cdf45e4ccd9998311bdd8;hp=10b7fdc59dc7c0d5a1dee83754da60692bb99862;hpb=3fbcd9b98c58d80858d1e0f9834aaaa83283cbba;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 10b7fdc..0f31a0f 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -97,23 +97,23 @@ ;;;; Import wait3(2) from Unix. #-win32 -(define-alien-routine ("wait3" c-wait3) sb-alien:int +(define-alien-routine ("waitpid" c-waitpid) sb-alien:int + (pid sb-alien:int) (status sb-alien:int :out) - (options sb-alien:int) - (rusage sb-alien:int)) + (options sb-alien:int)) #-win32 -(defun wait3 (&optional do-not-hang check-for-stopped) +(defun waitpid (pid &optional do-not-hang check-for-stopped) #+sb-doc - "Return any available status information on child process. " + "Return any available status information on child process with PID." (multiple-value-bind (pid status) - (c-wait3 (logior (if do-not-hang - sb-unix:wnohang - 0) - (if check-for-stopped - sb-unix:wuntraced - 0)) - 0) + (c-waitpid pid + (logior (if do-not-hang + sb-unix:wnohang + 0) + (if check-for-stopped + sb-unix:wuntraced + 0))) (cond ((or (minusp pid) (zerop pid)) nil) @@ -154,7 +154,8 @@ ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) #-win32 - `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*) + `(sb-thread::with-system-mutex (*active-processes-lock*) + ,@body) #+win32 `(progn ,@body)) @@ -248,7 +249,7 @@ PROCESS." (sb-sys:serve-all-events 1)) process) -#-(or hpux win32) +#-win32 ;;; Find the current foreground process group id. (defun find-current-foreground-process (proc) (with-alien ((result sb-alien:int)) @@ -273,18 +274,11 @@ PROCESS." ((:pid :process-group) (process-pid process)) (:pty-process-group - #-hpux (find-current-foreground-process process))))) (multiple-value-bind (okay errno) (case whom - #+hpux - (:pty-process-group - (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty process)) - sb-unix:TIOCSIGSEND - (sb-sys:int-sap - signal))) - ((:process-group #-hpux :pty-process-group) + ((:process-group) (sb-unix:unix-killpg pid signal)) (t (sb-unix:unix-kill pid signal))) @@ -326,36 +320,28 @@ status slot." (setf *active-processes* (delete process *active-processes*))) process) -;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes -#-win32 -(defun sigchld-handler (ignore1 ignore2 ignore3) - (declare (ignore ignore1 ignore2 ignore3)) - (get-processes-status-changes)) - (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*)))))))) - #+win32 (let (exited) (with-active-processes-lock () (setf *active-processes* - (delete-if (lambda (proc) + (delete-if #-win32 + (lambda (proc) + ;; Wait only on pids belonging to processes + ;; started by RUN-PROGRAM. There used to be a + ;; WAIT3 call here, but that makes direct + ;; WAIT, WAITPID usage impossible due to the + ;; race with the SIGCHLD signal handler. + (multiple-value-bind (pid what code core) + (waitpid (process-pid proc) t t) + (when pid + (setf (process-%status proc) what) + (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)) @@ -367,8 +353,8 @@ status slot." *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. + ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using waitpid, + ;; but in the Windows implementation it would be deeply bad. (dolist (proc exited) (let ((hook (process-status-hook proc))) (when hook @@ -390,7 +376,7 @@ status slot." ;;; 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. -#-win32 +#-(or win32 openbsd) (progn (define-alien-routine ptsname c-string (fd int)) (define-alien-routine grantpt boolean (fd int)) @@ -437,9 +423,24 @@ status slot." slave-name))) (sb-unix:unix-close master-fd)))))) (error "could not find a pty"))) +#+openbsd +(progn + (define-alien-routine openpty int (amaster int :out) (aslave int :out) + (name (* char)) (termp (* t)) (winp (* t))) + (defun find-a-pty () + (with-alien ((name-buf (array char 16))) + (multiple-value-bind (return-val master-fd slave-fd) + (openpty (cast name-buf (* char)) nil nil) + (if (zerop return-val) + (values master-fd + slave-fd + (sb-alien::c-string-to-string (alien-sap name-buf) + (sb-impl::default-external-format) + 'character)) + (error "could not find a pty")))))) #-win32 -(defun open-pty (pty cookie) +(defun open-pty (pty cookie &key (external-format :default)) (when pty (multiple-value-bind (master slave name) @@ -451,7 +452,7 @@ status slot." (unless new-fd (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty cookie))) + (copy-descriptor-to-stream new-fd pty cookie external-format))) (values name (sb-sys:make-fd-stream master :input t :output t :element-type :default @@ -489,7 +490,7 @@ status slot." ;; Put the pointer in the vector. (setf (sap-ref-sap vec-sap vec-index-offset) string-sap) ;; Advance string-sap for the next string. - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ size)))) + (setf string-sap (sap+ string-sap (round-bytes-to-words size))) (incf vec-index-offset bytes-per-word))) ;; Final null pointer. (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0)) @@ -504,61 +505,19 @@ status slot." ,@body) (sb-sys:deallocate-system-memory ,sap ,size))))) -#-win32 -(sb-alien:define-alien-routine ("spawn" %spawn) sb-alien:int - (program sb-alien:c-string) - (argv (* sb-alien:c-string)) - (envp (* sb-alien:c-string)) - (pty-name sb-alien:c-string) - (stdin sb-alien:int) - (stdout sb-alien:int) - (stderr sb-alien:int)) - -#+win32 -(sb-alien:define-alien-routine ("spawn" %spawn) sb-win32::handle +(sb-alien:define-alien-routine spawn + #-win32 sb-alien:int + #+win32 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) + (search sb-alien:int) + (envp (* sb-alien:c-string)) + (pty-name sb-alien:c-string) (wait sb-alien:int)) -(defun spawn (program argv stdin stdout stderr envp pty-name wait) - #+win32 (declare (ignore envp pty-name)) - #+win32 (%spawn program argv stdin stdout stderr (if wait 1 0)) - #-win32 (declare (ignore wait)) - #-win32 (%spawn program argv envp pty-name stdin stdout stderr)) - -;;; FIXME: why are we duplicating standard library stuff and not using -;;; execvp(3)? We can extend our internal spawn() routine to take a -;;; flag to say whether to search... -;;; 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 'string))) - (values (and (eq (sb-unix:unix-file-kind filename) :file) - #-win32 - (sb-unix:unix-access filename sb-unix:x_ok))))) - -(defun find-executable-in-search-path (pathname &optional - (search-path (posix-getenv "PATH"))) - #+sb-doc - "Find the first executable file matching PATHNAME in any of the -colon-separated list of pathnames SEARCH-PATH" - (let ((program #-win32 pathname - #+win32 (merge-pathnames pathname (make-pathname :type "exe")))) - (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 - ;; directory, at least until pfdietz comes along and says why - ;; that's noncompliant -- CSR, c. 2003-08-10 - for truename = (probe-file (subseq search-path start end)) - for fullpath = (when truename - (unix-namestring (merge-pathnames program truename))) - when (and fullpath (unix-filename-is-executable-p fullpath)) - return fullpath))) - ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the ;;; documentation should be in the doc string. So all information from @@ -619,7 +578,8 @@ colon-separated list of pathnames SEARCH-PATH" (if-output-exists :error) (error :output) (if-error-exists :error) - status-hook) + status-hook + (external-format :default)) #+sb-doc #.(concatenate 'string @@ -659,9 +619,8 @@ Users Manual for details about the PROCESS structure."#-win32" an alternative lossy representation of the new Unix environment, for compatibility with CMU CL"" :SEARCH - Look for PROGRAM in each of the directories along the $PATH + Look for PROGRAM in each of the directories in the child's $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."#-win32" @@ -703,13 +662,12 @@ Users Manual for details about the PROCESS structure."#-win32" 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.") + process changes. The function takes the process as an argument. + :EXTERNAL-FORMAT + The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.") #-win32 (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) - ;; Make sure that the interrupt handler is installed. - #-win32 - (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler) ;; Prepend the program to the argument list. (push (namestring program) args) (labels (;; It's friendly to allow the caller to pass any string @@ -739,20 +697,15 @@ Users Manual for details about the PROCESS structure."#-win32" #-win32 *handlers-installed* ;; 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 (simplify-args args)) - ;; See the comment above about execlp(3). - (pfile (if search - (find-executable-in-search-path program) - (unix-namestring program))) + (progname (native-namestring program)) ;; Gag. (cookie (list 0))) - (unless pfile - (error "no such program: ~S" program)) - (unless (unix-filename-is-executable-p pfile) - (error "not executable: ~S" program)) (unwind-protect + ;; Note: despite the WITH-* names, these macros don't + ;; 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) &body body) `(multiple-value-bind (,fd ,stream) @@ -766,7 +719,8 @@ Users Manual for details about the PROCESS structure."#-win32" (values stdout output-stream) (get-descriptor-for ,@args)))) ,@body)) - (with-open-pty (((pty-name pty-stream) (pty cookie)) &body 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) @@ -782,47 +736,53 @@ Users Manual for details about the PROCESS structure."#-win32" input cookie :direction :input :if-does-not-exist if-input-does-not-exist - :external-format :default) + :external-format external-format + :wait wait) (with-fd-and-stream-for ((stdout output-stream) :output output cookie :direction :output :if-exists if-output-exists - :external-format :default) + :external-format external-format) (with-fd-and-stream-for ((stderr error-stream) :error error cookie :direction :output :if-exists if-error-exists - :external-format :default) + :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*. - (with-active-processes-lock () - (with-args-vec (args-vec simple-args) - (with-environment-vec (environment-vec environment) - (let ((child - (without-gcing - (spawn pfile args-vec - stdin stdout stderr - environment-vec pty-name wait)))) - (when (minusp child) - (error "couldn't fork child process: ~A" - (strerror))) - (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*)))))))))) + (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 (= child -1) + (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. + (when (= child -1) + (error "couldn't fork child process: ~A" + (strerror))))))))) (dolist (fd *close-in-parent*) (sb-unix:unix-close fd)) (unless proc @@ -832,6 +792,7 @@ Users Manual for details about the PROCESS structure."#-win32" #-win32 (dolist (handler *handlers-installed*) (sb-sys:remove-fd-handler handler)))) + #-win32 (when (and wait proc) (process-wait proc)) proc))) @@ -841,9 +802,38 @@ Users Manual for details about the PROCESS structure."#-win32" ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie external-format) (incf (car cookie)) - (let* (handler + (let* ((handler nil) (buf (make-array 256 :element-type '(unsigned-byte 8))) - (read-end 0)) + (read-end 0) + (et (stream-element-type stream)) + (copy-fun + (cond + ((member et '(character base-char)) + (lambda () + (let* ((decode-end read-end) + (string (handler-case + (octets-to-string + buf :end read-end + :external-format external-format) + (end-of-input-in-character (e) + (setf decode-end + (octet-decoding-error-start e)) + (octets-to-string + buf :end decode-end + :external-format external-format))))) + (unless (zerop (length string)) + (write-string string stream) + (when (/= decode-end (length buf)) + (replace buf buf :start2 decode-end :end2 read-end)) + (decf read-end decode-end))))) + ((member et '(:default (unsigned-byte 8)) :test #'equal) + (lambda () + (write-sequence buf stream :end read-end) + (setf read-end 0))) + (t + ;; FIXME. + (error "Don't know how to copy to stream of element-type ~S" + et))))) (setf handler (sb-sys:add-fd-handler descriptor @@ -859,9 +849,11 @@ Users Manual for details about the PROCESS structure."#-win32" (ash 1 descriptor) 0 0 0) (cond ((null result) - (error "~@" - (strerror readable/errno))) + (if (eql sb-unix:eintr readable/errno) + (return) + (error "~@" + (strerror readable/errno)))) ((zerop result) (return)))) (multiple-value-bind (count errno) @@ -878,6 +870,10 @@ Users Manual for details about the PROCESS structure."#-win32" (setf handler nil) (decf (car cookie)) (sb-unix:unix-close descriptor) + (unless (zerop read-end) + ;; Should this be an END-OF-FILE? + (error "~@" buf)) (return)) ((null count) (sb-sys:remove-fd-handler handler) @@ -889,23 +885,14 @@ Users Manual for details about the PROCESS structure."#-win32" (strerror errno))) (t (incf read-end count) - (let* ((decode-end (length buf)) - (string (handler-case - (octets-to-string - buf :end read-end - :external-format external-format) - (end-of-input-in-character (e) - (setf decode-end - (octet-decoding-error-start e)) - (octets-to-string - buf :end decode-end - :external-format external-format))))) - (unless (zerop (length string)) - (write-string string stream) - (when (/= decode-end (length buf)) - (replace buf buf :start2 decode-end :end2 read-end)) - (decf read-end decode-end)))))))))))) + (funcall copy-fun)))))))))) +;;; FIXME: something very like this is done in SB-POSIX to treat +;;; streams as file descriptor designators; maybe we can combine these +;;; two? Additionally, as we have a couple of user-defined streams +;;; libraries, maybe we should have a generic function for doing this, +;;; so user-defined streams can play nicely with RUN-PROGRAM (and +;;; maybe also with SB-POSIX)? (defun get-stream-fd-and-external-format (stream direction) (typecase stream (sb-sys:fd-stream @@ -929,21 +916,21 @@ Users Manual for details about the PROCESS structure."#-win32" (defun get-descriptor-for (object cookie &rest keys - &key direction external-format + &key direction (external-format :default) wait &allow-other-keys) - ;; Someday somebody should review our use of the temporary file: are - ;; we doing something that's liable to run afoul of disk quotas or - ;; to choke on small /tmp file systems? + (declare (ignore wait)) ;This is explained below. + ;; Our use of a temporary file dates back to very old CMUCLs, and + ;; was probably only ever intended for use with STRING-STREAMs, + ;; which are ordinarily smallish. However, as we've got + ;; user-defined stream classes, we can end up trying to copy + ;; arbitrarily much data into the temp file, and so are liable to + ;; 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:unix-mkstemp "/tmp/.run-program-XXXXXX") + (sb-unix:sb-mkstemp "/tmp/.run-program-XXXXXX" #o0600) (unless fd (error "could not open a temporary file: ~A" (strerror name/errno))) - #-win32 #|FIXME: should say (logior s_irusr s_iwusr)|# - (unless (sb-unix:unix-chmod name/errno #o600) - (sb-unix:unix-close fd) - (error "failed to chmod the temporary file?!")) (unless (sb-unix:unix-unlink name/errno) (sb-unix:unix-close fd) (error "failed to unlink ~A" name/errno)) @@ -951,7 +938,9 @@ Users Manual for details about the PROCESS structure."#-win32" (cond ((eq object t) ;; No new descriptor is needed. (values -1 nil)) - ((eq object nil) + ((or (eq object nil) + (and (typep object 'broadcast-stream) + (not (broadcast-stream-streams object)))) ;; Use /dev/null. (multiple-value-bind (fd errno) @@ -995,7 +984,11 @@ Users Manual for details about the PROCESS structure."#-win32" (error "Direction must be either :INPUT or :OUTPUT, not ~S." direction))))) ((or (pathnamep object) (stringp object)) - (with-open-stream (file (apply #'open object keys)) + ;; 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)) (multiple-value-bind (fd errno) (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) @@ -1006,64 +999,88 @@ Users Manual for details about the PROCESS structure."#-win32" (error "couldn't duplicate file descriptor: ~A" (strerror errno))))))) ((streamp object) - ;; XXX: what is the correct way to compare external formats? (ecase direction (:input - (or - ;; If we can get an fd for the stream and the - ;; stream's external format is the default, let the - ;; child process use the fd for its descriptor. - ;; Otherwise, we copy data from the stream into a - ;; temp file, and give the temp file's descriptor to - ;; the child. - (multiple-value-bind (fd stream format) - (get-stream-fd-and-external-format object :input) - (when (and fd format - (eq (find-external-format - *default-external-format*) - (find-external-format format))) - (values fd stream))) - (let ((fd (make-temp-fd)) - (newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (let ((vector - (string-to-octets - line :external-format external-format))) - (sb-unix:unix-write - fd vector 0 (length vector))) - (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*) - (values fd nil)))) + (block nil + ;; If we can get an fd for the stream, let the child + ;; process use the fd for its descriptor. Otherwise, + ;; we copy data from the stream into a temp file, and + ;; give the temp file's descriptor to the + ;; child. + (multiple-value-bind (fd stream format) + (get-stream-fd-and-external-format object :input) + (declare (ignore format)) + (when fd + (return (values fd stream)))) + ;; FIXME: if we can't get the file descriptor, since + ;; the stream might be interactive or otherwise + ;; block-y, we can't know whether we can copy the + ;; stream's data to a temp file, so if RUN-PROGRAM was + ;; called with :WAIT NIL, we should probably error. + ;; However, STRING-STREAMs aren't fd-streams, but + ;; they're not prone to blocking; any user-defined + ;; streams that "read" from some in-memory data will + ;; probably be similar to STRING-STREAMs. So maybe we + ;; should add a STREAM-INTERACTIVE-P generic function + ;; for problems like this? Anyway, the machinery is + ;; here, if you feel like filling in the details. + #| + (when (and (null wait) #) + (error "~@" object)) + |# + (let ((fd (make-temp-fd)) + (et (stream-element-type object))) + (cond ((member et '(character base-char)) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (let ((vector (string-to-octets + line + :external-format external-format))) + (sb-unix:unix-write + fd vector 0 (length vector))) + (if no-cr + (return) + (sb-unix:unix-write + fd #.(string #\Newline) 0 1))))) + ((member et '(:default (unsigned-byte 8)) + :test 'equal) + (loop with buf = (make-array 256 :element-type '(unsigned-byte 8)) + for p = (read-sequence buf object) + until (zerop p) + do (sb-unix:unix-write fd buf 0 p))) + (t + (error "Don't know how to copy from stream of element-type ~S" + et))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) + (push fd *close-in-parent*) + (return (values fd nil))))) (:output - (or - ;; Similar to the :input trick above, except we - ;; arrange to copy data from the stream. This is - ;; only slightly less sleazy than the input case, - ;; since we don't buffer to a file, but I think we - ;; may still lose if there's data in the stream - ;; buffer. - (multiple-value-bind (fd stream format) - (get-stream-fd-and-external-format object :output) - (when (and fd format (eq (find-external-format - *default-external-format*) - (find-external-format format))) - (values fd stream))) - (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 external-format) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil)))))) + (block nil + ;; Similar to the :input trick above, except we + ;; arrange to copy data from the stream. This is + ;; slightly saner than the input case, since we don't + ;; buffer to a file, but I think we may still lose if + ;; there's unflushed data in the stream buffer and we + ;; give the file descriptor to the child. + (multiple-value-bind (fd stream format) + (get-stream-fd-and-external-format object :output) + (declare (ignore format)) + (when fd + (return (values fd stream)))) + (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 + 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)))))