tstreams.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP HTML git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ DIR Log DIR Files DIR Refs DIR Tags DIR LICENSE --- tstreams.lisp (18456B) --- 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 (check-if-accepts-characters stream) 319 ;; TODO this is naiive here, there's room for optimization 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 (prog1 386 (ecase return-as 387 (vector (vector-stream-vector stream)) 388 (string (octets-to-string (vector-stream-vector stream) 389 :encoding (external-format-of stream))) 390 (list (coerce (vector-stream-vector stream) 'list))) 391 (setf (vector-stream-vector stream) (make-vector-stream-buffer)))) 392 393 (defmacro with-output-to-sequence 394 ((var &key (return-as ''vector) (element-type '':default) 395 (external-format '*default-character-encoding*) initial-buffer-size) 396 &body body) 397 "Creates an IN-MEMORY output stream, binds VAR to this stream and 398 then executes the code in BODY. The stream stores data of type 399 ELEMENT-TYPE \(a subtype of OCTET). The stream is automatically closed 400 on exit from WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is 401 normal or abnormal. The return value of this macro is a vector \(or a 402 list if AS-LIST is true) containing the octets that were sent to the 403 stream within BODY." 404 (multiple-value-bind (body declarations) (parse-body body) 405 ;; this is here to stop SBCL complaining about binding them to NIL 406 `(let ((,var (make-in-memory-output-stream 407 :element-type ,element-type 408 :external-format ,external-format 409 :initial-buffer-size ,initial-buffer-size))) 410 ,@declarations 411 (unwind-protect 412 (progn 413 ,@body 414 (get-output-stream-sequence ,var :return-as ,return-as)) 415 (close ,var))))) 416 417 (defmacro with-input-from-sequence 418 ((var data &key (element-type '':default) 419 (external-format '*default-character-encoding*)) 420 &body body) 421 "Creates an IN-MEMORY input stream that will return the values 422 available in DATA, binds VAR to this stream and then executes the code 423 in BODY. The stream stores data of type ELEMENT-TYPE \(a subtype of 424 OCTET). The stream is automatically closed on exit from 425 WITH-INPUT-FROM-SEQUENCE, no matter whether the exit is normal or 426 abnormal. The return value of this macro is the return value of BODY." 427 (multiple-value-bind (body declarations) (parse-body body) 428 ;; this is here to stop SBCL complaining about binding them to NIL 429 `(let ((,var (make-in-memory-input-stream 430 ,data :element-type ,element-type 431 :external-format ,external-format))) 432 ,@declarations 433 (unwind-protect 434 (progn 435 ,@body) 436 (close ,var)))))