1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2007 Stelian Ionescu
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the
9 ;; preamble found here:
10 ;; http://opensource.franz.com/preamble.html
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU Lesser General
18 ;; Public License along with this library; if not, write to the
19 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
20 ;; Boston, MA 02110-1301, USA
22 (in-package :io.streams
)
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;; Instance Initialization ;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;; TODO: use the buffer pool
31 ;; TODO: handle instance reinitialization
32 (defmethod shared-initialize :after
((s dual-channel-gray-stream
) slot-names
33 &key
(input-buffer-size +bytes-per-iobuf
+)
34 (output-buffer-size +bytes-per-iobuf
+)
35 (external-format :default
))
36 (declare (ignore slot-names
))
37 (check-type input-buffer-size buffer-index
)
38 (check-type output-buffer-size buffer-index
)
39 (when (open-stream-p s
) (close s
))
40 (with-accessors ((ib input-buffer-of
) (ob output-buffer-of
)
41 (ef external-format-of
)) s
42 (setf ib
(allocate-iobuf input-buffer-size
)
43 ob
(allocate-iobuf output-buffer-size
))
44 (setf ef
(etypecase external-format
45 (symbol (find-external-format external-format
))
46 ((and list
(not null
))
47 (apply #'make-external-format external-format
))))))
55 (defmethod stream-element-type ((stream dual-channel-gray-stream
))
58 ;; TODO: use the buffer pool
59 (defmethod close :around
((stream dual-channel-gray-stream
) &key abort
)
60 (with-accessors ((ib input-buffer-of
)
61 (ob output-buffer-of
)) stream
62 (unless (or abort
(null ib
)) (finish-output stream
))
63 (when ib
(free-iobuf ib
))
64 (when ob
(free-iobuf ob
))
69 (defmethod close ((stream dual-channel-gray-stream
) &key abort
)
70 (declare (ignore stream abort
)))
78 (defmethod stream-clear-input ((stream dual-channel-gray-stream
))
79 (with-accessors ((ib input-buffer-of
)) stream
83 (defun %fill-ibuf
(buf fd
&optional timeout
)
86 (iomux:wait-until-fd-ready fd
:read timeout
)))
87 ;; FIXME signal something better
88 (cond ((member :timeout status
)
89 (return-from %fill-ibuf
:timeout
))
90 ((member :error status
)
91 (error "WAIT-UNTIL-FD-READY returned :ERROR on FD ~S" fd
)))))
92 (let ((num (et:repeat-upon-eintr
93 (et:read fd
(iobuf-end-pointer buf
)
94 (iobuf-end-space-length buf
)))))
97 (incf (iobuf-end buf
) num
))))
99 (defun %read-into-simple-array-ub8
(stream array start end
)
100 (declare (type dual-channel-gray-stream stream
))
101 (with-accessors ((ib input-buffer-of
)
102 (fd input-fd-of
)) stream
103 (let ((octets-needed (- end start
)))
104 (loop :with array-offset
:= start
105 :for octets-in-buffer
:= (iobuf-length ib
)
106 :for nbytes
:= (min octets-needed octets-in-buffer
)
107 :when
(plusp nbytes
) :do
108 (iobuf-copy-into-lisp-array ib
(iobuf-start ib
)
109 array array-offset nbytes
)
110 (incf array-offset nbytes
)
111 (decf octets-needed nbytes
)
112 (incf (iobuf-start ib
) nbytes
)
113 :if
(zerop octets-needed
) :do
(loop-finish)
114 :else
:do
(iobuf-reset ib
)
115 :when
(eql :eof
(%fill-ibuf ib fd
)) :do
(loop-finish)
116 :finally
(return array-offset
)))))
118 (defun %read-into-string
(stream string start end
)
119 (declare (type dual-channel-gray-stream stream
))
120 (loop :for offset
:from start
:below end
121 :for char
:= (stream-read-char stream
)
122 :if
(eql char
:eof
) :do
(loop-finish)
123 :else
:do
(setf (char string offset
) char
)
124 :finally
(return offset
)))
126 (defun %read-into-vector
(stream vector start end
)
127 (declare (type dual-channel-gray-stream stream
))
128 (loop :for offset
:from start
:below end
129 :for octet
:= (stream-read-byte stream
)
130 :if
(eql octet
:eof
) :do
(loop-finish)
131 :else
:do
(setf (aref vector offset
) octet
)
132 :finally
(return offset
)))
135 (defmethod #-openmcl stream-read-sequence
136 #+openmcl stream-read-vector
137 ((stream dual-channel-gray-stream
) seq
138 &optional
(start 0) end
)
139 (setf (values start end
) (%check-bounds seq start end
))
143 (%read-into-simple-array-ub8 stream seq start end
))
145 (%read-into-string stream seq start end
))
147 (%read-into-vector stream seq start end
)))))
150 (defmethod stream-read-byte-sequence ((stream dual-channel-gray-stream
) seq
151 &optional
(start 0) end
153 (declare (ignore no-hang interactive
))
154 (setf (values start end
) (%check-bounds seq start end
))
158 (%read-into-simple-array-ub8 stream seq start end
))
160 (%read-into-vector stream seq start end
)))))
163 (defmethod stream-read-char-sequence ((stream dual-channel-gray-stream
) seq
164 &optional
(start 0) end
)
165 (setf (values start end
) (%check-bounds seq start end
))
169 (%read-into-string stream seq start end
)))))
177 (defun %write-n-bytes
(buf fd nbytes
&optional timeout
)
178 (let ((bytes-written 0))
179 (flet ((write-once ()
180 (let ((num (handler-case
181 (et:repeat-upon-eintr
182 (et:write fd
(inc-pointer buf bytes-written
)
185 (return-from %write-n-bytes
(values nil
:eof
))))))
186 (unless (zerop num
) (incf bytes-written num
))))
187 (buffer-emptyp () (zerop nbytes
)))
189 (if (buffer-emptyp) (values t nil
)
190 (et:repeat-decreasing-timeout
(timeout-var timeout
)
191 (unless (setf num
(write-once))
192 (when (member :error
(iomux:wait-until-fd-ready fd
:write
))
193 ;; FIXME signal something better -- maybe analyze the status
194 (return-from %write-n-bytes
(values nil
:fail
))))
195 (when (buffer-emptyp) (return-from %write-n-bytes
(values t bytes-written
)))
196 (when (zerop timeout-var
) (return-from %write-n-bytes
(values nil
:timeout
)))))))))
198 (defun %flush-obuf
(buf fd
&optional timeout
)
199 (let ((bytes-written 0))
200 (flet ((write-once ()
201 (let ((num (handler-case
202 (et:repeat-upon-eintr
203 (et:write fd
(iobuf-start-pointer buf
)
206 (return-from %flush-obuf
(values nil
:eof
))))))
208 (incf (iobuf-start buf
) num
)
209 (incf bytes-written num
))))
211 (when (iobuf-empty-p buf
)
212 (iobuf-reset buf
) t
)))
214 (if (buffer-emptyp) (values t nil
)
215 (et:repeat-decreasing-timeout
(timeout-var timeout
)
216 (unless (setf num
(write-once))
217 (when (member :error
(iomux:wait-until-fd-ready fd
:write
))
218 ;; FIXME signal something better -- maybe analyze the status
219 (return-from %flush-obuf
(values nil
:fail
))))
220 (when (buffer-emptyp) (return-from %flush-obuf
(values t bytes-written
)))
221 (when (zerop timeout-var
) (return-from %flush-obuf
(values nil
:timeout
)))))))))
223 ;; TODO: add timeout support
224 (defun %flush-obuf-if-needed
(stream)
225 (declare (type dual-channel-gray-stream stream
))
226 (with-accessors ((fd output-fd-of
) (ob output-buffer-of
)
227 (must-flush-output-p must-flush-output-p
)) stream
228 (when (or must-flush-output-p
(iobuf-full-p ob
))
230 (setf must-flush-output-p nil
))))
232 (defmethod stream-clear-output ((stream dual-channel-gray-stream
))
233 (with-accessors ((ob output-buffer-of
)
234 (must-flush-output-p must-flush-output-p
)
235 (fd output-fd-of
)) stream
237 (setf must-flush-output-p nil
)
240 (defmethod stream-finish-output ((stream dual-channel-gray-stream
))
241 (with-accessors ((ob output-buffer-of
)
242 (must-flush-output-p must-flush-output-p
)
243 (fd output-fd-of
)) stream
245 (setf must-flush-output-p nil
)
248 (defmethod stream-force-output ((stream dual-channel-gray-stream
))
249 (setf (must-flush-output-p stream
) t
))
251 (defun %write-simple-array-ub8
(stream array start end
)
252 (declare (type dual-channel-gray-stream stream
))
253 (with-accessors ((ob output-buffer-of
)
254 (fd output-fd-of
)) stream
255 (let ((octets-needed (- end start
)))
256 (if (<= octets-needed
(iobuf-end-space-length ob
))
258 (iobuf-copy-from-lisp-array array start ob
259 (iobuf-end ob
) octets-needed
)
260 (incf (iobuf-end ob
) octets-needed
)
261 (%flush-obuf-if-needed stream
))
262 (with-pointer-to-vector-data (ptr array
)
264 (let ((ret (%write-n-bytes
(inc-pointer ptr start
)
267 (incf (iobuf-end ob
) octets-needed
)))))
270 (defun %write-vector-ub8
(stream vector start end
)
271 (declare (type dual-channel-gray-stream stream
))
272 (%write-simple-array-ub8 stream
(coerce vector
'ub8-sarray
) start end
))
274 (defun %write-vector
(stream vector start end
)
275 (declare (type dual-channel-gray-stream stream
))
276 (loop :for offset
:from start
:below end
277 :for octet
:= (aref vector offset
)
278 :do
(stream-write-byte stream octet
)
279 :finally
(return vector
)))
282 (defmethod #-openmcl stream-write-sequence
283 #+openmcl stream-write-vector
284 ((stream dual-channel-gray-stream
) seq
285 &optional
(start 0) end
)
286 (setf (values start end
) (%check-bounds seq start end
))
290 (%write-simple-array-ub8 stream seq start end
))
292 (stream-write-string stream seq start end
))
294 (%write-vector-ub8 stream seq start end
))
296 (%write-vector stream seq start end
)))))
299 (defmethod stream-write-byte-sequence ((stream dual-channel-gray-stream
) seq
300 &optional
(start 0) end
302 (declare (ignore no-hang interactive
))
303 (setf (values start end
) (%check-bounds seq start end
))
307 (%write-simple-array-ub8 stream seq start end
))
309 (%write-vector-ub8 stream seq start end
))
311 (%write-vector stream seq start end
)))))
314 (defmethod stream-write-char-sequence ((stream dual-channel-gray-stream
) seq
315 &optional
(start 0) end
)
316 (setf (values start end
) (%check-bounds seq start end
))
320 (stream-write-string stream seq start end
)))))
322 ;;;;;;;;;;;;;;;;;;;;;
324 ;; Character Input ;;
326 ;;;;;;;;;;;;;;;;;;;;;
328 (defun maybe-find-line-ending (fd ib ef
)
329 (let* ((start-off (iobuf-start ib
))
330 (char-code (bref ib start-off
)))
332 (ecase (ioenc:ef-line-terminator ef
)
333 (:unix
(when (= char-code
(char-code #\Linefeed
))
334 (incf (iobuf-start ib
))
336 (:mac
(when (= char-code
(char-code #\Return
))
337 (incf (iobuf-start ib
))
339 (:dos
(when (= char-code
(char-code #\Return
))
340 (when (and (= (iobuf-length ib
) 1)
341 (eql (%fill-ibuf ib fd
) :eof
))
342 (incf (iobuf-start ib
))
344 (when (= (bref ib
(1+ start-off
))
345 (char-code #\Linefeed
))
346 (incf (iobuf-start ib
) 2)
347 (return #\Newline
))))))))
349 (define-constant +max-octets-per-char
+ 6)
351 ;; FIXME: currently we return :EOF when read(2) returns 0
352 ;; we should distinguish hard end-of-files(EOF and buffer empty)
353 ;; from soft end-of-files(EOF and *some* bytes still in the buffer
354 ;; but not enough to make a full character)
355 (defmethod stream-read-char ((stream dual-channel-gray-stream
))
356 (with-accessors ((fd input-fd-of
) (ib input-buffer-of
)
357 (unread-index ibuf-unread-index-of
)
358 (ef external-format-of
)) stream
359 (setf unread-index
(iobuf-start ib
))
360 (let ((str (make-string 1))
362 (flet ((fill-buf-or-eof ()
363 (setf ret
(%fill-ibuf ib fd
))
365 (return-from stream-read-char
:eof
))))
366 (cond ((zerop (iobuf-length ib
))
369 ;; Some encodings such as CESU or Java's modified UTF-8 take
370 ;; as much as 6 bytes per character. Make sure we have enough
371 ;; space to collect read-ahead bytes if required.
372 ((< 0 (iobuf-end-space-length ib
) +max-octets-per-char
+)
373 (iobuf-copy-data-to-start ib
)
374 (setf unread-index
0)))
377 (maybe-find-line-ending fd ib ef
)))
379 (return-from stream-read-char line-end
)))
382 (setf ret
(nth-value 1 (ioenc::%octets-to-string
385 (iobuf-end ib
) ef
1)))
386 (end-of-input-in-character ()
389 (incf (iobuf-start ib
) ret
))
392 (defun maybe-find-line-ending-no-hang (fd ib ef
)
393 (declare (ignore fd
))
394 (let* ((start-off (iobuf-start ib
))
395 (char-code (bref ib start-off
)))
397 (ecase (ioenc:ef-line-terminator ef
)
398 (:unix
(when (= char-code
(char-code #\Linefeed
))
399 (incf (iobuf-start ib
))
401 (:mac
(when (= char-code
(char-code #\Return
))
402 (incf (iobuf-start ib
))
404 (:dos
(when (= char-code
(char-code #\Return
))
405 (when (= (iobuf-length ib
) 1)
406 (incf (iobuf-start ib
))
407 (return :starvation
))
408 (when (= (bref ib
(1+ start-off
))
409 (char-code #\Linefeed
))
410 (incf (iobuf-start ib
) 2)
411 (return #\Newline
))))))))
413 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream
))
414 (with-accessors ((fd input-fd-of
) (ib input-buffer-of
)
415 (ef external-format-of
)) stream
416 (let ((str (make-string 1))
420 (when (< 0 (iobuf-end-space-length ib
) 4)
421 (iobuf-copy-data-to-start ib
))
422 (when (and (iomux:fd-ready-p fd
:read
)
423 (eql :eof
(%fill-ibuf ib fd
)))
425 (when (zerop (iobuf-length ib
))
426 (return (if eof
:eof nil
)))
429 (maybe-find-line-ending-no-hang fd ib ef
)))
430 (cond ((eql line-end
:starvation
)
431 (return (if eof
#\Return nil
)))
432 ((characterp line-end
)
436 (setf ret
(nth-value 1 (ioenc::%octets-to-string
439 (iobuf-end ib
) ef
1)))
440 (end-of-input-in-character ()
442 (incf (iobuf-start ib
) ret
)
445 (defun %stream-unread-char
(stream)
446 (declare (type dual-channel-gray-stream stream
))
447 (with-accessors ((ib input-buffer-of
)
448 (unread-index ibuf-unread-index-of
)) stream
449 (symbol-macrolet ((start (iobuf-start ib
)))
451 ((> start unread-index
)
452 (setf start unread-index
))
454 (error "No uncommitted character to unread")))))
457 (defmethod stream-unread-char ((stream dual-channel-gray-stream
) character
)
458 ;; unreading anything but the latest character is wrong,
459 ;; but checking is not mandated by the standard
462 (%stream-unread-char stream
)
463 (unless (ignore-errors (eql (stream-read-char stream
) character
))
464 (error "Trying to unread wrong character ~S" character
)))
466 (declare (ignore character
))
468 (%stream-unread-char stream
))
470 (defmethod stream-peek-char ((stream dual-channel-gray-stream
))
471 (let ((char (stream-read-char stream
)))
472 (cond ((eql char
:eof
) :eof
)
473 (t (%stream-unread-char stream
)
476 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
479 (defmethod stream-listen ((stream dual-channel-gray-stream
))
480 (let ((char (stream-read-char-no-hang stream
)))
481 (cond ((characterp char
)
482 (stream-unread-char stream char
)
488 ;;;;;;;;;;;;;;;;;;;;;;
490 ;; Character Output ;;
492 ;;;;;;;;;;;;;;;;;;;;;;
494 (defmethod stream-write-char ((stream dual-channel-gray-stream
)
495 (character character
))
496 (%flush-obuf-if-needed stream
)
497 (if (eql character
#\Newline
)
498 (%write-line-terminator stream
(ioenc:ef-line-terminator
(external-format-of stream
)))
499 ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
500 (stream-write-string stream
(make-string 1 :initial-element character
))))
502 (defmethod stream-start-line-p ((stream dual-channel-gray-stream
))
505 (defmethod stream-terpri ((stream dual-channel-gray-stream
))
506 (write-char #\Newline stream
) nil
)
508 (defmethod stream-fresh-line ((stream dual-channel-gray-stream
))
509 (write-char #\Newline stream
) t
)
511 (define-constant +unix-line-terminator
+
512 (make-array 1 :element-type
'ub8
:initial-contents
'(10)))
513 (define-constant +dos-line-terminator
+
514 (make-array 2 :element-type
'ub8
:initial-contents
'(13 10)))
515 (define-constant +mac-line-terminator
+
516 (make-array 1 :element-type
'ub8
:initial-contents
'(13)))
518 (defun %write-line-terminator
(stream line-terminator
)
519 (case line-terminator
520 (:unix
(%write-simple-array-ub8 stream
+unix-line-terminator
+ 0 1))
521 (:dos
(%write-simple-array-ub8 stream
+dos-line-terminator
+ 0 2))
522 (:mac
(%write-simple-array-ub8 stream
+mac-line-terminator
+ 0 1))))
524 (defmethod stream-write-string ((stream dual-channel-gray-stream
)
526 &optional
(start 0) end
)
527 (setf (values start end
) (%check-bounds string start end
))
530 (ef (external-format-of stream
))
531 (line-terminator (ioenc:ef-line-terminator ef
)))
532 (loop :for off1
:= start
:then
(1+ off2
)
533 :for nl-off
:= (position #\Newline string
:start off1
)
534 :for off2
:= (or nl-off end
)
535 :when nl-off
:do
(%write-line-terminator stream line-terminator
)
536 :when
(> off2 off1
) :do
537 (setf octets
(ioenc:string-to-octets
538 string
:start off1
:end off2
539 :external-format ef
))
540 (%write-simple-array-ub8 stream octets
0 (length octets
))
541 :while
(< off2 end
))))
550 (defmethod stream-read-byte ((stream dual-channel-gray-stream
))
551 (with-accessors ((fd input-fd-of
)
552 (ib input-buffer-of
)) stream
553 (flet ((fill-buf-or-eof ()
555 (when (eql :eof
(%fill-ibuf ib fd
))
556 (return-from stream-read-byte
:eof
))))
557 (when (zerop (iobuf-length ib
))
559 (iobuf-pop-octet ib
))))
567 (defmethod stream-write-byte ((stream dual-channel-gray-stream
) integer
)
568 (check-type integer ub8
"an unsigned 8-bit value")
569 (with-accessors ((ob output-buffer-of
)) stream
570 (%flush-obuf-if-needed stream
)
571 (iobuf-push-octet ob integer
)))