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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"