streams.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 exten… | |
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-lengt… | |
82 (setf (fill-pointer vector) new-length) | |
83 (replace vector extension :start1 original-length :start2 start :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 oct… | |
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 … | |
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-in… | |
115 () | |
116 (:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that rea… | |
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-… | |
160 :initial-size initial-buffer-size) | |
161 :element-type element-type | |
162 :%external-format (ensure-external-format external-form… | |
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 whe… | |
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-form… | |
177 | |
178 (defclass vector-stream () | |
179 ((vector | |
180 :initarg :vector :accessor vector-stream-vector | |
181 :documentation "The underlying vector of the stream which \(for outp… | |
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 stream… | |
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 … | |
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 expect… | |
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 p… | |
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 stre… | |
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 … | |
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 :e… | |
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 stre… | |
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 s… | |
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 :e… | |
347 (vector | |
348 (check-if-accepts-octets stream) | |
349 (extend-vector-output-stream-buffer sequence stream :start start :e… | |
350 sequence) | |
351 | |
352 (defmethod stream-write-string ((stream vector-output-stream) | |
353 string &optional (start 0) (end (length … | |
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 vect… | |
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) … | |
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… | |
390 (list (coerce vector 'list))) | |
391 (setf (vector-stream-vector stream) | |
392 (make-vector-stream-buffer :element-type (element-type-of st… | |
393 | |
394 (defmacro with-output-to-sequence | |
395 ((var &key (return-as ''vector) (element-type '':default) | |
396 (external-format '*default-character-encoding*) initial-buffer… | |
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))))) |