Commit 9d260c5a9444c92ced87986a363e341d07f7024d
2017-06-20T22:55:33
wip
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
diff --git a/fd-gray.lisp b/fd-gray.lisp
index 5594b98..686eca7 100644
--- a/fd-gray.lisp
+++ b/fd-gray.lisp
@@ -27,7 +27,35 @@
(defclass stream (trivial-gray-stream-mixin)
((fd :initarg :fd
:reader stream-fd
- :type file-descriptor)))
+ :type file-descriptor)
+ (blocking :initarg :blocking
+ :accessor stream-blocking%
+ :type boolean)))
+
+(defgeneric stream-blocking (stream))
+
+(defmethod stream-blocking ((stream stream))
+ (or (and (slot-boundp stream 'blocking)
+ (slot-value stream 'blocking))
+ (setf (slot-value stream 'blocking)
+ (let ((flags (fcntl:getfl (stream-fd stream))))
+ (not (= 0 (logand fcntl:+o-nonblock+ flags)))))))
+
+(defgeneric (setf stream-blocking) (value stream))
+
+(defmethod (setf stream-blocking) (value (stream stream))
+ (let* ((fd (stream-fd stream))
+ (flags (fcntl:getfl fd)))
+ (cond
+ ((and value (not (= 0 (logand fcntl:+o-nonblock+ flags))))
+ t)
+ ((and (not value) (= 0 (logand fcntl:+o-nonblock+ flags)))
+ nil)
+ (t
+ (fcntl:setfl fd (if value
+ (logand (lognot fcntl:+o-nonblock+) flags)
+ (logior fcntl:+o-nonblock+ flags)))
+ (setf (slot-value stream 'blocking) value)))))
(define-condition stream-error (cl:stream-error)
()
@@ -84,10 +112,15 @@ on a fd gray stream."))
Tries to read once from input-length to input-max (end of buffer)."
(let* ((buffer (input-buffer stream))
(length (input-length stream))
- (r (unistd:read (stream-fd stream)
- (cffi:mem-aptr buffer :unsigned-char length)
- (- (input-max stream) length))))
- (cond ((= r 0)
+ (fd (stream-fd stream))
+ (buf (cffi:mem-aptr buffer :unsigned-char length))
+ (buflen (- (input-max stream) length))
+ (r (if (stream-blocking stream)
+ (unistd:read fd buf buflen)
+ (unistd:read-non-blocking fd buf buflen))))
+ (cond ((null r)
+ nil)
+ ((= r 0)
:eof)
((< r 0)
(error 'stream-input-error :stream stream))
@@ -102,8 +135,9 @@ Tries to read once from input-length to input-max (end of buffer)."
(when (= input-index (input-length stream))
(setf input-index 0
(input-length stream) 0)
- (when (eq :eof (stream-input stream))
- (return-from stream-read-byte :eof)))
+ (case (stream-input stream)
+ ((:eof) (return-from stream-read-byte :eof))
+ ((nil) (return-from stream-read-byte nil))))
(let ((b (cffi:mem-aref buffer :unsigned-char input-index)))
(incf input-index)
b))))
@@ -126,7 +160,9 @@ Tries to read once from input-length to input-max (end of buffer)."
(when (= input-index (input-length stream))
(setf input-index 0
(input-length buffer) 0)
- (stream-input stream)))))))
+ (case (stream-input stream)
+ ((:eof) (return-from stream-read-sequence :eof))
+ ((nil) (return-from stream-read-sequence nil)))))))))
(defmethod close ((stream input-stream) &key abort)
(declare (ignore abort))
@@ -144,6 +180,14 @@ Tries to read once from input-length to input-max (end of buffer)."
,@body)
(close ,stream)))))
+(define-condition stream-output-error (stream-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "output error on ~S"
+ (stream-error-stream condition))))
+ (:documentation "An error that is signalled when an output error happens
+on a fd gray stream."))
+
(defclass output-stream (stream fundamental-binary-output-stream)
((output-buffer :initform (cffi:foreign-alloc :unsigned-char
:count *buffer-size*)
@@ -165,27 +209,40 @@ Tries to read once from input-length to input-max (end of buffer)."
Calls write with data ranging from output-index to output-length."
(let ((buffer (output-buffer stream)))
(with-accessors ((output-index output-index)) stream
- (loop
- (when (= output-index (output-length buffer))
- (setf output-index 0
- (output-length buffer) 0)
- (return))
- (let ((r (unistd:write (stream-fd stream)
- (cffi:mem-aptr buffer :unsigned-char output-index)
- (- (output-length stream) output-index))))
- (incf output-index r))))))
+ (let* ((fd (stream-fd stream))
+ (buf (cffi:mem-aptr buffer :unsigned-char output-index))
+ (buflen (- (output-length stream) output-index))
+ (r (if (stream-blocking stream)
+ (unistd:write fd buf buflen)
+ (unistd:write-non-blocking fd buf buflen))))
+ (cond ((null r)
+ (return-from stream-output nil))
+ ((= 0 r)
+ (return-from stream-output :eof))
+ ((< r 0)
+ (error 'stream-output-error :stream stream))
+ (t
+ (incf output-index r)
+ (when (= output-index (output-length stream))
+ (setf output-index 0
+ (output-length stream) 0))))))))
(defmethod stream-force-output ((stream output-stream))
(stream-output stream))
(defmethod stream-finish-output ((stream output-stream))
- (stream-output stream))
+ (loop
+ (when (= 0 (output-length stream))
+ (return))
+ (stream-output stream)))
(defmethod stream-write-byte ((stream output-stream) byte)
(check-if-open stream)
(let ((buffer (output-buffer stream)))
(when (= (output-length stream) (output-max stream))
- (stream-finish-output stream))
+ (let ((r (stream-output stream)))
+ (cond ((null r)
+ ))))
(setf (cffi:mem-aref buffer :unsigned-char (input-length stream)) byte)
(incf (input-length stream)))
byte)