tin-memory.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tin-memory.lisp (19043B)
---
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/flexi-streams/in-memory.lisp,v 1.31 2008/05/19 07:57:07 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 (defclass in-memory-stream (trivial-gray-stream-mixin)
33 ((transformer :initarg :transformer
34 :accessor in-memory-stream-transformer
35 :documentation "A function used to transform the
36 written/read octet to the value stored/retrieved in/from the
37 underlying vector.")
38 #+:cmu
39 (open-p :initform t
40 :accessor in-memory-stream-open-p
41 :documentation "For CMUCL we have to keep track of this
42 manually."))
43 (:documentation "An IN-MEMORY-STREAM is a binary stream that reads
44 octets from or writes octets to a sequence in RAM."))
45
46 (defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
47 ()
48 (:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that
49 reads octets from a sequence in RAM."))
50
51 #+:cmu
52 (defmethod output-stream-p ((stream in-memory-input-stream))
53 "Explicitly states whether this is an output stream."
54 (declare (optimize speed))
55 nil)
56
57 (defclass in-memory-output-stream (in-memory-stream fundamental-binary-output-stream)
58 ()
59 (:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
60 writes octets to a sequence in RAM."))
61
62 #+:cmu
63 (defmethod input-stream-p ((stream in-memory-output-stream))
64 "Explicitly states whether this is an input stream."
65 (declare (optimize speed))
66 nil)
67
68 (defclass list-stream ()
69 ((list :initarg :list
70 :accessor list-stream-list
71 :documentation "The underlying list of the stream."))
72 (:documentation "A LIST-STREAM is a mixin for IN-MEMORY streams
73 where the underlying sequence is a list."))
74
75 (defclass vector-stream ()
76 ((vector :initarg :vector
77 :accessor vector-stream-vector
78 :documentation "The underlying vector of the stream which
79 \(for output) must always be adjustable and have a fill pointer."))
80 (:documentation "A VECTOR-STREAM is a mixin for IN-MEMORY streams
81 where the underlying sequence is a vector."))
82
83 (defclass list-input-stream (list-stream in-memory-input-stream)
84 ()
85 (:documentation "A binary input stream that gets its data from an
86 associated list of octets."))
87
88 (defclass vector-input-stream (vector-stream in-memory-input-stream)
89 ((index :initarg :index
90 :accessor vector-stream-index
91 :type (integer 0 #.array-dimension-limit)
92 :documentation "An index into the underlying vector denoting
93 the current position.")
94 (end :initarg :end
95 :accessor vector-stream-end
96 :type (integer 0 #.array-dimension-limit)
97 :documentation "An index into the underlying vector denoting
98 the end of the available data."))
99 (:documentation "A binary input stream that gets its data from an
100 associated vector of octets."))
101
102 (defclass vector-output-stream (vector-stream in-memory-output-stream)
103 ()
104 (:documentation "A binary output stream that writes its data to an
105 associated vector."))
106
107 #+:cmu
108 (defmethod open-stream-p ((stream in-memory-stream))
109 "Returns a true value if STREAM is open. See ANSI standard."
110 (declare #.*standard-optimize-settings*)
111 (in-memory-stream-open-p stream))
112
113 #+:cmu
114 (defmethod close ((stream in-memory-stream) &key abort)
115 "Closes the stream STREAM. See ANSI standard."
116 (declare #.*standard-optimize-settings*)
117 (declare (ignore abort))
118 (prog1
119 (in-memory-stream-open-p stream)
120 (setf (in-memory-stream-open-p stream) nil)))
121
122 (defmethod check-if-open ((stream in-memory-stream))
123 "Checks if STREAM is open and signals an error otherwise."
124 (declare #.*standard-optimize-settings*)
125 (unless (open-stream-p stream)
126 (error 'in-memory-stream-closed-error
127 :stream stream)))
128
129 (defmethod stream-element-type ((stream in-memory-stream))
130 "The element type is always OCTET by definition."
131 (declare #.*standard-optimize-settings*)
132 'octet)
133
134 (defgeneric peek-byte (stream &optional peek-type eof-err-p eof-value)
135 (:documentation
136 "PEEK-BYTE is like PEEK-CHAR, i.e. it returns a byte from the stream without
137 actually removing it. If PEEK-TYPE is NIL the next byte is returned, if
138 PEEK-TYPE is T, the next byte which is not 0 is returned, if PEEK-TYPE is an
139 byte, the next byte which equals PEEK-TYPE is returned. EOF-ERROR-P and
140 EOF-VALUE are interpreted as usual."))
141
142 (defmethod peek-byte ((stream vector-input-stream) &optional peek-type (eof-error-p t) eof-value)
143 "Returns a byte from VECTOR-INPUT-STREAM without actually removing it."
144 (declare #.*standard-optimize-settings*)
145 (let ((index (vector-stream-index stream)))
146 (loop :for byte = (read-byte stream eof-error-p :eof)
147 :for new-index :from index
148 :until (cond ((eq byte :eof)
149 (return eof-value))
150 ((null peek-type))
151 ((eq peek-type 't)
152 (plusp byte))
153 ((= byte peek-type)))
154 :finally (setf (slot-value stream 'index) new-index)
155 (return byte))))
156
157 (defmethod peek-byte ((stream list-input-stream) &optional peek-type (eof-error-p t) eof-value)
158 "Returns a byte from VECTOR-INPUT-STREAM without actually removing it."
159 (declare #.*standard-optimize-settings*)
160 (loop
161 :for list-elem = (car (list-stream-list stream))
162 :for byte = (read-byte stream eof-error-p :eof)
163 :until (cond ((eq byte :eof)
164 (return eof-value))
165 ((null peek-type))
166 ((eq peek-type 't)
167 (plusp byte))
168 ((= byte peek-type)))
169 :finally (push list-elem (list-stream-list stream))
170 (return byte)))
171
172 (defmethod transform-octet ((stream in-memory-stream) octet)
173 "Applies the transformer of STREAM to octet and returns the result."
174 (declare #.*standard-optimize-settings*)
175 (funcall (or (in-memory-stream-transformer stream)
176 #'identity) octet))
177
178 (defmethod stream-read-byte ((stream list-input-stream))
179 "Reads one byte by simply popping it off of the top of the list."
180 (declare #.*standard-optimize-settings*)
181 (check-if-open stream)
182 (with-accessors ((list list-stream-list))
183 stream
184 (transform-octet stream (or (pop list) (return-from stream-read-byte :eof)))))
185
186 (defmethod stream-listen ((stream list-input-stream))
187 "Checks whether list is not empty."
188 (declare #.*standard-optimize-settings*)
189 (check-if-open stream)
190 (with-accessors ((list list-stream-list))
191 stream
192 list))
193
194 (defmethod stream-read-sequence ((stream list-input-stream) sequence start end &key)
195 "Repeatedly pops elements from the list until it's empty."
196 (declare #.*standard-optimize-settings*)
197 (declare (fixnum start end))
198 (with-accessors ((list list-stream-list))
199 stream
200 (loop for index of-type fixnum from start below end
201 while list
202 do (setf (elt sequence index) (pop list))
203 finally (return index))))
204
205 (defmethod stream-read-byte ((stream vector-input-stream))
206 "Reads one byte and increments INDEX pointer unless we're beyond
207 END pointer."
208 (declare #.*standard-optimize-settings*)
209 (check-if-open stream)
210 (with-accessors ((index vector-stream-index)
211 (end vector-stream-end)
212 (vector vector-stream-vector))
213 stream
214 (let ((current-index index))
215 (declare (fixnum current-index))
216 (cond ((< current-index (the fixnum end))
217 (incf (the fixnum index))
218 (transform-octet stream (aref vector current-index)))
219 (t :eof)))))
220
221 (defmethod stream-listen ((stream vector-input-stream))
222 "Checking whether INDEX is beyond END."
223 (declare #.*standard-optimize-settings*)
224 (check-if-open stream)
225 (with-accessors ((index vector-stream-index)
226 (end vector-stream-end))
227 stream
228 (< (the fixnum index) (the fixnum end))))
229
230 (defmethod stream-read-sequence ((stream vector-input-stream) sequence start end &key)
231 "Traverses both sequences in parallel until the end of one of them
232 is reached."
233 (declare #.*standard-optimize-settings*)
234 (declare (fixnum start end))
235 (loop with vector-end of-type fixnum = (vector-stream-end stream)
236 with vector = (vector-stream-vector stream)
237 for index of-type fixnum from start below end
238 for vector-index of-type fixnum = (vector-stream-index stream)
239 while (< vector-index vector-end)
240 do (setf (elt sequence index)
241 (aref vector vector-index))
242 (incf (the fixnum (vector-stream-index stream)))
243 finally (return index)))
244
245 (defmethod stream-write-byte ((stream vector-output-stream) byte)
246 "Writes a byte \(octet) by extending the underlying vector."
247 (declare #.*standard-optimize-settings*)
248 (check-if-open stream)
249 (with-accessors ((vector vector-stream-vector))
250 stream
251 (vector-push-extend (transform-octet stream byte) vector)))
252
253 (defmethod stream-write-sequence ((stream vector-output-stream) sequence start end &key)
254 "Just calls VECTOR-PUSH-EXTEND repeatedly."
255 (declare #.*standard-optimize-settings*)
256 (declare (fixnum start end))
257 (with-accessors ((vector vector-stream-vector))
258 stream
259 (loop for index of-type fixnum from start below end
260 do (vector-push-extend (transform-octet stream (elt sequence index)) vector))
261 sequence))
262
263 (defmethod stream-file-position ((stream vector-input-stream))
264 "Simply returns the index into the underlying vector."
265 (declare #.*standard-optimize-settings*)
266 (with-accessors ((index vector-stream-index))
267 stream
268 index))
269
270 (defmethod (setf stream-file-position) (position-spec (stream vector-input-stream))
271 "Sets the index into the underlying vector if POSITION-SPEC is acceptable."
272 (declare #.*standard-optimize-settings*)
273 (with-accessors ((index vector-stream-index)
274 (end vector-stream-end))
275 stream
276 (setq index
277 (case position-spec
278 (:start 0)
279 (:end end)
280 (otherwise
281 (unless (integerp position-spec)
282 (error 'in-memory-stream-position-spec-error
283 :format-control "Unknown file position designator: ~S."
284 :format-arguments (list position-spec)
285 :stream stream
286 :position-spec position-spec))
287 (unless (<= 0 position-spec end)
288 (error 'in-memory-stream-position-spec-error
289 :format-control "File position designator ~S is out of bounds."
290 :format-arguments (list position-spec)
291 :stream stream
292 :position-spec position-spec))
293 position-spec)))
294 position-spec))
295
296 (defmethod stream-file-position ((stream vector-output-stream))
297 "Simply returns the fill pointer of the underlying vector."
298 (declare #.*standard-optimize-settings*)
299 (with-accessors ((vector vector-stream-vector))
300 stream
301 (fill-pointer vector)))
302
303 (defmethod (setf stream-file-position) (position-spec (stream vector-output-stream))
304 "Sets the fill pointer underlying vector if POSITION-SPEC is
305 acceptable. Adjusts the vector if necessary."
306 (declare #.*standard-optimize-settings*)
307 (with-accessors ((vector vector-stream-vector))
308 stream
309 (let* ((total-size (array-total-size vector))
310 (new-fill-pointer
311 (case position-spec
312 (:start 0)
313 (:end
314 (warn "File position designator :END doesn't really make sense for an output stream.")
315 total-size)
316 (otherwise
317 (unless (integerp position-spec)
318 (error 'in-memory-stream-position-spec-error
319 :format-control "Unknown file position designator: ~S."
320 :format-arguments (list position-spec)
321 :stream stream
322 :position-spec position-spec))
323 (unless (<= 0 position-spec array-total-size-limit)
324 (error 'in-memory-stream-position-spec-error
325 :format-control "File position designator ~S is out of bounds."
326 :format-arguments (list position-spec)
327 :stream stream
328 :position-spec position-spec))
329 position-spec))))
330 (declare (fixnum total-size new-fill-pointer))
331 (when (> new-fill-pointer total-size)
332 (adjust-array vector new-fill-pointer))
333 (setf (fill-pointer vector) new-fill-pointer)
334 position-spec)))
335
336 (defmethod make-in-memory-input-stream ((vector vector) &key (start 0)
337 (end (length vector))
338 transformer)
339 "Returns a binary input stream which will supply, in order, the
340 octets in the subsequence of VECTOR bounded by START and END.
341 Each octet returned will be transformed in turn by the optional
342 TRANSFORMER function."
343 (declare #.*standard-optimize-settings*)
344 (make-instance 'vector-input-stream
345 :vector vector
346 :index start
347 :end end
348 :transformer transformer))
349
350 (defmethod make-in-memory-input-stream ((list list) &key (start 0)
351 (end (length list))
352 transformer)
353 "Returns a binary input stream which will supply, in order, the
354 octets in the subsequence of LIST bounded by START and END. Each
355 octet returned will be transformed in turn by the optional
356 TRANSFORMER function."
357 (declare #.*standard-optimize-settings*)
358 (make-instance 'list-input-stream
359 :list (subseq list start end)
360 :transformer transformer))
361
362 (defun make-output-vector (&key (element-type 'octet))
363 "Creates and returns an array which can be used as the underlying
364 vector for a VECTOR-OUTPUT-STREAM."
365 (declare #.*standard-optimize-settings*)
366 (make-array 0 :adjustable t
367 :fill-pointer 0
368 :element-type element-type))
369
370 (defun make-in-memory-output-stream (&key (element-type 'octet) transformer)
371 "Returns a binary output stream which accepts objects of type
372 ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence
373 that contains the octes that were actually output. The octets
374 stored will each be transformed by the optional TRANSFORMER
375 function."
376 (declare #.*standard-optimize-settings*)
377 (make-instance 'vector-output-stream
378 :vector (make-output-vector :element-type element-type)
379 :transformer transformer))
380
381 (defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key as-list)
382 "Returns a vector containing, in order, all the octets that have
383 been output to the IN-MEMORY stream STREAM. This operation clears any
384 octets on STREAM, so the vector contains only those octets which have
385 been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
386 the creation of the stream, whichever occurred most recently. If
387 AS-LIST is true the return value is coerced to a list."
388 (declare #.*standard-optimize-settings*)
389 (with-accessors ((vector vector-stream-vector))
390 stream
391 (prog1
392 (if as-list
393 (coerce vector 'list)
394 vector)
395 (setq vector
396 (make-output-vector)))))
397
398 (defmethod output-stream-sequence-length ((stream in-memory-output-stream))
399 "Returns the current length of the underlying vector of the
400 IN-MEMORY output stream STREAM."
401 (declare (optimize speed))
402 (length (the vector (vector-stream-vector stream))))
403
404 (defmacro with-input-from-sequence ((var sequence &key start end transformer)
405 &body body)
406 "Creates an IN-MEMORY input stream from SEQUENCE using the
407 parameters START and END, binds VAR to this stream and then
408 executes the code in BODY. A function TRANSFORMER may optionally
409 be specified to transform the returned octets. The stream is
410 automatically closed on exit from WITH-INPUT-FROM-SEQUENCE, no
411 matter whether the exit is normal or abnormal. The return value
412 of this macro is the return value of BODY."
413 (with-rebinding (sequence)
414 `(let (,var)
415 (unwind-protect
416 (progn
417 (setq ,var (make-in-memory-input-stream ,sequence
418 :start (or ,start 0)
419 :end (or ,end (length ,sequence))
420 :transformer ,transformer))
421 ,@body)
422 (when ,var (close ,var))))))
423
424 (defmacro with-output-to-sequence ((var &key as-list (element-type ''octet) transformer)
425 &body body)
426 "Creates an IN-MEMORY output stream, binds VAR to this stream
427 and then executes the code in BODY. The stream stores data of
428 type ELEMENT-TYPE \(a subtype of OCTET) which is \(optionally)
429 transformed by the function TRANSFORMER prior to storage. The
430 stream is automatically closed on exit from
431 WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is normal or
432 abnormal. The return value of this macro is a vector \(or a list
433 if AS-LIST is true) containing the octets that were sent to the
434 stream within BODY."
435 `(let (,var)
436 (unwind-protect
437 (progn
438 (setq ,var (make-in-memory-output-stream :element-type ,element-type
439 :transformer ,transformer))
440 ,@body
441 (get-output-stream-sequence ,var :as-list ,as-list))
442 (when ,var (close ,var)))))