GopherProxy

	tin-memory.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tin-memory.lisp (19043B)
	---
	1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 1…
	2 ;;; $Header: /usr/local/cvsrep/flexi-streams/in-memory.lisp,v 1.31 2008/…
	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-in…
	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-o…
	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 …
	137 actually removing it. If PEEK-TYPE is NIL the next byte is returned, …
	138 PEEK-TYPE is T, the next byte which is not 0 is returned, if PEEK-TYP…
	139 byte, the next byte which equals PEEK-TYPE is returned. EOF-ERROR-P a…
	140 EOF-VALUE are interpreted as usual."))
	141
	142 (defmethod peek-byte ((stream vector-input-stream) &optional peek-type (…
	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 (eo…
	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…
	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 sta…
	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 s…
	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…
	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 i…
	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-inp…
	271 "Sets the index into the underlying vector if POSITION-SPEC is accepta…
	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:…
	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 ou…
	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-out…
	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 …
	315 total-size)
	316 (otherwise
	317 (unless (integerp position-spec)
	318 (error 'in-memory-stream-position-spec-error
	319 :format-control "Unknown file position designato…
	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 …
	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 (lengt…
	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 li…
	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) transfor…
	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) …
	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-strea…
	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 transfo…
	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 (leng…
	420 :transformer ,trans…
	421 ,@body)
	422 (when ,var (close ,var))))))
	423
	424 (defmacro with-output-to-sequence ((var &key as-list (element-type ''oct…
	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 ,eleme…
	439 :transformer ,transf…
	440 ,@body
	441 (get-output-stream-sequence ,var :as-list ,as-list))
	442 (when ,var (close ,var)))))