/
unicly-io.lisp
209 lines (186 loc) · 8.86 KB
/
unicly-io.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
;;; :FILE-CREATED <Timestamp: #{2011-08-18T21:12:14-04:00Z}#{11334} - by MON>
;;; :FILE unicly/unicly-io.lisp
;;; ==============================
(in-package #:unicly)
;; *package*
(declaim (inline uuid-valid-stream-p))
(defun uuid-valid-stream-p (maybe-stream)
(declare (optimize (speed 3)))
(if (and (streamp maybe-stream)
(open-stream-p (the stream maybe-stream)))
(values t (the stream maybe-stream))
(values nil maybe-stream)))
(defun uuid-valid-stream-verify-io-type (maybe-valid-io-stream &key direction)
(declare ((member :input :output) direction)
(inline uuid-valid-stream-p)
(optimize (speed 3)))
(multiple-value-bind (chk stream-val) (uuid-valid-stream-p maybe-valid-io-stream)
(declare (boolean chk))
(unless (if (eql direction :output)
(and chk (output-stream-p (the stream stream-val)))
(and chk (input-stream-p (the stream stream-val))))
(error ":FUNCTION `UUID-VALID-STREAM-VERIFY-IO-TYPE' ~
-- arg IN-STREAM failed check for either `uuid-valid-stream-p' or `cl:~(~A~)-stream-p'~%~T~
got-val: ~S~%~Ttype-of: ~S~%"
direction stream-val (type-of stream-val))))
(the stream maybe-valid-io-stream))
(defun uuid-valid-stream-verify-for-output (out-stream)
(declare (optimize (speed 3)))
(the (values stream &optional)
(uuid-valid-stream-verify-io-type out-stream :direction :output)))
(defun uuid-valid-stream-verify-for-input (in-stream)
(declare (optimize (speed 3)))
(the (values stream &optional)
(uuid-valid-stream-verify-io-type in-stream :direction :input)))
;; :EXAMPLE
;; (let ((os (make-string-output-stream)))
;; (uuid-valid-stream-verify-octet-stream-for-output os))
;;
;; (let ((is (make-string-input-stream "bubba")))
;; (uuid-valid-stream-verify-octet-stream-for-input is))
(defun uuid-valid-stream-verify-io-octet-type (maybe-octet-stream &key direction)
(declare ((member :input :output) direction))
(let* ((chk-stream
(ecase direction
(:output (uuid-valid-stream-verify-for-output maybe-octet-stream))
(:input (uuid-valid-stream-verify-for-input maybe-octet-stream))))
(elt-type (stream-element-type (the stream chk-stream))))
(multiple-value-bind (t1 t2) (subtypep elt-type 'uuid-ub8)
(declare (boolean t1 t2))
(unless (and t1 t2)
(error "UUID-VALID-STREAM-VERIFY-IO-OCTET-TYPE -- arg MAYBE-OCTET-STREAM ~
has `cl:stream-element-type' not `cl:subtypep' of `uuid-ub8'~%~Twith-stream: ~S~%~Twith-type: ~S~%"
chk-stream elt-type))))
(the stream maybe-octet-stream))
(defun uuid-valid-stream-verify-octet-stream-for-output (maybe-output-octet-stream)
(uuid-valid-stream-verify-io-octet-type maybe-output-octet-stream :direction :output))
(defun uuid-valid-stream-verify-octet-stream-for-input (maybe-input-octet-stream)
(uuid-valid-stream-verify-io-octet-type maybe-input-octet-stream :direction :input))
;;; ==============================
;; :NOTE Following idiom does not suitably catch EOF.
;; (defun uuid-deserialize-byte-array-bytes (stream-in)
;; (uuid-valid-stream-verify-octet-stream-for-input stream-in)
;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
;; (read-sequence bv-return stream :start 0 :end 127)
;; bv-return))
;;
(defun uuid-deserialize-byte-array-bytes (stream-in)
(uuid-valid-stream-verify-octet-stream-for-input stream-in)
(loop
with ba16 = (uuid-byte-array-16-zeroed)
for ba16-idx from 0 below 16
for byte-read = (read-byte stream-in nil 'EOF)
if (eql byte-read 'EOF)
do (error 'end-of-file :stream stream-in)
end
;; unless (typep byte-read 'bit) ;; catches new line just prior to EOF...
;; do (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
;; byte-read (type-of byte-read))
do (setf (aref ba16 ba16-idx) byte-read)
finally (return ba16)))
;;; ==============================
;; :TODO `deserialize-uuid'...
;; :NOTE Should there be a generic function which dispatches on the UUID's
;; representation , e.g. uuid-bit-vector-128, uuid-byte-array-20array-16,
;; unique-universal-identifier, uuid-string-32, uuid-string-36?
;; :NOTE Consider renaming this to `serialize-uuid-byte-array' and calling the
;; G-F in body.
(defun uuid-serialize-byte-array-bytes (uuid-or-byte-array-16 stream-out)
(declare ((or uuid-byte-array-16 unique-universal-identifier) uuid-or-byte-array-16)
(type stream stream-out)
(optimize (speed 3)))
(uuid-valid-stream-verify-octet-stream-for-output stream-out)
(let ((ba16
(the uuid-byte-array-16
(if (uuid-byte-array-16-p uuid-or-byte-array-16)
uuid-or-byte-array-16
(uuid-get-namespace-bytes uuid-or-byte-array-16)))))
(declare (uuid-byte-array-16 ba16))
;; (loop
;; for byte-idx from 0 below 16
;; do (write-byte (aref ba16 byte-idx) stream))
(write-sequence ba16 stream-out :start 0 :end 16)))
;;; ==============================
;; :TODO Should peek at stream to test if we are at end of file
;; (error 'end-of-file :stream stream)
;; Should check if there are pututatively enough bytes remaining in stream with:
;; (>= (- file-length file-position) 128)
;; This won't be 100% reliable but will at least let us bail early for trivial cases.
;;
;; :NOTE Following idiom with `cl:read-sequence' does not suitably catch EOF.
;; (defun uuid-deserialize-bit-vector-bits (stream-in)
;; (let ((bv-return (uuid-bit-vector-128-zeroed)))
;; (read-sequence bv-return stream-in :start 0 :end 127)
;; bv-return))
;;
;; :NOTE Following is the equivalent using `cl:do' instead of `cl:loop'
;; (defun uuid-deserialize-bit-vector-bits (stream-in)
;; (uuid-valid-stream-verify-octet-stream-for-input stream-in)
;; (let ((bv (uuid-bit-vector-128-zeroed)))
;; (do ((code (read-byte s nil 'EOF) (read-byte s nil 'EOF))
;; (cnt 0 (1+ cnt)))
;; ((if (or (eql code 'EOF) (> cnt 128 ))
;; t
;; (unless (typep code 'bit)
;; (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
;; code (type-of code))))
;; (if (= cnt 128)
;; (uuid-bit-vector-eql w-uuid-bv bv)
;; ;; (values nil (cons code cnt))))
;; (error 'end-of-file :stream stream-in)))
;; (setf (sbit bv cnt) code))))
;;
(defun uuid-deserialize-bit-vector-bits (stream-in)
(uuid-valid-stream-verify-octet-stream-for-input stream-in)
(loop
with bv = (uuid-bit-vector-128-zeroed)
for cnt from 0 below 128
for byte-read = (read-byte stream-in nil 'EOF)
if (eql byte-read 'EOF)
do (error 'end-of-file :stream stream-in)
end
unless (typep byte-read 'bit) ;; catches new line just prior to EOF...
do (error "UUID-DESERIALIZE-BIT-VECTOR-BITS -- CL:READ-BYTE read object not of type CL:BIT~%~Tgot: ~S~%~Ttype-of: ~S~%"
byte-read (type-of byte-read))
do (setf (sbit bv cnt) byte-read)
finally (return bv)))
(defun uuid-serialize-bit-vector-bits (bv-or-uuid stream-out)
(declare ((or uuid-bit-vector-128 unique-universal-identifier) bv-or-uuid)
(type stream stream-out))
(uuid-valid-stream-verify-octet-stream-for-output stream-out)
(let ((bv-128 (the uuid-bit-vector-128
(if (unique-universal-identifier-p bv-or-uuid)
(uuid-to-bit-vector bv-or-uuid)
bv-or-uuid))))
(declare (uuid-bit-vector-128 bv-128))
;; (loop
;; ;; for bit-idx downfrom 127 to 0
;; for bit-idx from 0 below 128
;; do (write-byte (sbit bv-128 bit-idx) stream-out))
(write-sequence bv-128 stream-out :start 0 :end 128)))
;; (fundoc 'uuid-read-bit-vector-bits
;; Read the bits of a UUID's bit-vector representation from INPUT-PATHNAME return
;; an object of type `uuid-bit-vector-128'.
;; INPUT-PATHNAME names an existing file with element-type `uuid-ub8'.
;; :EXAMPLE
;; (let* ((tmp (make-pathname :directory '(:absolute "tmp")
;; :name "bitstream-test"))
;; (v4 (uuid-to-bit-vector (make-v4-uuid)))
;; (v4-io (uuid-read-bit-vector-bits (uuid-write-bit-vector-bits v4 tmp))))
;; (uuid-bit-vector-eql v4 v4-io))
(defun uuid-read-bit-vector-bits (input-pathname &key (if-does-not-exist :error))
(declare ((or pathname string) input-pathname))
(with-open-file (bv-in input-pathname
:direction :input
:if-does-not-exist if-does-not-exist
:element-type 'uuid-ub8)
(uuid-deserialize-bit-vector-bits bv-in)))
;;; ==============================
;; Local Variables:
;; indent-tabs-mode: nil
;; show-trailing-whitespace: t
;; mode: lisp-interaction
;; package: unicly
;; End:
;;; ==============================
;;; EOF