-
Notifications
You must be signed in to change notification settings - Fork 0
/
unicly-deprecated.lisp
425 lines (389 loc) · 18.2 KB
/
unicly-deprecated.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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
;;; :FILE-CREATED <Timestamp: #{2011-04-14T12:24:46-04:00Z}#{11154} - by MON>
;;; :FILE unicly/unicly-deprecated.lisp
;;; ==============================
;;; ==============================
;;; :NOTE This file is contained of definitions for two searate classes of symbols:
;; - Those from the original UUID library which are either not being used by
;; unicly or which are found to be suboptimal for use with unicly.
;; - Those from the development of unicly which are mis-attempts, are
;; superseded by a generic/method combination or which are otherwise
;; suboptimal and/or non-functional
;;; ==============================
(in-package #:unicly)
;;; ==============================
;;; :DEPRECATED
;;; ==============================
#+(or)
(defmacro uuid-get-bytes-for-integer (unsigned-integer)
;; (macroexpand-1 '(uuid-get-bytes-for-integer 281474976710655))
(declare (optimize (speed 3)))
`(etypecase (integer-length ,unsigned-integer)
,@(loop
for cnt upfrom 1 below 7
for x upfrom 0 below 48 by 8
for low = 0 then (case x
(24 17) ; Skip returning 3 octet value 17-24, bump to 4
(40 33) ; Skip returning 5 octet value 33-40, bump to 6
(t (+ x 1)))
for high = 8 then (+ x 8)
unless (and (oddp cnt) (> cnt 1))
collect (list (list 'integer low high) cnt))))
#+(or)
(defun uuid-to-byte-array (uuid)
;; :NOTE `uuid-get-namespace-bytes' and `uuid-to-byte-array' are essentially the same.
(declare (unique-universal-identifier uuid)
(optimize (speed 3)))
(let ((array (make-array 16 :element-type 'uuid-ub8)))
(declare (uuid-byte-array-16 array))
(with-slots (%uuid_time-low %uuid_time-mid %uuid_time-high-and-version
%uuid_clock-seq-and-reserved %uuid_clock-seq-low %uuid_node)
uuid
(declare (type uuid-ub32 %uuid_time-low)
(type uuid-ub16 %uuid_time-mid %uuid_time-high-and-version)
(type uuid-ub8 %uuid_clock-seq-and-reserved %uuid_clock-seq-low)
(type uuid-ub48 %uuid_node))
(loop
for i from 3 downto 0
do (setf (aref array (- 3 i)) (ldb (byte 8 (* 8 i)) %uuid_time-low)))
(loop
for i from 5 downto 4
do (setf (aref array i) (ldb (byte 8 (* 8 (- 5 i))) %uuid_time-mid)))
(loop
for i from 7 downto 6
do (setf (aref array i) (ldb (byte 8 (* 8 (- 7 i))) %uuid_time-high-and-version)))
(setf (aref array 8) (ldb (byte 8 0) %uuid_clock-seq-and-reserved))
(setf (aref array 9) (ldb (byte 8 0) %uuid_clock-seq-low))
(loop
for i from 15 downto 10
do (setf (aref array i) (ldb (byte 8 (* 8 (- 15 i))) %uuid_node)))
(the uuid-byte-array-16 array))))
#+(or)
(deftype uuid-integer-length ()
;; expands to: (or (integer 1 2) (integer 4 4) (integer 6 6))
'(member 1 2 4 6))
#+(or)
(defun uuid-number-to-byte-array (num &optional size)
;; :EXAMPLE
;; (uuid-number-to-byte-array 825973027016)
;; => #(200 48 212 79 192 0), 6
;;
;; (slot-value *uuid-namespace-dns* '%uuid_node) ;=> 825973027016
;; (logand 825973027016 255) ;=> 200
;; (logand (ash 825973027016 -8) 255) ;=> 48
;; (logand (ash 3226457136 -8) 255) ;=> 212
;; (logand (ash 12603348 -8) 255) ;=> 79
;; (logand (ash 49231 -8) 255) ;=> 192
;; (ash 192 -8) ;=> 0
(declare ((integer 0 *) num)
((or null uuid-integer-length) size))
;; :NOTE This SIZE slot is required b/c for approx. ~1/100 of
;; every UUIDs generated the %UUID_TIME-MID slot is 0!
;; We used to short circuit early when NUM was `cl:zerop' and simply bail
;; returning the `cl:values': => #(0), 1
;; However, this was _bad_ b/c a %UUID_TIME-MID must be of length 2 e.g.:
;; => #(0 0), 2
;; This in turn has later consequences b/c we lost our padding and corrupted
;; the valid length of genenerated uuid-byte-arrays of type `uuid-byte-array-16'.
(if (zerop num)
(values (make-array 1 :element-type 'uuid-ub8 :initial-element 0) 1)
(let* ((type-cnt (or size (uuid-get-bytes-for-integer num)))
(byte-arr (make-array type-cnt :element-type 'uuid-ub8 :initial-element 0)))
(declare ((mod 7) type-cnt)
((integer 1 *) num)
((simple-array (unsigned-byte 8) (*)) byte-arr))
(loop
for val = num then (ash val -8)
for count downfrom (1- type-cnt) downto 0
do (setf (aref byte-arr count) (logand val #XFF))
finally (return (values byte-arr type-cnt))))))
#+(or)
(defun uuid-load-bytes (byte-array &key (byte-size 8) (start 0) end)
(declare (type uuid-byte-array byte-array)
(optimize (speed 3)))
(let ((ret-val 0))
(loop
for i from start to end
for pos from (- end start) downto 0
do (setf ret-val (dpb (aref byte-array i) (byte byte-size (* pos byte-size)) ret-val)))
ret-val))
#+(or)
(declaim (inline %uuid-get-bytes-if))
#+(or)
(defun %uuid-get-bytes-if (chk-uuid-str)
(or (and (uuid-hex-string-32-p chk-uuid-str)
(the uuid-string-32 chk-uuid-str))
#-mon (error "Arg CHK-UUID-STR not `uuid-hex-string-32-p'~% ~
got: ~S~% ~
type-of: ~S~%" chk-uuid-str (type-of chk-uuid-str))
#+mon (mon:simple-error-mon :w-sym '%uuid-get-bytes-if
:w-type 'function
:w-spec "arg CHK-UUID-STR not `uuid-hex-string-32-p'"
:w-got chk-uuid-str
:w-type-of t
:signal-or-only nil)))
#+(or)
(defun uuid-get-bytes (uuid-string)
(declare (optimize (speed 3) (debug 0))
(inline %uuid-get-bytes-if))
(let ((uuid-str-if (%uuid-get-bytes-if uuid-string))
(outstr (make-array 16 :element-type 'character :initial-element #\NUL :fill-pointer 0)))
(declare (uuid-string-32 uuid-str-if)
((and (vector character 16) (not simple-array)) outstr))
(with-output-to-string (out outstr)
(loop
with max = (- (length uuid-str-if) 2)
for i = 0 then (+ i 2)
as j = (+ i 2)
as cur-pos = (the uuid-ub8 (parse-integer (subseq uuid-str-if i j) :radix 16))
do (format out "~A" (code-char (the uuid-ub8 cur-pos)))
while (< i max))
(the uuid-byte-string (make-array 16 :element-type 'character :initial-contents outstr)))))
#+(or)
(defun uuid-digest-uuid-string (digest-version string-uuid name)
;; This is step two of RFC4122 section 4.3
;; - Compute the hash of the name space ID concatenated with the name.
(declare ((mod 6) digest-version)
(type string name string-uuid))
(let ((digester (ironclad:make-digest (%verify-digest-version digest-version))))
;; :NOTE `mon:ascii-string-to-byte-array'
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array string-uuid))
(ironclad:update-digest digester
;; #-sbcl (trivial-utf-8:string-to-utf-8-bytes name))
;; :NOTE sb-ext:string-to-octets is approx 11x
;; faster and conses 75% less than flexi-streams:string-to-octets
#-(or :sbcl :sb-unicode) (the uuid-byte-array (flexi-streams:string-to-octets name :external-format :UTF-8))
#+:sbcl (the uuid-byte-array (sb-ext:string-to-octets name :external-format :UTF-8)))
(the (values uuid-byte-array &optional) (ironclad:produce-digest digester))))
;;; ==============================
;;; :NOTE Everything below here is deprecated, including `uuid-digest-uuid-string'.
;;; ==============================
;;; ==============================
;;; SUPERSEDED-SLOW-OR-BUGGY
;;; ==============================
;;; ==============================
;; (defun make-uuid-from-string (uuid-or-hex-string-36)
;; (declare ((or unique-universal-identifier string) uuid-or-hex-string-36))
;; (let ((chk-uuid-str (typecase uuid-or-hex-string-36
;; (unique-universal-identifier
;; (return-from make-uuid-from-string (uuid-copy-uuid uuid-or-hex-string-36)))
;; (string (make-uuid-from-string-if uuid-or-hex-string-36)))))
;; (declare (uuid-string-36 chk-uuid-str)
;; (optimize (speed 3)))
;; (make-instance 'unique-universal-identifier
;; :%uuid_time-low
;; (the uuid-ub32 (parse-integer chk-uuid-str :start 0 :end 8 :radix 16))
;; :%uuid_time-mid
;; (the uuid-ub16 (parse-integer chk-uuid-str :start 9 :end 13 :radix 16))
;; :%uuid_time-high-and-version
;; (the uuid-ub16 (parse-integer chk-uuid-str :start 14 :end 18 :radix 16))
;; :%uuid_clock-seq-and-reserved
;; (the uuid-ub8 (parse-integer chk-uuid-str :start 19 :end 21 :radix 16))
;; :%uuid_clock-seq-low
;; (the uuid-ub8 (parse-integer chk-uuid-str :start 21 :end 23 :radix 16))
;; :%uuid_node
;; (the uuid-ub48 (parse-integer chk-uuid-str :start 24 :end 36 :radix 16)))))
;;
;;; ==============================
;;; ==============================
;; (declaim (inline uuid-disassemble-ub48))
;; (defun uuid-disassemble-ub48 (u48)
;; (declare (type uuid-ub48 u48)
;; (optimize (speed 3)))
;; (let ((b1 (ldb (byte 8 40) u48))
;; (b2 (ldb (byte 8 32) u48))
;; (b3 (ldb (byte 8 24) u48))
;; (b4 (ldb (byte 8 16) u48))
;; (b5 (ldb (byte 8 8) u48))
;; (b6 (ldb (byte 8 0) u48)))
;; (declare (type uuid-ub8 b1 b1 b2 b3 b4 b5 b6))
;; (values b1 b2 b3 b4 b5 b6)))
;;; ==============================
;;; ==============================
;; (defun uuid-number-to-byte-array (num)
;; (declare ((integer 0 *) num))
;; (if (zerop num)
;; (values (make-array 1 :element-type 'uuid-ub8 :initial-contents (list 0)) 1)
;; (loop
;; :with type-cnt = (uuid-get-bytes-for-integer num)
;; :for val = num :then (ash val -8)
;; :for count :from 0 below type-cnt
;; ;; Knock down all 1 bits above 255 to 0 ;; #XFF -> 255
;; :collect (logand val #XFF) :into bits
;; :finally (return (values (make-array count
;; :element-type 'uuid-ub8
;; :initial-contents (nreverse bits))
;; count)))))
;;; ==============================
;;; ==============================
;; :NOTE Now a generic-function/method specialized on `unique-universal-identifier'
;; (defun uuid-princ-to-string (uuid-instance)
;; (declare (unique-universal-identifier uuid-instance))
;; #-sbcl (assert (typep uuid-instance 'unique-universal-identifier)
;; (uuid-instance)
;; "Arg UUID-INSTANCE does not satisfy `unique-universal-identifier-p'")
;; (princ-to-string uuid-instance))
;;; ==============================
;;; ==============================
;; Doesn't work
;; (defun %BUGGY-make-uuid-namespace-loadtime-vars (namespace-pairs)
;; (loop
;; :for (nm . id-string) namespace-pairs
;; :when (uuid-hex-string-36-p id-string)
;; :do (setf nm (make-uuid-from-string id-string))))
;;; ==============================
;;; ==============================
;; (fundoc 'make-uuid-namespace-loadtime-vars
;; "Set values of NAMESPACE-PAIRS to UUIDs at loadtime.~%~@
;; NAMESPACE-PAIRS is a list of conses each of the form:~%
;; \( <SYMBOL> . <UUID-HEX-STRING-36> \)~%~@
;; <SYMBOL> should be a variable or parameter in the current environment.~%~@
;; <UUID-HEX-STRING-36> should satisfy `dbc:uuid-hex-string-36-p'.~%~@
;; Value is set as if by `dbc:make-uuid-from-string'.~%~@
;; :EXAMPLE~%~@
;; { ... <EXAMPLE> ... } ~%~@
;; :SEE-ALSO `<XREF>'.~%")
;;; ==============================
;;; ==============================
;; :NOTE unique-universal-identifier-p is now a generic-function.
;; (fundoc 'unique-universal-identifier-p
;; "Whether MAYBE-UUID-INSTANCE is a unique-universal-identifier.
;; Return T when argument is an instace of the class
;; `unique-universal-identifier' or one of its subclasses.~%~@
;; :EXAMPLE~%
;; \(unique-universal-identifier-p *uuid-namespace-dns*\)
;; \(unique-universal-identifier-p t\)~%~@
;; :SEE-ALSO `<XREF>'.~%")
;;; ==============================
;;; ==============================
;; (fundoc 'uuid-princ-to-string
;; "Return string representation fo UUID-INSTANCE as if by `cl:princ-to-string'.~%~@
;; UUID-INSTANCE should satisfy `unique-universal-identifier-p', an error is
;; signaled if not~%~@
;; :EXAMPLE~%~@
;; \(uuid-princ-to-string *uuid-namespace-dns*\)
;; \(uuid-princ-to-string t\)
;; :SEE-ALSO `<XREF>'.~%")
;;; ==============================
;;; ==============================
;; Now a generic function
;; (fundoc 'uuid-print-bytes
;; "Print the raw bytes of UUID in hexadecimal format to STREAM.~%~@
;; UUID is an instance of `unique-universal-identifier' class.~%~@
;; STREAM is an output-stream.
;; Output of returned has the format:~%
;; 6ba7b8109dad11d180b400c04fd430c8~%~@
;; :EXAMPLE~%~@
;; { ... <EXAMPLE> ... } ~%~@
;; :SEE-ALSO `<XREF>'.~%")
;;; ==============================
;; (typedoc 'uuid-integer-length
;; "An object of this type is an integer of type \(unsigned-byte 3\) in the set {1 2 4 6}.~%~@
;; These represent valid `cl:integer-length's capable of representing the numeric
;; value in a fully intialized instance of the class `unique-universal-identifier'.
;; :EXAMPLE~%
;; \(mapcar #'\(lambda \(x\) \(cons \(typep x 'uuid-integer-length\) x\)\) '\(0 1 2 3 4 5 6 7\)\)~%
;; :SEE-ALSO `uuid-number-to-byte-array'.~%")
;;; ==============================
;;; ==============================
;;; :NOTE The type signature of the arrray returned by `uuid-digest-uuid-string' differs for :MD5 vs :SHA1
;;; v5 :SHA1 returns an array of type: (simple-array (unsigned-byte 8) (20))
;;; v3 :MD5 returns an array of type: (simple-array (unsigned-byte 8) (16))
;;
;;; :NOTE No longer using. This was specialized on the return value of:
;;; (uuid-get-bytes (uuid-print-bytes nil *uuid-namespace-dns*))
;; (defun uuid-digest-uuid-string (digest-version string-uuid name)
;; ;; This is step two of RFC4122 section 4.3
;; ;; - Compute the hash of the name space ID concatenated with the name.
;; (declare ((mod 6) digest-version)
;; (type string name string-uuid))
;; (let ((digester (ironclad:make-digest (%verify-digest-version digest-version))))
;; ;; :NOTE `mon:ascii-string-to-byte-array'
;; (ironclad:update-digest digester (ironclad:ascii-string-to-byte-array string-uuid))
;; (ironclad:update-digest digester
;; ;; #-sbcl (trivial-utf-8:string-to-utf-8-bytes name))
;; ;; :NOTE sb-ext:string-to-octets is approx 11x
;; ;; faster and conses 75% less than flexi-streams:string-to-octets
;; #-sbcl (the uuid-byte-array (flexi-streams:string-to-octets name :external-format :UTF-8))
;; #+sbcl (the uuid-byte-array (sb-ext:string-to-octets name :external-format :UTF-8)))
;; (the (values uuid-byte-array &optional) (ironclad:produce-digest digester))))
;;
;;
;; (defun uuid-print-bytes (stream uuid)
;; (declare (type unique-universal-identifier uuid)
;; (optimize (speed 3)))
;; (with-slots (%uuid_time-low
;; %uuid_time-mid
;; %uuid_time-high-and-version
;; %uuid_clock-seq-and-reserved
;; %uuid_clock-seq-low
;; %uuid_node)
;; uuid
;; (declare (type uuid-ub32 %uuid_time-low)
;; (type uuid-ub16 %uuid_time-mid %uuid_time-high-and-version)
;; (type uuid-ub8 %uuid_clock-seq-and-reserved %uuid_clock-seq-low)
;; (type uuid-ub48 %uuid_node))
;; (format stream "~8,'0X~4,'0X~4,'0X~2,'0X~2,'0X~12,'0X"
;; %uuid_time-low
;; %uuid_time-mid
;; %uuid_time-high-and-version
;; %uuid_clock-seq-and-reserved
;; %uuid_clock-seq-low
;; %uuid_node)))
;;
;; :WAS The convoluted print-bytes/get-bytes route
;; (defun make-v3-uuid (namespace name)
;; (declare (type string name)
;; (unique-universal-identifier namespace)
;; (optimize (speed 3)))
;; ;;;; (digested-v3or5-uuid (uuid-digest-uuid-string 3 (uuid-get-bytes (uuid-print-bytes nil namespace)) name) 3))
;; (digested-v3or5-uuid
;; (the uuid-byte-array-16
;; (uuid-digest-uuid-string 3
;; (the uuid-byte-string
;; (uuid-get-bytes
;; (the uuid-string-32
;; (uuid-print-bytes nil namespace)))) name)) 3))
;;
;; :WAS The convoluted print-bytes/get-bytes route
;; (defun make-v5-uuid (namespace name)
;; (declare (type string name)
;; (unique-universal-identifier namespace)
;; (optimize (speed 3)))
;; ;; (digested-v3or5-uuid (uuid-digest-uuid-string 5 (uuid-get-bytes (uuid-print-bytes nil namespace)) name) 5))
;; (digested-v3or5-uuid
;; (the uuid-byte-array-20
;; (uuid-digest-uuid-string 5
;; (the uuid-byte-string
;; (uuid-get-bytes
;; (the uuid-string-32
;; (uuid-print-bytes nil namespace)))) name)) 5)
;;
;;
;;; ==============================
;; (defmacro arr-to-bytes (from to array)
;; "Helper macro used in `uuid-from-byte-array'."
;; `(loop for i from ,from to ,to
;; with res = 0
;; do (setf (ldb (byte 8 (* 8 (- ,to i))) res) (aref ,array i))
;; finally (return res)))
;;
;;; :TESTING use of `macrolet'
;; (defun arr-to-bytes-mlet (array)
;; (macrolet ((arr-to-bytes (from to w-array)
;; (declare ((mod 17) from to))
;; `(loop
;; for i from ,from to ,to
;; with res = 0
;; do (setf (ldb (byte 8 (* 8 (- ,to i))) res) (aref ,w-array i))
;; finally (return res))))
;; (arr-to-bytes 0 3 array )))
;;; ==============================
;;; ==============================
;; Local Variables:
;; indent-tabs-mode: nil
;; show-trailing-whitespace: t
;; mode: lisp-interaction
;; package: unicly
;; End:
;;; ==============================
;;; EOF