X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=0f31a0fa9e8115a274969cd8f5ad6aec3d1186a2;hb=4d0b87793a047baecf2403455ddca1a82f44a41b;hp=04b5d6a5b0cac638fd7d3ae2fd3e44e997869903;hpb=1e7fc4730aa0cafb0aba5278e8cdbdba566b8725;p=sbcl.git diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 04b5d6a..0f31a0f 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -440,7 +440,7 @@ status slot." (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) @@ -452,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 @@ -578,7 +578,8 @@ status slot." (if-output-exists :error) (error :output) (if-error-exists :error) - status-hook) + status-hook + (external-format :default)) #+sb-doc #.(concatenate 'string @@ -661,7 +662,9 @@ 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")) @@ -733,18 +736,18 @@ 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 @@ -759,7 +762,7 @@ Users Manual for details about the PROCESS structure."#-win32" (if search 1 0) environment-vec pty-name (if wait 1 0)))) - (when (plusp child) + (unless (= child -1) (setf proc (apply #'make-process @@ -799,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 @@ -853,22 +885,7 @@ 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)))))))))) ;;; FIXME: something very like this is done in SB-POSIX to treat ;;; streams as file descriptor designators; maybe we can combine these @@ -921,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) @@ -1012,19 +1031,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)))))