1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Implementation using Gray streams.
6 (in-package :iolib.streams
)
8 ;;;-------------------------------------------------------------------------
9 ;;; Instance Initialization
10 ;;;-------------------------------------------------------------------------
12 (defun free-stream-buffers (ibuf obuf
)
13 (when ibuf
(free-iobuf ibuf
))
14 (when obuf
(free-iobuf obuf
)))
16 ;;; TODO: use the buffer pool
17 ;;; TODO: handle instance reinitialization
18 (defmethod shared-initialize :after
((stream dual-channel-gray-stream
) slot-names
19 &key
(input-buffer-size +bytes-per-iobuf
+)
20 (output-buffer-size +bytes-per-iobuf
+)
21 (external-format :default
))
22 (declare (ignore slot-names
))
23 (unless input-buffer-size
(setf input-buffer-size
+bytes-per-iobuf
+))
24 (unless output-buffer-size
(setf output-buffer-size
+bytes-per-iobuf
+))
25 (check-type input-buffer-size buffer-index
)
26 (check-type output-buffer-size buffer-index
)
27 (with-accessors ((ibuf input-buffer-of
)
28 (obuf output-buffer-of
)
29 (ef external-format-of
))
31 (setf ibuf
(allocate-iobuf input-buffer-size
)
32 obuf
(allocate-iobuf output-buffer-size
)
34 (trivial-garbage:finalize stream
(lambda () (free-stream-buffers ibuf obuf
)))))
37 ;;;-------------------------------------------------------------------------
39 ;;;-------------------------------------------------------------------------
41 (defmethod stream-element-type ((stream dual-channel-gray-stream
))
44 ;; TODO: use the buffer pool
45 (defmethod close :around
((stream dual-channel-gray-stream
) &key abort
)
46 (with-accessors ((ibuf input-buffer-of
)
47 (obuf output-buffer-of
))
49 (trivial-garbage:cancel-finalization stream
)
50 (unless (or abort
(null ibuf
)) (finish-output stream
))
51 (free-stream-buffers ibuf obuf
)
52 (setf ibuf nil obuf nil
))
56 (defmethod close ((stream dual-channel-gray-stream
) &key abort
)
57 (declare (ignore stream abort
)))
59 (defmethod (setf external-format-of
)
60 (external-format (stream dual-channel-gray-stream
))
61 (let ((canonical-ef (babel:ensure-external-format external-format
)))
62 (setf (slot-value stream
'external-format
) canonical-ef
)
63 (setf (values (slot-value stream
'eol-writer
)
64 (slot-value stream
'eol-finder
))
65 (case (babel:external-format-eol-style canonical-ef
)
66 (:lf
(values #'stream-write-lf
#'stream-find-lf
))
67 (:crlf
(values #'stream-write-crlf
#'stream-find-crlf
))
68 (:cr
(values #'stream-write-cr
#'stream-find-cr
))))))
71 ;;;-------------------------------------------------------------------------
73 ;;;-------------------------------------------------------------------------
75 (defmethod stream-clear-input ((stream dual-channel-gray-stream
))
76 (iobuf-reset (input-buffer-of stream
)))
78 (declaim (inline %read-sequence
))
79 (defun %read-sequence
(stream seq start end
)
80 (check-bounds seq start end
)
83 (ub8-sarray (%read-into-simple-array-ub8 stream seq start end
))
84 (string (%read-into-string stream seq start end
))
85 (ub8-vector (%read-into-vector stream seq start end
)))))
87 (declaim (inline read-sequence
*))
88 (defun read-sequence* (stream sequence
&key
(start 0) end
)
89 (%read-sequence stream sequence start end
))
91 (defmethod stream-read-sequence
92 ((stream dual-channel-gray-stream
) sequence start end
&key
)
93 (%read-sequence stream sequence start end
))
95 (defmethod drain-input-buffer
96 ((stream dual-channel-gray-stream
) sequence
&key
(start 0) end
)
97 (check-bounds sequence start end
)
98 (with-accessors ((ib input-buffer-of
))
100 (let ((nbytes (min (- end start
)
103 (iobuf-copy-into-lisp-array ib
(iobuf-start ib
)
106 (incf (iobuf-start ib
) nbytes
)
107 (let ((len (iobuf-length ib
)))
108 (values (+ start nbytes
)
109 (and (plusp len
) len
)))))))
112 ;;;-------------------------------------------------------------------------
114 ;;;-------------------------------------------------------------------------
116 (defmethod stream-clear-output ((stream dual-channel-gray-stream
))
117 (iobuf-reset (output-buffer-of stream
))
118 (setf (dirtyp stream
) nil
))
120 (defmethod stream-finish-output ((stream dual-channel-gray-stream
))
121 (with-accessors ((fd output-fd-of
)
122 (write-fn write-fn-of
)
123 (ob output-buffer-of
)
126 (with-hangup-guard stream
127 (%write-octets-from-iobuf write-fn fd ob
))
130 (defmethod stream-force-output ((stream dual-channel-gray-stream
))
131 (setf (dirtyp stream
) t
))
133 (declaim (inline %write-sequence
))
134 (defun %write-sequence
(stream seq start end
)
135 (check-bounds seq start end
)
138 (ub8-sarray (%write-simple-array-ub8 stream seq start end
))
139 (string (stream-write-string stream seq start end
))
140 (ub8-vector (%write-vector-ub8 stream seq start end
))
141 (vector (%write-vector stream seq start end
)))))
143 (declaim (inline write-sequence
*))
144 (defun write-sequence* (stream sequence
&key
(start 0) end
)
145 (%write-sequence stream sequence start end
))
147 (defmethod stream-write-sequence ((stream dual-channel-gray-stream
)
148 sequence start end
&key
)
149 (%write-sequence stream sequence start end
))
152 ;;;-------------------------------------------------------------------------
154 ;;;-------------------------------------------------------------------------
156 (defun %stream-rewind-iobuf
(stream iobuf encoding
)
157 (maybe-rewind-iobuf iobuf encoding
)
158 (setf (unread-index-of stream
) (iobuf-start iobuf
)))
160 (defmethod stream-read-char ((stream dual-channel-gray-stream
))
161 (with-accessors ((fd input-fd-of
)
164 (unread-index unread-index-of
)
165 (ef external-format-of
))
167 (let ((encoding (babel:external-format-encoding ef
)))
168 (%stream-rewind-iobuf stream ib encoding
)
169 (let ((eofp (eql :eof
(%fill-ibuf ib fd read-fn
))))
170 (if (and eofp
(iobuf-empty-p ib
))
172 ;; At this point, there's at least one octet in the buffer
173 (let ((line-end (funcall (eol-finder-of stream
) ib fd read-fn nil eofp
)))
174 (if (eql #\Newline line-end
)
176 (decode-one-char fd read-fn ib encoding
))))))))
178 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream
))
179 (with-accessors ((fd input-fd-of
)
182 (ef external-format-of
))
184 (let ((encoding (babel:external-format-encoding ef
)))
185 (%stream-rewind-iobuf stream ib encoding
)
186 (let ((eofp (eql :eof
(%fill-ibuf
/no-hang ib fd read-fn
))))
187 (if (iobuf-empty-p ib
)
189 ;; At this point, there's at least one octet in the buffer
190 (let ((line-end (funcall (eol-finder-of stream
) ib fd read-fn t eofp
)))
191 (cond ((null line-end
)
192 (decode-one-char/no-hang ib encoding
))
193 ((eql #\Newline line-end
)
195 ;; There's a CR but it's not EOF so we could still receive a LF
196 ((and (eql :incomplete line-end
) (not eofp
))
199 (defun %stream-unread-char
(stream)
200 (declare (type dual-channel-gray-stream stream
))
201 (with-accessors ((ib input-buffer-of
)
202 (unread-index unread-index-of
))
204 (symbol-macrolet ((start (iobuf-start ib
)))
206 ((> start unread-index
)
207 (setf start unread-index
))
208 ((= start unread-index
)
209 (error 'no-characters-to-unread
:stream stream
))
210 (t (bug "On stream ~S the buffer start(~A) is less than the unread index(~A)."
211 stream start unread-index
)))))
214 (defmethod stream-unread-char ((stream dual-channel-gray-stream
) character
)
215 (declare (ignore character
))
216 (%stream-unread-char stream
))
218 (defmethod stream-peek-char ((stream dual-channel-gray-stream
))
219 (let ((char (stream-read-char stream
)))
220 (cond ((eql :eof char
)
223 (%stream-unread-char stream
)
226 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
229 (defmethod stream-listen ((stream dual-channel-gray-stream
))
230 (let ((char (stream-read-char-no-hang stream
)))
231 (cond ((characterp char
) (stream-unread-char stream char
) t
)
232 ((eql :eof char
) nil
)
236 ;;;-------------------------------------------------------------------------
238 ;;;-------------------------------------------------------------------------
240 (defmethod stream-write-char ((stream dual-channel-gray-stream
)
241 (character character
))
242 (%flush-obuf-if-needed stream
)
243 (if (char= character
#\Newline
)
244 (funcall (eol-writer-of stream
) stream
)
245 (let ((string (make-string 1 :initial-element character
)))
246 (declare (dynamic-extent string
))
247 (stream-write-string stream string
))))
249 (defmethod stream-line-column ((stream dual-channel-gray-stream
))
252 (defmethod stream-start-line-p ((stream dual-channel-gray-stream
))
255 (defmethod stream-terpri ((stream dual-channel-gray-stream
))
256 (write-char #\Newline stream
) nil
)
258 (defmethod stream-fresh-line ((stream dual-channel-gray-stream
))
259 (write-char #\Newline stream
) t
)
261 (defmethod stream-write-string ((stream dual-channel-gray-stream
)
262 (string string
) &optional
(start 0) end
)
263 (check-bounds string start end
)
264 (do* ((ef (external-format-of stream
))
265 (encoding (babel:external-format-encoding ef
)))
267 (case (char string start
)
269 (funcall (eol-writer-of stream
) stream
)
272 (setf start
(%write-string-chunk stream string start end encoding
)))))
276 ;;;-------------------------------------------------------------------------
278 ;;;-------------------------------------------------------------------------
280 (defmethod stream-read-byte ((stream dual-channel-gray-stream
))
281 (with-accessors ((fd input-fd-of
)
283 (ib input-buffer-of
))
285 (flet ((fill-buf-or-eof ()
287 (when (eql :eof
(%fill-ibuf ib fd read-fn
))
289 (when (zerop (iobuf-length ib
))
291 (iobuf-pop-octet ib
))))
294 ;;;-------------------------------------------------------------------------
296 ;;;-------------------------------------------------------------------------
298 (defmethod stream-write-byte ((stream dual-channel-gray-stream
) integer
)
299 (check-type integer ub8
"an unsigned 8-bit value")
300 (with-accessors ((ob output-buffer-of
))
302 (with-hangup-guard stream
303 (%flush-obuf-if-needed stream
))
304 (iobuf-push-octet ob integer
)))
307 ;;;-------------------------------------------------------------------------
308 ;;; Buffer-related functions
309 ;;;-------------------------------------------------------------------------
311 (defmethod input-buffer-size ((stream dual-channel-gray-stream
))
312 (iobuf-length (input-buffer-of stream
)))
314 (defmethod input-buffer-empty-p ((stream dual-channel-gray-stream
))
315 (iobuf-empty-p (input-buffer-of stream
)))
317 (defmethod output-buffer-size ((stream dual-channel-gray-stream
))
318 (iobuf-length (output-buffer-of stream
)))
320 (defmethod output-buffer-empty-p ((stream dual-channel-gray-stream
))
321 (iobuf-empty-p (output-buffer-of stream
)))