;;;; 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
+ :external-format external-format
:element-type :default
:dual-channel-p t)))))
-(defmacro round-bytes-to-words (n)
+;; Null terminate strings only C-side: otherwise we can run into
+;; A-T-S-L even for simple encodings like ASCII. Multibyte encodings
+;; may need more than a single byte of zeros; assume 4 byte is enough
+;; for everyone.
+(defmacro round-null-terminated-bytes-to-words (n)
(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))))
+ `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n)
+ 4 (1- ,bytes-per-word)))
+ (1- ,bytes-per-word))))
(defun string-list-to-c-strvec (string-list)
(let* ((bytes-per-word (/ sb-vm:n-machine-word-bits sb-vm:n-byte-bits))
;; clobbers argv[-1].
(vec-bytes (* bytes-per-word (+ (length string-list) 2)))
(octet-vector-list (mapcar (lambda (s)
- (string-to-octets s :null-terminate t))
+ (string-to-octets s))
string-list))
(string-bytes (reduce #'+ octet-vector-list
:key (lambda (s)
- (round-bytes-to-words (length s)))))
+ (round-null-terminated-bytes-to-words
+ (length s)))))
(total-bytes (+ string-bytes vec-bytes))
;; Memory to hold the vector of pointers and all the strings.
(vec-sap (sb-sys:allocate-system-memory total-bytes))
(string-sap (sap+ vec-sap vec-bytes))
;; Index starts from [1]!
(vec-index-offset bytes-per-word))
- (declare (index string-bytes vec-bytes total-bytes)
+ (declare (sb-vm:signed-word vec-bytes)
+ (sb-vm:word string-bytes total-bytes)
(sb-sys:system-area-pointer vec-sap string-sap))
(dolist (octets octet-vector-list)
(declare (type (simple-array (unsigned-byte 8) (*)) octets))
(let ((size (length octets)))
;; Copy string.
(sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size)
+ ;; NULL-terminate it
+ (sb-kernel:system-area-ub8-fill 0 string-sap size 4)
;; 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-null-terminated-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)
- (open-pty ,pty ,cookie)
+ (open-pty ,pty ,cookie :external-format external-format)
,@body))
(with-args-vec ((vec args) &body body)
`(with-c-strvec (,vec ,args)
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
(dolist (fd *close-on-error*)
(sb-unix:unix-close fd))
- ;; FIXME: nothing seems to set this.
#-win32
(dolist (handler *handlers-installed*)
- (sb-sys:remove-fd-handler handler))))
- (when (and wait proc)
- (process-wait proc))
+ (sb-sys:remove-fd-handler handler)))
+ #-win32
+ (when (and wait proc)
+ (unwind-protect
+ (process-wait proc)
+ (dolist (handler *handlers-installed*)
+ (sb-sys:remove-fd-handler handler)))))
proc)))
;;; Install a handler for any input that shows up on the file
;;; 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))))))))
+ #-win32
+ (push handler *handlers-installed*)))
;;; FIXME: something very like this is done in SB-POSIX to treat
;;; streams as file descriptor designators; maybe we can combine these
;; 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))
child process won't hang~:>" object))
|#
(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)))
- (sb-unix:unix-write
- fd vector 0 (length vector)))
- (if no-cr
- (return)
- (sb-unix:unix-write fd newline 0 1))))
+ (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)))))