From: Nikodemus Siivola Date: Tue, 10 May 2011 20:41:51 +0000 (+0000) Subject: 1.0.48.8: better binary stream support in RUN-PROGRAM X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5b96a0e6ff6390f3c85f90a72207cf052ea11bf6;p=sbcl.git 1.0.48.8: better binary stream support in RUN-PROGRAM * In COPY-DESCRIPTOR-TO-STREAM, decode octets only if the stream has a character element type. For :DEFAULT and (UNSIGNED-BYTE 8) just copy the octets over directly. For others, signal an error. (Would be nice to support, but not a high priority.) * Similarly for copying to temporary files from non-fd input streams. --- diff --git a/NEWS b/NEWS index 39819ac..bb86954 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ changes relative to sbcl-1.0.48: * enhancement: ASDF has been updated to version 2.015.1. * enhancement: backtraces involving frames from the default evaluator are more readable. + * enhancement: RUN-PROGRAM works with user-defined binary input and output + streams. * bug fix: blocking reads from FIFOs created by RUN-PROGRAM were uninterruptible, as well as blocking reads from socket streams created with for which :SERVE-EVENTS NIL. (regression from 1.0.42.43) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 8dd754a..e85e2cc 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -802,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 @@ -856,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 @@ -1015,19 +1029,29 @@ 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)))) (sb-unix:unix-lseek fd 0 sb-unix:l_set) (push fd *close-in-parent*) (return (values fd nil))))) diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp index d27bb65..c04337a 100644 --- a/tests/run-program.impure.lisp +++ b/tests/run-program.impure.lisp @@ -65,6 +65,51 @@ (sb-thread:join-thread writer) (assert (equal "OK" (read-line out))))) +(defclass buffer-stream (sb-gray:fundamental-binary-input-stream sb-gray:fundamental-binary-output-stream) + ((buffer :initform (make-array 128 + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0)) + (mark :initform 0))) + +(defmethod stream-element-type ((stream buffer-stream)) + '(unsigned-byte 8)) + +(defmethod sb-gray:stream-read-sequence ((stream buffer-stream) seq &optional (start 0) end) + (let* ((buffer (slot-value stream 'buffer)) + (end (or end (length seq))) + (mark (slot-value stream 'mark)) + (fill-pointer (fill-pointer buffer)) + (new-mark (+ mark (min fill-pointer (- end start))))) + (setf (slot-value stream 'mark) new-mark) + (replace seq buffer + :start1 start :end1 end + :start2 mark :end2 fill-pointer) + (min end (+ start (- fill-pointer mark))))) + +(defmethod sb-gray:stream-write-sequence ((stream buffer-stream) seq &optional (start 0) end) + (let* ((buffer (slot-value stream 'buffer)) + (end (or end (length seq))) + (fill-pointer (fill-pointer buffer)) + (new-fill (min (array-total-size buffer) (+ fill-pointer (- end start))))) + (setf (fill-pointer buffer) new-fill) + (replace buffer seq + :start1 fill-pointer + :start2 start :end2 end) + seq)) + +(with-test (:name :run-program-cat-3) + ;; User-defined binary input and output streams. + (let ((in (make-instance 'buffer-stream)) + (out (make-instance 'buffer-stream)) + (data #(0 1 2 3 4 5 6 7 8 9 10 11 12))) + (write-sequence data in) + (let ((process (sb-ext:run-program "/bin/cat" '() :wait t :output out :input in)) + (buf (make-array (length data)))) + (assert (= 13 (read-sequence buf out))) + (assert (= 0 (read-sequence (make-array 8) out))) + (assert (equalp buf data))))) + ;;; Test driving an external program (cat) through pipes wrapped in ;;; composite streams. diff --git a/version.lisp-expr b/version.lisp-expr index a6a714f..08d7c69 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.48.7" +"1.0.48.8"