X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=fee0dd751dd324b1773dadee110b581a3eba5d25;hb=eac461c1f1ca91cfe282c779291d582ed6b336cb;hp=8dd754ab4c88bb7ccee85c201d59753aa685a7fe;hpb=a6da3f313e44f757a24834b347b3beabdc7a5f10;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 8dd754a..fee0dd7 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -145,7 +145,6 @@ #+sb-doc "List of process structures for all active processes.") -#-win32 (defvar *active-processes-lock* (sb-thread:make-mutex :name "Lock for active processes.")) @@ -153,11 +152,8 @@ ;;; 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 @@ -386,14 +382,16 @@ status slot." ;; 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 @@ -408,13 +406,15 @@ status slot." (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 @@ -455,13 +455,19 @@ status slot." (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)) @@ -469,41 +475,50 @@ status slot." ;; 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 @@ -565,9 +580,8 @@ status slot." &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 @@ -718,20 +732,26 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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 @@ -755,46 +775,54 @@ Users Manual for details about the PROCESS structure."#-win32" (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 @@ -802,9 +830,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 @@ -856,22 +913,9 @@ Users Manual for details about the PROCESS structure."#-win32" (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 @@ -895,6 +939,12 @@ Users Manual for details about the PROCESS structure."#-win32" (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")) + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created @@ -913,10 +963,14 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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)) @@ -924,7 +978,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) @@ -973,15 +1029,16 @@ Users Manual for details about the PROCESS structure."#-win32" ;; 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 @@ -1015,19 +1072,32 @@ Users Manual for details about the PROCESS structure."#-win32" 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)))))