input.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
input.lisp (13156B)
---
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/flexi-streams/input.lisp,v 1.78 2008/05/25 19:25:44 edi Exp $
3
4 ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :flexi-streams)
31
32 #-:lispworks
33 (defmethod read-byte* ((flexi-input-stream flexi-input-stream))
34 "Reads one byte \(octet) from the underlying stream of
35 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not
36 empty)."
37 (declare #.*standard-optimize-settings*)
38 ;; we're using S instead of STREAM here because of an
39 ;; issue with SBCL:
40 ;; <http://article.gmane.org/gmane.lisp.steel-bank.general/1386>
41 (with-accessors ((position flexi-stream-position)
42 (bound flexi-stream-bound)
43 (octet-stack flexi-stream-octet-stack)
44 (s flexi-stream-stream))
45 flexi-input-stream
46 (declare (integer position)
47 (type (or null integer) bound))
48 (when (and bound
49 (>= position bound))
50 (return-from read-byte* nil))
51 (incf position)
52 (or (pop octet-stack)
53 (read-byte s nil nil)
54 (progn (decf position) nil))))
55
56 #+:lispworks
57 (defmethod read-byte* ((flexi-input-stream flexi-input-stream))
58 "Reads one byte \(octet) from the underlying \(binary) stream of
59 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty)."
60 (declare #.*standard-optimize-settings*)
61 (with-accessors ((position flexi-stream-position)
62 (bound flexi-stream-bound)
63 (octet-stack flexi-stream-octet-stack)
64 (stream flexi-stream-stream))
65 flexi-input-stream
66 (declare (integer position)
67 (type (or null integer) bound))
68 (when (and bound
69 (>= position bound))
70 (return-from read-byte* nil))
71 (incf position)
72 (or (pop octet-stack)
73 (read-byte stream nil nil)
74 (progn (decf position) nil))))
75
76 #+:lispworks
77 (defmethod read-byte* ((flexi-input-stream flexi-char-input-stream))
78 "Reads one byte \(octet) from the underlying stream of
79 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty).
80 Only used for LispWorks bivalent streams which aren't binary."
81 (declare #.*standard-optimize-settings*)
82 (with-accessors ((position flexi-stream-position)
83 (bound flexi-stream-bound)
84 (octet-stack flexi-stream-octet-stack)
85 (stream flexi-stream-stream))
86 flexi-input-stream
87 (declare (integer position)
88 (type (or null integer) bound))
89 (when (and bound
90 (>= position bound))
91 (return-from read-byte* nil))
92 (incf position)
93 (or (pop octet-stack)
94 ;; we use READ-SEQUENCE because READ-BYTE doesn't work with all
95 ;; bivalent streams in LispWorks
96 (let* ((buffer (make-array 1 :element-type 'octet))
97 (new-position (read-sequence buffer stream)))
98 (cond ((zerop new-position)
99 (decf position) nil)
100 (t (aref buffer 0)))))))
101
102 (defmethod stream-clear-input ((flexi-input-stream flexi-input-stream))
103 "Calls the corresponding method for the underlying input stream
104 and also clears the value of the OCTET-STACK slot."
105 (declare #.*standard-optimize-settings*)
106 ;; note that we don't reset the POSITION slot
107 (with-accessors ((octet-stack flexi-stream-octet-stack)
108 (stream flexi-stream-stream))
109 flexi-input-stream
110 (setq octet-stack nil)
111 (clear-input stream)))
112
113 (defmethod stream-listen ((flexi-input-stream flexi-input-stream))
114 "Calls the corresponding method for the underlying input stream
115 but first checks if \(old) input is available in the OCTET-STACK
116 slot."
117 (declare #.*standard-optimize-settings*)
118 (with-accessors ((position flexi-stream-position)
119 (bound flexi-stream-bound)
120 (octet-stack flexi-stream-octet-stack)
121 (stream flexi-stream-stream))
122 flexi-input-stream
123 (declare (integer position)
124 (type (or null integer) bound))
125 (when (and bound
126 (>= position bound))
127 (return-from stream-listen nil))
128 (or octet-stack (listen stream))))
129
130 (defmethod stream-read-byte ((stream flexi-input-stream))
131 "Reads one byte \(octet) from the underlying stream."
132 (declare #.*standard-optimize-settings*)
133 ;; set LAST-CHAR-CODE slot to NIL because we can't UNREAD-CHAR after
134 ;; this operation
135 (with-accessors ((last-char-code flexi-stream-last-char-code)
136 (last-octet flexi-stream-last-octet))
137 stream
138 (setq last-char-code nil)
139 (let ((octet (read-byte* stream)))
140 (setq last-octet octet)
141 (or octet :eof))))
142
143 (defun unread-char% (char flexi-input-stream)
144 "Used internally to put a character CHAR which was already read back
145 on the stream. Uses the OCTET-STACK slot and decrements the POSITION
146 slot accordingly."
147 (declare #.*standard-optimize-settings*)
148 (with-accessors ((position flexi-stream-position)
149 (octet-stack flexi-stream-octet-stack)
150 (external-format flexi-stream-external-format))
151 flexi-input-stream
152 (let ((counter 0) octets-reversed)
153 (declare (fixnum counter))
154 (flet ((writer (octet)
155 (incf counter)
156 (push octet octets-reversed)))
157 (declare (dynamic-extent (function writer)))
158 (char-to-octets external-format char #'writer)
159 (decf position counter)
160 (setq octet-stack (nreconc octets-reversed octet-stack))))))
161
162 (defmethod stream-read-char ((stream flexi-input-stream))
163 (declare #.*standard-optimize-settings*)
164 ;; note that we do nothing for the :LF EOL style because we assume
165 ;; that #\Newline is the same as #\Linefeed in all Lisps which will
166 ;; use this library
167 (with-accessors ((external-format flexi-stream-external-format)
168 (last-octet flexi-stream-last-octet)
169 (last-char-code flexi-stream-last-char-code))
170 stream
171 ;; set LAST-OCTET slot to NIL because we can't UNREAD-BYTE after
172 ;; this operation
173 (setq last-octet nil)
174 (flet ((reader ()
175 (read-byte* stream))
176 (unreader (char)
177 (unread-char% char stream)))
178 (declare (dynamic-extent (function reader) (function unreader)))
179 (let* ((*current-unreader* #'unreader)
180 (char-code (or (octets-to-char-code external-format #'reader)
181 (return-from stream-read-char :eof))))
182 ;; remember this character and its char code for UNREAD-CHAR
183 (setq last-char-code char-code)
184 (or (code-char char-code) char-code)))))
185
186 (defmethod stream-read-char-no-hang ((stream flexi-input-stream))
187 "Reads one character if the underlying stream has at least one
188 octet available."
189 (declare #.*standard-optimize-settings*)
190 ;; note that this may block for non-8-bit encodings - I think
191 ;; there's no easy way to handle this correctly
192 (and (stream-listen stream)
193 (stream-read-char stream)))
194
195 (defmethod stream-read-sequence ((flexi-input-stream flexi-input-stream) sequence start end &key)
196 "An optimized version which uses a buffer underneath. The function
197 can deliver characters as well as octets and it decides what to do
198 based on the element type of the sequence \(which takes precedence)
199 and the element type of the stream. What you'll really get might also
200 depend on your Lisp. Some of the implementations are more picky than
201 others - see for example FLEXI-STREAMS-TEST::SEQUENCE-TEST."
202 (declare #.*standard-optimize-settings*)
203 (declare (fixnum start end))
204 (with-accessors ((octet-stack flexi-stream-octet-stack)
205 (external-format flexi-stream-external-format)
206 (last-octet flexi-stream-last-octet)
207 (last-char-code flexi-stream-last-char-code)
208 (element-type flexi-stream-element-type)
209 (stream flexi-stream-stream)
210 (position flexi-stream-position))
211 flexi-input-stream
212 (when (>= start end)
213 (return-from stream-read-sequence start))
214 (when (or (typep sequence
215 '(and vector
216 (not string)
217 (not (vector t))))
218 (and (not (stringp sequence))
219 (type-equal element-type 'octet)))
220 ;; if binary data is requested, just read from the underlying
221 ;; stream directly and skip the rest (but flush octet stack
222 ;; first)
223 (let ((index start))
224 (declare (fixnum index))
225 (when octet-stack
226 (replace sequence octet-stack :start1 start :end1 end)
227 (let ((octets-flushed (min (length octet-stack) (- end start))))
228 (incf index octets-flushed)
229 (setq octet-stack (nthcdr octets-flushed octet-stack))))
230 (setq index (read-sequence sequence stream :start index :end end))
231 (when (> index start)
232 (setq last-char-code nil
233 last-octet (elt sequence (1- index))))
234 (incf position (- index start))
235 (return-from stream-read-sequence index)))
236 ;; otherwise hand over to the external format to do the work
237 (read-sequence* external-format flexi-input-stream sequence start end)))
238
239 (defmethod stream-unread-char ((stream flexi-input-stream) char)
240 "Implements UNREAD-CHAR for streams of type FLEXI-INPUT-STREAM.
241 Makes sure CHAR will only be unread if it was the last character
242 read and if it was read with the same encoding that's currently
243 being used by the stream."
244 (declare #.*standard-optimize-settings*)
245 (with-accessors ((last-char-code flexi-stream-last-char-code))
246 stream
247 (unless last-char-code
248 (error 'flexi-stream-error
249 :stream stream
250 :format-control "No character to unread from this stream \(or external format has changed or last reading operation was binary)."))
251 (unless (= (char-code char) last-char-code)
252 (error 'flexi-stream-error
253 :stream stream
254 :format-control "Last character read (~S) was different from ~S."
255 :format-arguments (list (code-char last-char-code) char)))
256 (unread-char% char stream)
257 (setq last-char-code nil)
258 nil))
259
260 (defmethod unread-byte (byte (flexi-input-stream flexi-input-stream))
261 "Similar to UNREAD-CHAR in that it `unreads' the last octet from
262 STREAM. Note that you can only call UNREAD-BYTE after a corresponding
263 READ-BYTE."
264 (declare #.*standard-optimize-settings*)
265 (with-accessors ((last-octet flexi-stream-last-octet)
266 (octet-stack flexi-stream-octet-stack)
267 (position flexi-stream-position))
268 flexi-input-stream
269 (unless last-octet
270 (error 'flexi-stream-error
271 :stream stream
272 :format-control "No byte to unread from this stream \(or last reading operation read a character)."))
273 (unless (= byte last-octet)
274 (error 'flexi-stream-error
275 :stream stream
276 :format-control "Last byte read was different from #x~X."
277 :format-arguments (list byte)))
278 (setq last-octet nil)
279 (decf (the integer position))
280 (push byte octet-stack)
281 nil))
282
283 (defmethod peek-byte ((flexi-input-stream flexi-input-stream)
284 &optional peek-type (eof-error-p t) eof-value)
285 "Returns an octet from FLEXI-INPUT-STREAM without actually removing it."
286 (declare #.*standard-optimize-settings*)
287 (loop for octet = (read-byte flexi-input-stream eof-error-p :eof)
288 until (cond ((eq octet :eof)
289 (return eof-value))
290 ((null peek-type))
291 ((eq peek-type t)
292 (plusp octet))
293 ((= octet peek-type)))
294 finally (unread-byte octet flexi-input-stream)
295 (return octet)))