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
)
52 (defmethod stream-element-type ((stream dual-channel-gray-stream
))
55 ;; TODO: use the buffer pool
56 (defmethod close :around
((stream dual-channel-gray-stream
) &key abort
)
57 (with-accessors ((ib input-buffer-of
)
58 (ob output-buffer-of
)) stream
59 (unless (or abort
(null ib
)) (finish-output stream
))
60 (when ib
(free-iobuf ib
))
61 (when ob
(free-iobuf ob
))
66 (defmethod close ((stream dual-channel-gray-stream
) &key abort
)
67 (declare (ignore stream abort
)))
69 (defmethod (setf external-format-of
) (external-format (stream dual-channel-gray-stream
))
70 (setf (slot-value stream
'external-format
)
71 (ensure-external-format external-format
)))
79 (defmethod stream-clear-input ((stream dual-channel-gray-stream
))
80 (with-accessors ((ib input-buffer-of
)) stream
84 (defun %fill-ibuf
(buf fd
&optional timeout
)
87 (iomux:wait-until-fd-ready fd
:read timeout
)))
89 (return-from %fill-ibuf
:timeout
))))
90 (let ((num (et:repeat-upon-eintr
91 (et:read fd
(iobuf-end-pointer buf
)
92 (iobuf-end-space-length buf
)))))
95 (incf (iobuf-end buf
) num
))))
97 (defun %read-into-simple-array-ub8
(stream array start end
)
98 (declare (type dual-channel-gray-stream stream
))
99 (with-accessors ((ib input-buffer-of
)
100 (fd input-fd-of
)) stream
101 (let ((octets-needed (- end start
)))
102 (loop :with array-offset
:= start
103 :for octets-in-buffer
:= (iobuf-length ib
)
104 :for nbytes
:= (min octets-needed octets-in-buffer
)
105 :when
(plusp nbytes
) :do
106 (iobuf-copy-into-lisp-array ib
(iobuf-start ib
)
107 array array-offset nbytes
)
108 (incf array-offset nbytes
)
109 (decf octets-needed nbytes
)
110 (incf (iobuf-start ib
) nbytes
)
111 :if
(zerop octets-needed
) :do
(loop-finish)
112 :else
:do
(iobuf-reset ib
)
113 :when
(eql :eof
(%fill-ibuf ib fd
)) :do
(loop-finish)
114 :finally
(return array-offset
)))))
116 (defun %read-into-string
(stream string start end
)
117 (declare (type dual-channel-gray-stream stream
))
118 (loop :for offset
:from start
:below end
119 :for char
:= (stream-read-char stream
)
120 :if
(eql char
:eof
) :do
(loop-finish)
121 :else
:do
(setf (char string offset
) char
)
122 :finally
(return offset
)))
124 (defun %read-into-vector
(stream vector start end
)
125 (declare (type dual-channel-gray-stream stream
))
126 (loop :for offset
:from start
:below end
127 :for octet
:= (stream-read-byte stream
)
128 :if
(eql octet
:eof
) :do
(loop-finish)
129 :else
:do
(setf (aref vector offset
) octet
)
130 :finally
(return offset
)))
133 (defmethod #-openmcl stream-read-sequence
134 #+openmcl stream-read-vector
136 ((stream dual-channel-gray-stream
) seq
137 &optional
(start 0) end
)
139 ((stream dual-channel-gray-stream
) seq start end
)
140 (setf (values start end
) (%check-bounds seq start end
))
144 (%read-into-simple-array-ub8 stream seq start end
))
146 (%read-into-string stream seq start end
))
148 (%read-into-vector stream seq start end
)))))
151 (defmethod stream-read-byte-sequence ((stream dual-channel-gray-stream
) seq
152 &optional
(start 0) end
154 (declare (ignore no-hang interactive
))
155 (setf (values start end
) (%check-bounds seq start end
))
159 (%read-into-simple-array-ub8 stream seq start end
))
161 (%read-into-vector stream seq start end
)))))
164 (defmethod stream-read-char-sequence ((stream dual-channel-gray-stream
) seq
165 &optional
(start 0) end
)
166 (setf (values start end
) (%check-bounds seq start end
))
170 (%read-into-string stream seq start end
)))))
178 (defun %write-n-bytes
(buf fd nbytes
&optional timeout
)
179 (declare (type stream-buffer buf
))
180 (let ((bytes-written 0))
181 (labels ((write-once ()
182 (let ((num (handler-case
183 (et:repeat-upon-condition-decreasing-timeout
184 ((et:eintr
) timeout-var timeout
)
186 (et:write fd
(inc-pointer buf bytes-written
) nbytes
)
187 (when (and timeout-var
(zerop timeout-var
))
188 (return-from %write-n-bytes
(values nil
:timeout
)))))
190 (return-from %write-n-bytes
(values nil
:eof
))))))
191 (unless (zerop num
) (incf bytes-written num
))))
195 ;; FIXME signal something better -- maybe analyze the status
196 (return-from %write-n-bytes
(values nil
:fail
)))))
197 (buffer-emptyp () (= bytes-written nbytes
))
198 (errorp () (handler-case (iomux:wait-until-fd-ready fd
:write
)
199 (iomux:poll-error
()))))
200 (loop :until
(buffer-emptyp) :do
(write-or-return)
201 :finally
(return (values t bytes-written
))))))
203 (defun %flush-obuf
(buf fd
&optional timeout
)
204 (declare (type iobuf buf
))
205 (let ((bytes-written 0))
206 (labels ((write-once ()
207 (let ((num (handler-case
208 (et:repeat-upon-condition-decreasing-timeout
209 ((et:eintr
) timeout-var timeout
)
211 (et:write fd
(iobuf-start-pointer buf
)
213 (when (and timeout-var
(zerop timeout-var
))
214 (return-from %flush-obuf
(values nil
:timeout
)))))
216 (return-from %flush-obuf
(values nil
:eof
))))))
218 (incf (iobuf-start buf
) num
)
219 (incf bytes-written num
))))
223 ;; FIXME signal something better -- maybe analyze the status
224 (return-from %flush-obuf
(values nil
:fail
)))))
226 (when (iobuf-empty-p buf
)
227 (iobuf-reset buf
) t
))
228 (errorp () (handler-case (iomux:wait-until-fd-ready fd
:write
)
229 (iomux:poll-error
()))))
230 (loop :until
(buffer-emptyp) :do
(write-or-return)
231 :finally
(return (values t bytes-written
))))))
233 ;; TODO: add timeout support
234 (defun %flush-obuf-if-needed
(stream)
235 (declare (type dual-channel-gray-stream stream
))
236 (with-accessors ((fd output-fd-of
) (ob output-buffer-of
)
237 (must-flush-output-p must-flush-output-p
)) stream
238 (when (or must-flush-output-p
(iobuf-full-p ob
))
240 (setf must-flush-output-p nil
))))
242 (defmethod stream-clear-output ((stream dual-channel-gray-stream
))
243 (with-accessors ((ob output-buffer-of
)
244 (must-flush-output-p must-flush-output-p
)
245 (fd output-fd-of
)) stream
247 (setf must-flush-output-p nil
)
250 (defmethod stream-finish-output ((stream dual-channel-gray-stream
))
251 (with-accessors ((ob output-buffer-of
)
252 (must-flush-output-p must-flush-output-p
)
253 (fd output-fd-of
)) stream
255 (setf must-flush-output-p nil
)
258 (defmethod stream-force-output ((stream dual-channel-gray-stream
))
259 (setf (must-flush-output-p stream
) t
))
261 (defun %write-simple-array-ub8
(stream array start end
)
262 (declare (type dual-channel-gray-stream stream
))
263 (with-accessors ((ob output-buffer-of
)
264 (fd output-fd-of
)) stream
265 (let ((octets-needed (- end start
)))
266 (if (<= octets-needed
(iobuf-end-space-length ob
))
268 (iobuf-copy-from-lisp-array array start ob
269 (iobuf-end ob
) octets-needed
)
270 (incf (iobuf-end ob
) octets-needed
)
271 (%flush-obuf-if-needed stream
))
272 (with-pointer-to-vector-data (ptr array
)
274 (let ((ret (%write-n-bytes
(inc-pointer ptr start
)
277 (incf (iobuf-end ob
) octets-needed
)))))
280 (defun %write-vector-ub8
(stream vector start end
)
281 (declare (type dual-channel-gray-stream stream
))
282 (%write-simple-array-ub8 stream
(coerce vector
'ub8-sarray
) start end
))
284 (defun %write-vector
(stream vector start end
)
285 (declare (type dual-channel-gray-stream stream
))
286 (loop :for offset
:from start
:below end
287 :for octet
:= (aref vector offset
)
288 :do
(stream-write-byte stream octet
)
289 :finally
(return vector
)))
292 (defmethod #-openmcl stream-write-sequence
293 #+openmcl stream-write-vector
295 ((stream dual-channel-gray-stream
) seq
296 &optional
(start 0) end
)
298 ((stream dual-channel-gray-stream
) seq start end
)
299 (setf (values start end
) (%check-bounds seq start end
))
303 (%write-simple-array-ub8 stream seq start end
))
305 (stream-write-string stream seq start end
))
307 (%write-vector-ub8 stream seq start end
))
309 (%write-vector stream seq start end
)))))
312 (defmethod stream-write-byte-sequence ((stream dual-channel-gray-stream
) seq
313 &optional
(start 0) end
315 (declare (ignore no-hang interactive
))
316 (setf (values start end
) (%check-bounds seq start end
))
320 (%write-simple-array-ub8 stream seq start end
))
322 (%write-vector-ub8 stream seq start end
))
324 (%write-vector stream seq start end
)))))
327 (defmethod stream-write-char-sequence ((stream dual-channel-gray-stream
) seq
328 &optional
(start 0) end
)
329 (setf (values start end
) (%check-bounds seq start end
))
333 (stream-write-string stream seq start end
)))))
335 ;;;;;;;;;;;;;;;;;;;;;
337 ;; Character Input ;;
339 ;;;;;;;;;;;;;;;;;;;;;
341 (defun maybe-find-line-ending (fd ib ef
)
342 (let* ((start-off (iobuf-start ib
))
343 (char-code (bref ib start-off
)))
345 (ecase (ioenc:ef-line-terminator ef
)
346 (:unix
(when (= char-code
(char-code #\Linefeed
))
347 (incf (iobuf-start ib
))
349 (:mac
(when (= char-code
(char-code #\Return
))
350 (incf (iobuf-start ib
))
352 (:dos
(when (= char-code
(char-code #\Return
))
353 (when (and (= (iobuf-length ib
) 1)
354 (eql (%fill-ibuf ib fd
) :eof
))
355 (incf (iobuf-start ib
))
357 (when (= (bref ib
(1+ start-off
))
358 (char-code #\Linefeed
))
359 (incf (iobuf-start ib
) 2)
360 (return #\Newline
))))))))
362 (define-constant +max-octets-per-char
+ 6)
364 ;; FIXME: currently we return :EOF when read(2) returns 0
365 ;; we should distinguish hard end-of-files(EOF and buffer empty)
366 ;; from soft end-of-files(EOF and *some* bytes still in the buffer
367 ;; but not enough to make a full character)
368 (defmethod stream-read-char ((stream dual-channel-gray-stream
))
369 (with-accessors ((fd input-fd-of
) (ib input-buffer-of
)
370 (unread-index ibuf-unread-index-of
)
371 (ef external-format-of
)) stream
372 (flet ((decode-one-char (str ib ef
)
373 (ioenc::%octets-to-string
(iobuf-data ib
) str
(iobuf-start ib
)
374 (iobuf-end ib
) ef
1)))
375 (setf unread-index
(iobuf-start ib
))
376 (let ((str (make-string 1))
378 (flet ((fill-buf-or-eof ()
379 (setf ret
(%fill-ibuf ib fd
))
381 (return-from stream-read-char
:eof
))))
382 (cond ((zerop (iobuf-length ib
))
385 ;; Some encodings such as CESU or Java's modified UTF-8 take
386 ;; as much as 6 bytes per character. Make sure we have enough
387 ;; space to collect read-ahead bytes if required.
388 ((< 0 (iobuf-end-space-length ib
) +max-octets-per-char
+)
389 (iobuf-copy-data-to-start ib
)
390 (setf unread-index
0)))
392 (return-if stream-read-char
(maybe-find-line-ending fd ib ef
))
395 (setf ret
(nth-value 1 (decode-one-char str ib ef
)))
396 (end-of-input-in-character ()
399 (incf (iobuf-start ib
) ret
))
402 (defun maybe-find-line-ending-no-hang (fd ib ef
)
403 (declare (ignore fd
))
404 (let* ((start-off (iobuf-start ib
))
405 (char-code (bref ib start-off
)))
407 (ecase (ioenc:ef-line-terminator ef
)
408 (:unix
(when (= char-code
(char-code #\Linefeed
))
409 (incf (iobuf-start ib
))
411 (:mac
(when (= char-code
(char-code #\Return
))
412 (incf (iobuf-start ib
))
414 (:dos
(when (= char-code
(char-code #\Return
))
415 (when (= (iobuf-length ib
) 1)
416 (incf (iobuf-start ib
))
417 (return :starvation
))
418 (when (= (bref ib
(1+ start-off
))
419 (char-code #\Linefeed
))
420 (incf (iobuf-start ib
) 2)
421 (return #\Newline
))))))))
423 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream
))
424 (with-accessors ((fd input-fd-of
) (ib input-buffer-of
)
425 (ef external-format-of
)) stream
426 (let ((str (make-string 1))
430 (when (< 0 (iobuf-end-space-length ib
) 4)
431 (iobuf-copy-data-to-start ib
))
432 (when (and (iomux:fd-ready-p fd
:read
)
433 (eql :eof
(%fill-ibuf ib fd
)))
435 (when (zerop (iobuf-length ib
))
436 (return (if eof
:eof nil
)))
439 (maybe-find-line-ending-no-hang fd ib ef
)))
440 (cond ((eql line-end
:starvation
)
441 (return (if eof
#\Return nil
)))
442 ((characterp line-end
)
446 (setf ret
(nth-value 1 (ioenc::%octets-to-string
449 (iobuf-end ib
) ef
1)))
450 (end-of-input-in-character ()
452 (incf (iobuf-start ib
) ret
)
455 (defun %stream-unread-char
(stream)
456 (declare (type dual-channel-gray-stream stream
))
457 (with-accessors ((ib input-buffer-of
)
458 (unread-index ibuf-unread-index-of
)) stream
459 (symbol-macrolet ((start (iobuf-start ib
)))
461 ((> start unread-index
)
462 (setf start unread-index
))
464 (error "No uncommitted character to unread")))))
467 (defmethod stream-unread-char ((stream dual-channel-gray-stream
) character
)
468 ;; unreading anything but the latest character is wrong,
469 ;; but checking is not mandated by the standard
472 (%stream-unread-char stream
)
473 (unless (ignore-errors (eql (stream-read-char stream
) character
))
474 (error "Trying to unread wrong character ~S" character
)))
476 (declare (ignore character
))
478 (%stream-unread-char stream
))
480 (defmethod stream-peek-char ((stream dual-channel-gray-stream
))
481 (let ((char (stream-read-char stream
)))
482 (cond ((eql char
:eof
) :eof
)
483 (t (%stream-unread-char stream
)
486 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
489 (defmethod stream-listen ((stream dual-channel-gray-stream
))
490 (let ((char (stream-read-char-no-hang stream
)))
491 (cond ((characterp char
)
492 (stream-unread-char stream char
)
498 ;;;;;;;;;;;;;;;;;;;;;;
500 ;; Character Output ;;
502 ;;;;;;;;;;;;;;;;;;;;;;
504 (defmethod stream-write-char ((stream dual-channel-gray-stream
)
505 (character character
))
506 (%flush-obuf-if-needed stream
)
507 (if (char= character
#\Newline
)
508 (%write-line-terminator stream
(ioenc:ef-line-terminator
(external-format-of stream
)))
509 ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
510 (stream-write-string stream
(make-string 1 :initial-element character
))))
512 (defmethod stream-line-column ((stream dual-channel-gray-stream
))
515 (defmethod stream-start-line-p ((stream dual-channel-gray-stream
))
518 (defmethod stream-terpri ((stream dual-channel-gray-stream
))
519 (write-char #\Newline stream
) nil
)
521 (defmethod stream-fresh-line ((stream dual-channel-gray-stream
))
522 (write-char #\Newline stream
) t
)
524 (define-constant +unix-line-terminator
+
525 (make-array 1 :element-type
'ub8
:initial-contents
'(10)))
526 (define-constant +dos-line-terminator
+
527 (make-array 2 :element-type
'ub8
:initial-contents
'(13 10)))
528 (define-constant +mac-line-terminator
+
529 (make-array 1 :element-type
'ub8
:initial-contents
'(13)))
531 (defun %write-line-terminator
(stream line-terminator
)
532 (case line-terminator
533 (:unix
(%write-simple-array-ub8 stream
+unix-line-terminator
+ 0 1))
534 (:dos
(%write-simple-array-ub8 stream
+dos-line-terminator
+ 0 2))
535 (:mac
(%write-simple-array-ub8 stream
+mac-line-terminator
+ 0 1))))
537 (defmethod stream-write-string ((stream dual-channel-gray-stream
)
539 &optional
(start 0) end
)
540 (setf (values start end
) (%check-bounds string start end
))
543 (ef (external-format-of stream
))
544 (line-terminator (ioenc:ef-line-terminator ef
)))
545 (loop :for off1
:= start
:then
(1+ off2
)
546 :for nl-off
:= (position #\Newline string
:start off1
)
547 :for off2
:= (or nl-off end
)
548 :when nl-off
:do
(%write-line-terminator stream line-terminator
)
549 :when
(> off2 off1
) :do
550 (setf octets
(ioenc:string-to-octets
551 string
:start off1
:end off2
552 :external-format ef
))
553 (%write-simple-array-ub8 stream octets
0 (length octets
))
554 :while
(< off2 end
))))
563 (defmethod stream-read-byte ((stream dual-channel-gray-stream
))
564 (with-accessors ((fd input-fd-of
)
565 (ib input-buffer-of
)) stream
566 (flet ((fill-buf-or-eof ()
568 (when (eql :eof
(%fill-ibuf ib fd
))
569 (return-from stream-read-byte
:eof
))))
570 (when (zerop (iobuf-length ib
))
572 (iobuf-pop-octet ib
))))
580 (defmethod stream-write-byte ((stream dual-channel-gray-stream
) integer
)
581 (check-type integer ub8
"an unsigned 8-bit value")
582 (with-accessors ((ob output-buffer-of
)) stream
583 (%flush-obuf-if-needed stream
)
584 (iobuf-push-octet ob integer
)))