streams.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
---
streams.lisp (18470B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; streams.lisp --- Conversions between strings and UB8 vectors.
4 ;;;
5 ;;; Copyright (c) 2005-2007, Dr. Edmund Weitz. All rights reserved.
6 ;;; Copyright (c) 2008, Attila Lendvai. All rights reserved.
7 ;;;
8 ;;; Redistribution and use in source and binary forms, with or without
9 ;;; modification, are permitted provided that the following conditions
10 ;;; are met:
11 ;;;
12 ;;; * Redistributions of source code must retain the above copyright
13 ;;; notice, this list of conditions and the following disclaimer.
14 ;;;
15 ;;; * Redistributions in binary form must reproduce the above
16 ;;; copyright notice, this list of conditions and the following
17 ;;; disclaimer in the documentation and/or other materials
18 ;;; provided with the distribution.
19 ;;;
20 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
21 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
24 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
26 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
28 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32 ;;; STATUS
33 ;;;
34 ;;; - in-memory output streams support binary/bivalent/character
35 ;;; element-types and file-position
36
37 ;;; TODO
38 ;;;
39 ;;; - filter-stream types/mixins that can wrap a binary stream and
40 ;;; turn it into a bivalent/character stream
41 ;;; - in-memory input streams with file-position similar to in-memory
42 ;;; output streams
43 ;;; - in-memory input/output streams?
44
45 (in-package #:babel)
46
47 (defpackage #:babel-streams
48 (:use #:common-lisp #:babel #:trivial-gray-streams #:alexandria)
49 (:export
50 #:in-memory-stream
51 #:vector-output-stream
52 #:vector-input-stream
53 #:make-in-memory-output-stream
54 #:make-in-memory-input-stream
55 #:get-output-stream-sequence
56 #:with-output-to-sequence
57 #:with-input-from-sequence))
58
59 (in-package :babel-streams)
60
61 (declaim (inline check-if-open check-if-accepts-octets
62 check-if-accepts-characters stream-accepts-characters?
63 stream-accepts-octets? vector-extend
64 extend-vector-output-stream-buffer))
65
66 (defgeneric get-output-stream-sequence (stream &key &allow-other-keys))
67
68 ;;;; Some utilities (on top due to inlining)
69
70 (defun vector-extend (extension vector &key (start 0) (end (length extension)))
71 ;; copied over from cl-quasi-quote
72 (declare (optimize speed)
73 (type vector extension vector)
74 (type array-index start end))
75 (let* ((original-length (length vector))
76 (extension-length (- end start))
77 (new-length (+ original-length extension-length))
78 (original-dimension (array-dimension vector 0)))
79 (when (< original-dimension new-length)
80 (setf vector
81 (adjust-array vector (max (* 2 original-dimension) new-length))))
82 (setf (fill-pointer vector) new-length)
83 (replace vector extension :start1 original-length :start2 start :end2 end)
84 vector))
85
86 (defclass in-memory-stream (trivial-gray-stream-mixin)
87 ((element-type ; :default means bivalent
88 :initform :default :initarg :element-type :accessor element-type-of)
89 (%external-format
90 :initform (ensure-external-format *default-character-encoding*)
91 :initarg :%external-format :accessor external-format-of)
92 #+cmu
93 (open-p
94 :initform t :accessor in-memory-stream-open-p
95 :documentation "For CMUCL we have to keep track of this manually."))
96 (:documentation "An IN-MEMORY-STREAM is a binary stream that reads octets
97 from or writes octets to a sequence in RAM."))
98
99 (defmethod stream-element-type ((self in-memory-stream))
100 ;; stream-element-type is a CL symbol, we may not install an accessor on it.
101 ;; so, go through this extra step.
102 (element-type-of self))
103
104 (defun stream-accepts-octets? (stream)
105 (let ((element-type (element-type-of stream)))
106 (or (eq element-type :default)
107 (equal element-type '(unsigned-byte 8))
108 (subtypep element-type '(unsigned-byte 8)))))
109
110 (defun stream-accepts-characters? (stream)
111 (let ((element-type (element-type-of stream)))
112 (member element-type '(:default character base-char))))
113
114 (defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
115 ()
116 (:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that reads
117 octets from a sequence in RAM."))
118
119 #+cmu
120 (defmethod output-stream-p ((stream in-memory-input-stream))
121 "Explicitly states whether this is an output stream."
122 (declare (optimize speed))
123 nil)
124
125 (defclass in-memory-output-stream (in-memory-stream
126 fundamental-binary-output-stream)
127 ()
128 (:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
129 writes octets to a sequence in RAM."))
130
131 #+cmu
132 (defmethod input-stream-p ((stream in-memory-output-stream))
133 "Explicitly states whether this is an input stream."
134 (declare (optimize speed))
135 nil)
136
137 (defun make-in-memory-output-stream (&key (element-type :default)
138 external-format
139 initial-buffer-size)
140 "Returns a binary output stream which accepts objects of type
141 ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence that
142 contains the octes that were actually output."
143 (declare (optimize speed))
144 (unless external-format
145 (setf external-format *default-character-encoding*))
146 (when (eq element-type :bivalent)
147 (setf element-type :default))
148 (make-instance 'vector-output-stream
149 :vector (make-vector-stream-buffer
150 :element-type
151 (cond
152 ((or (eq element-type :default)
153 (equal element-type '(unsigned-byte 8)))
154 '(unsigned-byte 8))
155 ((eq element-type 'character)
156 'character)
157 ((subtypep element-type '(unsigned-byte 8))
158 '(unsigned-byte 8))
159 (t (error "Illegal element-type ~S" element-type)))
160 :initial-size initial-buffer-size)
161 :element-type element-type
162 :%external-format (ensure-external-format external-format)))
163
164 (defun make-in-memory-input-stream (data &key (element-type :default)
165 external-format)
166 "Returns a binary input stream which provides the elements of DATA when read."
167 (declare (optimize speed))
168 (unless external-format
169 (setf external-format *default-character-encoding*))
170 (when (eq element-type :bivalent)
171 (setf element-type :default))
172 (make-instance 'vector-input-stream
173 :vector data
174 :element-type element-type
175 :end (length data)
176 :%external-format (ensure-external-format external-format)))
177
178 (defclass vector-stream ()
179 ((vector
180 :initarg :vector :accessor vector-stream-vector
181 :documentation "The underlying vector of the stream which \(for output)
182 must always be adjustable and have a fill pointer.")
183 (index
184 :initform 0 :initarg :index :accessor vector-stream-index
185 :type (integer 0 #.array-dimension-limit)
186 :documentation "An index into the underlying vector denoting the
187 current position."))
188 (:documentation
189 "A VECTOR-STREAM is a mixin for IN-MEMORY streams where the underlying
190 sequence is a vector."))
191
192 (defclass vector-input-stream (vector-stream in-memory-input-stream)
193 ((end
194 :initarg :end :accessor vector-stream-end
195 :type (integer 0 #.array-dimension-limit)
196 :documentation "An index into the underlying vector denoting the end
197 of the available data."))
198 (:documentation "A binary input stream that gets its data from an
199 associated vector of octets."))
200
201 (defclass vector-output-stream (vector-stream in-memory-output-stream)
202 ()
203 (:documentation
204 "A binary output stream that writes its data to an associated vector."))
205
206 (define-condition in-memory-stream-error (stream-error)
207 ()
208 (:documentation "Superclass for all errors related to IN-MEMORY streams."))
209
210 (define-condition in-memory-stream-closed-error (in-memory-stream-error)
211 ()
212 (:report (lambda (condition stream)
213 (format stream "~S is closed."
214 (stream-error-stream condition))))
215 (:documentation "An error that is signalled when someone is trying to read
216 from or write to a closed IN-MEMORY stream."))
217
218 (define-condition wrong-element-type-stream-error (stream-error)
219 ((expected-type :accessor expected-type-of :initarg :expected-type))
220 (:report (lambda (condition output)
221 (let ((stream (stream-error-stream condition)))
222 (format output "The element-type of ~S is ~S while expecting ~
223 a stream that accepts ~S."
224 stream (element-type-of stream)
225 (expected-type-of condition))))))
226
227 (defun wrong-element-type-stream-error (stream expected-type)
228 (error 'wrong-element-type-stream-error
229 :stream stream :expected-type expected-type))
230
231 #+cmu
232 (defmethod open-stream-p ((stream in-memory-stream))
233 "Returns a true value if STREAM is open. See ANSI standard."
234 (declare (optimize speed))
235 (in-memory-stream-open-p stream))
236
237 #+cmu
238 (defmethod close ((stream in-memory-stream) &key abort)
239 "Closes the stream STREAM. See ANSI standard."
240 (declare (ignore abort) (optimize speed))
241 (prog1
242 (in-memory-stream-open-p stream)
243 (setf (in-memory-stream-open-p stream) nil)))
244
245 (defun check-if-open (stream)
246 "Checks if STREAM is open and signals an error otherwise."
247 (declare (optimize speed))
248 (unless (open-stream-p stream)
249 (error 'in-memory-stream-closed-error :stream stream)))
250
251 (defun check-if-accepts-octets (stream)
252 (declare (optimize speed))
253 (unless (stream-accepts-octets? stream)
254 (wrong-element-type-stream-error stream '(unsigned-byte 8))))
255
256 (defun check-if-accepts-characters (stream)
257 (declare (optimize speed))
258 (unless (stream-accepts-characters? stream)
259 (wrong-element-type-stream-error stream 'character)))
260
261 (defmethod stream-read-byte ((stream vector-input-stream))
262 "Reads one byte and increments INDEX pointer unless we're beyond END pointer."
263 (declare (optimize speed))
264 (check-if-open stream)
265 (let ((index (vector-stream-index stream)))
266 (cond ((< index (vector-stream-end stream))
267 (incf (vector-stream-index stream))
268 (aref (vector-stream-vector stream) index))
269 (t :eof))))
270
271 #+#:ignore
272 (defmethod stream-read-char ((stream vector-input-stream))
273 ;; TODO
274 )
275
276 (defmethod stream-listen ((stream vector-input-stream))
277 "Checking whether INDEX is beyond END."
278 (declare (optimize speed))
279 (check-if-open stream)
280 (< (vector-stream-index stream) (vector-stream-end stream)))
281
282 (defmethod stream-read-sequence ((stream vector-input-stream)
283 sequence start end &key)
284 (declare (optimize speed) (type array-index start end))
285 ;; TODO check the sequence type, assert for the element-type and use
286 ;; the external-format.
287 (loop with vector-end of-type array-index = (vector-stream-end stream)
288 with vector = (vector-stream-vector stream)
289 for index from start below end
290 for vector-index of-type array-index = (vector-stream-index stream)
291 while (< vector-index vector-end)
292 do (setf (elt sequence index)
293 (aref vector vector-index))
294 (incf (vector-stream-index stream))
295 finally (return index)))
296
297 (defmethod stream-write-byte ((stream vector-output-stream) byte)
298 "Writes a byte \(octet) by extending the underlying vector."
299 (declare (optimize speed))
300 (check-if-open stream)
301 (check-if-accepts-octets stream)
302 (vector-push-extend byte (vector-stream-vector stream))
303 (incf (vector-stream-index stream))
304 byte)
305
306 (defun extend-vector-output-stream-buffer (extension stream &key (start 0)
307 (end (length extension)))
308 (declare (optimize speed)
309 (type array-index start end)
310 (type vector extension))
311 (vector-extend extension (vector-stream-vector stream) :start start :end end)
312 (incf (vector-stream-index stream) (- end start))
313 (values))
314
315 (defmethod stream-write-char ((stream vector-output-stream) char)
316 (declare (optimize speed))
317 (check-if-open stream)
318 (if (eq (element-type-of stream) 'character)
319 (vector-push-extend char (vector-stream-vector stream))
320 (let ((octets (string-to-octets (string char)
321 :encoding (external-format-of stream))))
322 (extend-vector-output-stream-buffer octets stream)))
323 char)
324
325 (defmethod stream-write-sequence ((stream vector-output-stream)
326 sequence start end &key)
327 "Just calls VECTOR-PUSH-EXTEND repeatedly."
328 (declare (optimize speed)
329 (type array-index start end))
330 (etypecase sequence
331 (string
332 (if (stream-accepts-octets? stream)
333 ;; TODO this is naiive here, there's room for optimization
334 (let ((octets (string-to-octets sequence
335 :encoding (external-format-of stream)
336 :start start
337 :end end)))
338 (extend-vector-output-stream-buffer octets stream))
339 (progn
340 (assert (stream-accepts-characters? stream))
341 (extend-vector-output-stream-buffer sequence stream
342 :start start :end end))))
343 ((vector (unsigned-byte 8))
344 ;; specialized branch to help inlining
345 (check-if-accepts-octets stream)
346 (extend-vector-output-stream-buffer sequence stream :start start :end end))
347 (vector
348 (check-if-accepts-octets stream)
349 (extend-vector-output-stream-buffer sequence stream :start start :end end)))
350 sequence)
351
352 (defmethod stream-write-string ((stream vector-output-stream)
353 string &optional (start 0) (end (length string)))
354 (stream-write-sequence stream string start (or end (length string))))
355
356 (defmethod stream-line-column ((stream vector-output-stream))
357 "Dummy line-column method that always returns NIL. Needed for
358 character output streams."
359 nil)
360
361 (defmethod stream-file-position ((stream vector-stream))
362 "Simply returns the index into the underlying vector."
363 (declare (optimize speed))
364 (vector-stream-index stream))
365
366 (defun make-vector-stream-buffer (&key (element-type '(unsigned-byte 8))
367 initial-size)
368 "Creates and returns an array which can be used as the underlying vector
369 for a VECTOR-OUTPUT-STREAM."
370 (declare (optimize speed)
371 (type (or null array-index) initial-size))
372 (make-array (the array-index (or initial-size 32))
373 :adjustable t
374 :fill-pointer 0
375 :element-type element-type))
376
377 (defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key (return-as 'vector))
378 "Returns a vector containing, in order, all the octets that have
379 been output to the IN-MEMORY stream STREAM. This operation clears any
380 octets on STREAM, so the vector contains only those octets which have
381 been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
382 the creation of the stream, whichever occurred most recently. If
383 AS-LIST is true the return value is coerced to a list."
384 (declare (optimize speed))
385 (let ((vector (vector-stream-vector stream)))
386 (prog1
387 (ecase return-as
388 (vector vector)
389 (string (octets-to-string vector :encoding (external-format-of stream)))
390 (list (coerce vector 'list)))
391 (setf (vector-stream-vector stream)
392 (make-vector-stream-buffer :element-type (element-type-of stream))))))
393
394 (defmacro with-output-to-sequence
395 ((var &key (return-as ''vector) (element-type '':default)
396 (external-format '*default-character-encoding*) initial-buffer-size)
397 &body body)
398 "Creates an IN-MEMORY output stream, binds VAR to this stream and
399 then executes the code in BODY. The stream stores data of type
400 ELEMENT-TYPE \(a subtype of OCTET). The stream is automatically closed
401 on exit from WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is
402 normal or abnormal. The return value of this macro is a vector \(or a
403 list if AS-LIST is true) containing the octets that were sent to the
404 stream within BODY."
405 (multiple-value-bind (body declarations) (parse-body body)
406 ;; this is here to stop SBCL complaining about binding them to NIL
407 `(let ((,var (make-in-memory-output-stream
408 :element-type ,element-type
409 :external-format ,external-format
410 :initial-buffer-size ,initial-buffer-size)))
411 ,@declarations
412 (unwind-protect
413 (progn
414 ,@body
415 (get-output-stream-sequence ,var :return-as ,return-as))
416 (close ,var)))))
417
418 (defmacro with-input-from-sequence
419 ((var data &key (element-type '':default)
420 (external-format '*default-character-encoding*))
421 &body body)
422 "Creates an IN-MEMORY input stream that will return the values
423 available in DATA, binds VAR to this stream and then executes the code
424 in BODY. The stream stores data of type ELEMENT-TYPE \(a subtype of
425 OCTET). The stream is automatically closed on exit from
426 WITH-INPUT-FROM-SEQUENCE, no matter whether the exit is normal or
427 abnormal. The return value of this macro is the return value of BODY."
428 (multiple-value-bind (body declarations) (parse-body body)
429 ;; this is here to stop SBCL complaining about binding them to NIL
430 `(let ((,var (make-in-memory-input-stream
431 ,data :element-type ,element-type
432 :external-format ,external-format)))
433 ,@declarations
434 (unwind-protect
435 (progn
436 ,@body)
437 (close ,var)))))