;;;; 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)
;;; 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))
(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))
((: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)))
(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))
*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
;;; 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))
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)
(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
;; 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))
,@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
- ;; <Krystof> 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
(if-output-exists :error)
(error :output)
(if-error-exists :error)
- status-hook)
+ status-hook
+ (external-format :default))
#+sb-doc
#.(concatenate
'string
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"
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
#-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)
(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)
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
#-win32
(dolist (handler *handlers-installed*)
(sb-sys:remove-fd-handler handler))))
+ #-win32
(when (and wait proc)
(process-wait proc))
proc)))
;;; 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
(ash 1 descriptor)
0 0 0)
(cond ((null result)
- (error "~@<couldn't select on sub-process: ~
- ~2I~_~A~:>"
- (strerror readable/errno)))
+ (if (eql sb-unix:eintr readable/errno)
+ (return)
+ (error "~@<Couldn't select on sub-process: ~
+ ~2I~_~A~:>"
+ (strerror readable/errno))))
((zerop result)
(return))))
(multiple-value-bind (count errno)
(setf handler nil)
(decf (car cookie))
(sb-unix:unix-close descriptor)
+ (unless (zerop read-end)
+ ;; Should this be an END-OF-FILE?
+ (error "~@<non-empty buffer when EOF reached ~
+ while reading from child: ~S~:>" buf))
(return))
((null count)
(sb-sys:remove-fd-handler handler)
(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
(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))
(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)
(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))
(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) #<some undetermined criterion>)
+ (error "~@<don't know how to get an fd for ~A, and so ~
+ can't ensure that copying its data to the ~
+ child process won't hang~:>" 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)))))
projects / sbcl.git / blobdiff