#+sb-doc
"List of process structures for all active processes.")
-#-win32
(defvar *active-processes-lock*
(sb-thread:make-mutex :name "Lock for active processes."))
;;; 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
;; 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
(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
(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 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))
(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
&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
;; 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)
+ (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
(let (child)
(with-active-processes-lock ()
(with-args-vec (args-vec simple-args)
- (with-environment-vec (environment-vec environment)
+ (with-environment-vec (environment-vec)
(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*)))))
+ (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.
- (when (= child -1)
- (error "couldn't fork child process: ~A"
- (strerror)))))))))
+ #+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))))))))))
(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))))
- #-win32
- (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
(strerror errno)))
(t
(incf read-end count)
- (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))))))))))))
+ (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
(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"))
+
\f
;;; Find a file descriptor to use for object given the direction.
;;; Returns the descriptor. If object is :STREAM, returns the created
;; 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))
(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)
;; 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))
- (cond (fd
- (push fd *close-in-parent*)
- (values fd nil))
- (t
- (error "couldn't duplicate file descriptor: ~A"
- (strerror errno)))))))
+ (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
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)))))
projects / sbcl.git / blobdiff