-
Notifications
You must be signed in to change notification settings - Fork 29
/
utils.lisp
378 lines (315 loc) · 13.6 KB
/
utils.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
;;;; +----------------------------------------------------------------+
;;;; | DBUS |
;;;; +----------------------------------------------------------------+
(defpackage #:dbus/utils
(:use #:cl)
(:import-from #:alexandria #:once-only #:with-gensyms #:when-let)
(:import-from #:trivial-garbage #:make-weak-hash-table)
(:import-from #:babel #:string-to-octets)
(:import-from #:iolib.syscalls #:getpwuid #:getuid)
(:export
#:make-octet-vector
#:inexistent-entry
#:inexistent-entry-designator
#:entry-replacement-attempt
#:entry-replacement-attempt-old
#:entry-replacement-attempt-new
#:replace-entry-p
#:encode-hex-string
#:decode-hex-string
#:with-if-failed-handler
#:current-username
#:with-binary-writers
#:with-binary-readers
#:stream-read-position
#:signed-to-unsigned
#:unsigned-to-signed
#:define-name-class-mapping
#:align
#:u8
#:u16
#:u32
#:u64))
(in-package #:dbus/utils)
;;;; Utilities
(defun make-octet-vector (size &rest array-options)
"Return a fresh vector whose element type is (unsigned-byte 8)."
(apply #'make-array size :element-type '(unsigned-byte 8) array-options))
(define-condition inexistent-entry (error)
((designator :initarg :designator :reader inexistent-entry-designator))
(:report (lambda (condition stream)
(format stream "An inexistent entry was sought using ~S as designator."
(inexistent-entry-designator condition)))))
(defun inexistent-entry (designator if-does-not-exist)
"Called when an inexistent entry was sought using DESIGNATOR, and
acts according to the value of IF-DOES-NOT-EXIST:
:ERROR
Signal an INEXISTENT-ENTRY error with a USE-VALUE restart.
NIL
Return NIL."
(ecase if-does-not-exist
(:error
(restart-case (error 'inexistent-entry :designator designator)
(use-value (new-value)
:report "Use a value as entry."
:interactive prompt-for-value
new-value)))
((nil) nil)))
(defun prompt-for-value ()
"Interactively prompt for a value. An expression is read and
evaluated, and its value is returned."
(format *query-io* "Enter an expression to yield a value: ")
(multiple-value-list (eval (read *query-io*))))
(define-condition entry-replacement-attempt (error)
((old :initarg :old :reader entry-replacement-attempt-old)
(new :initarg :new :reader entry-replacement-attempt-new))
(:report (lambda (condition stream)
(format stream "Attempted to replace ~S by ~S."
(entry-replacement-attempt-old condition)
(entry-replacement-attempt-new condition)))))
(defun replace-entry-p (old new if-exists)
"Return true if the new entry should replace the old one. IF-EXISTS
determines how to find out:
:ERROR
Signal an ENTRY-REPLACEMENT-ATTEMPT error with a CONTINUE restart
to replace the entry, and an ABORT restart to not replace it.
:WARN
Replace the entry after signaling a warning.
:DONT-REPLACE
Don't replace entry.
:REPLACE
Replace entry."
(flet ((replace-it () (return-from replace-entry-p t))
(dont-replace-it () (return-from replace-entry-p nil)))
(ecase if-exists
(:error
(restart-case (error 'entry-replacement-attempt :old old :new new)
(continue ()
:report "Replace old entry."
(replace-it))
(abort ()
:report "Don't replace old entry."
(dont-replace-it))))
(:warn
(warn "Replacing existing entry ~S with ~S." old new)
(replace-it))
(:dont-replace
(dont-replace-it))
(:replace
(replace-it)))))
(defun encode-hex-string (data &key (start 0) end)
"Encode a string composed of hexadecimal digit character pairs, each
representing an octet. The input is either an octet vector, or a
UTF-8 string that will be converted to one.
START and END are bounding index designators for the data."
(etypecase data
(string
(encode-hex-string
(string-to-octets data :encoding :utf-8 :start start :end end)))
(vector
(with-output-to-string (out)
(loop for index from start below (or end (length data))
for octet = (aref data index) do
(write-char (char-downcase (digit-char (ash octet -4) 16)) out)
(write-char (char-downcase (digit-char (logand octet #x0F) 16)) out))))))
(defun decode-hex-string (string &key (start 0) end)
"Decode a string composed of hexadecimal digit character pairs, each
representing an octet, to an octet vector with the corresponding
octets.
START and END are bounding index designators for the string."
(when (null end)
(setf end (length string)))
(assert (evenp (- end start)))
(let ((octets (make-octet-vector (/ (- end start) 2))))
(with-input-from-string (in string :start start :end end)
(loop for hi = (read-char in nil nil)
for lo = (read-char in nil nil)
for pos upfrom 0
until (null hi)
do (setf (aref octets pos)
(logior (ash (digit-char-p hi 16) 4)
(digit-char-p lo 16)))))
octets))
(defun call-with-if-failed-handler (if-failed function)
"Call FUNCTION in a context according to IF-FAILED:
:ERROR
Signal an error on failure.
NIL
Return NIL on failure."
(ecase if-failed
(:error (funcall function))
((nil) (ignore-errors (funcall function)))))
(defmacro with-if-failed-handler (if-failed-form &body forms)
"Sugar for CALL-WITH-IF-FAILED-HANDLER."
`(call-with-if-failed-handler ,if-failed-form (lambda () ,@forms)))
(defun current-username ()
"Return the current user's name."
(nth-value 0 (getpwuid (getuid))))
(defmacro with-binary-writers ((stream endianness &key prefix) &body forms)
"Evaluate forms with functions to write binary data to the stream in
a given endianness.
STREAM
A form evaluating to a binary output stream with a file position.
ENDIANNESS
A form evaluating to either :LITTLE-ENDIAN or :BIG-ENDIAN.
PREFIX
Either NIL (the default) or a string designator. In the latter
case, the following function names will be symbols interned in the
current package, with <PREFIX>-<NAME> names, e.g., OUTPUT-U8 if
the prefix is OUTPUT.
Local functions:
ALIGN
A function that takes an integer and ensures the stream's file
position is aligned to it. It does so by writing the appropriate
number of 0 octets.
U8, U16, U32, U64
Functions that take 8-, 16-, 32-, and 64-bit unsigned byte values,
respectively, and write these values to the stream, in the
appropriate endianness. The values are always naturally aligned
before written."
(destructuring-bind (align u8 u16 u32 u64)
(mapcar (lambda (symbol)
(if (null prefix)
symbol
(intern (format nil "~A-~A" prefix symbol))))
'(align u8 u16 u32 u64))
(once-only (stream)
(with-gensyms (body-function-name u8-var u16-var u32-var u64-var)
`(flet ((,body-function-name (,u8-var ,u16-var ,u32-var ,u64-var)
(labels ((,align (n)
(loop until (zerop (mod (file-position ,stream) n)) do (,u8 0)))
(,u8 (value)
(funcall ,u8-var value))
(,u16 (value)
(,align 2)
(funcall ,u16-var value))
(,u32 (value)
(,align 4)
(funcall ,u32-var value))
(,u64 (value)
(,align 8)
(funcall ,u64-var value)))
(declare (inline ,align ,u8 ,u16 ,u32 ,u64))
(declare (ignorable #',align #',u8 #',u16 #',u32 #',u64))
,@forms)))
(ecase ,endianness
(:little-endian
(macrolet ((u (size)
`(lambda (value)
,@(loop for i from 0 below size by 8
collect `(write-byte (ldb (byte 8 ,i) value) ,',stream)))))
(,body-function-name (u 8) (u 16) (u 32) (u 64))))
(:big-endian
(macrolet ((u (size)
`(lambda (value)
,@(loop for i from (- size 8) downto 0 by 8
collect `(write-byte (ldb (byte 8 ,i) value) ,',stream)))))
(,body-function-name (u 8) (u 16) (u 32) (u 64))))))))))
(defvar *stream-read-positions*
(make-weak-hash-table :weakness :key)
"A mapping from a stream (weakly referenced) to a read position.")
(defun stream-read-position (stream)
"Return the stream's read position (zero by default)."
(gethash stream *stream-read-positions* 0))
(defun (setf stream-read-position) (new-read-position stream)
"Set the stream's read position to a new value."
(setf (gethash stream *stream-read-positions*) new-read-position))
(defmacro with-binary-readers ((stream endianness &key prefix) &body forms)
"Evaluate forms with functions to read binary data from the stream
in a given endianness.
STREAM
A form evaluating to a binary input stream.
ENDIANNESS
A form evaluating to either :LITTLE-ENDIAN or :BIG-ENDIAN.
PREFIX
Either NIL (the default) or a string designator. In the latter
case, the following function names will be symbols interned in the
current package, with <PREFIX>-<NAME> names, e.g., INPUT-U8 if
the prefix is INPUT.
Local functions:
ALIGN
A function that takes an integer and ensures the stream's read
position is aligned to it. It does so by reading and ignoring the
appropriate number of octets.
U8, U16, U32, U64
Functions that read 8-, 16-, 32-, and 64-bit unsigned byte values,
respectively, from the stream, in the appropriate endianness. The
read position is ensured to be naturally aligned before reading
the value."
(destructuring-bind (align u8 u16 u32 u64)
(mapcar (lambda (symbol)
(if (null prefix)
symbol
(intern (format nil "~A-~A" prefix symbol))))
'(align u8 u16 u32 u64))
(once-only (stream)
(with-gensyms (body-function-name u8-var u16-var u32-var u64-var)
`(flet ((,body-function-name (,u8-var ,u16-var ,u32-var ,u64-var)
(labels ((,align (n)
(loop until (zerop (mod (stream-read-position ,stream) n)) do (,u8)))
(,u8 ()
(funcall ,u8-var))
(,u16 ()
(,align 2)
(funcall ,u16-var))
(,u32 ()
(,align 4)
(funcall ,u32-var))
(,u64 ()
(,align 8)
(funcall ,u64-var)))
(declare (inline ,align ,u8 ,u16 ,u32 ,u64))
(declare (ignorable #',align #',u8 #',u16 #',u32 #',u64))
,@forms)))
(ecase ,endianness
(:little-endian
(macrolet ((u (size)
`(lambda ()
(let ((value 0))
,@(loop for i from 0 below size by 8
collect `(setf (ldb (byte 8 ,i) value)
(read-byte ,',stream)))
(incf (stream-read-position ,',stream) ,(floor size 8))
value))))
(,body-function-name (u 8) (u 16) (u 32) (u 64))))
(:big-endian
(macrolet ((u (size)
`(lambda ()
(let ((value 0))
,@(loop for i from (- size 8) downto 0 by 8
collect `(setf (ldb (byte 8 ,i) value)
(read-byte ,',stream)))
(incf (stream-read-position ,',stream) ,(floor size 8))
value))))
(,body-function-name (u 8) (u 16) (u 32) (u 64))))))))))
(defun signed-to-unsigned (value size)
"Return the unsigned representation of a signed byte with a given
size."
(ldb (byte size 0) value))
(defun unsigned-to-signed (value size)
"Return the signed representation of an unsigned byte with a given
size."
(if (logbitp (1- size) value)
(dpb value (byte size 0) -1)
value))
(defmacro define-name-class-mapping (&key class map find)
"Define an interface for mapping names (strings) to classes (or
class names)."
(let ((map-docstring (format nil "Map names to ~A classes or class names." class))
(find-docstring (format nil "Return the ~A class (or class name) corresponding to NAME." class))
(find-setf-docstring (format nil "Associate a ~A class (or class name) with NAME." class)))
`(progn
(defvar ,map
(make-hash-table :test 'equal)
,map-docstring)
(defun ,find (name &key (if-does-not-exist :error))
,find-docstring
(or (gethash name ,map)
(inexistent-entry name if-does-not-exist)))
(defun (setf ,find) (class name &key (if-exists :warn))
,find-setf-docstring
(when-let (old (,find name :if-does-not-exist nil))
(when (not (replace-entry-p old class if-exists))
(return-from ,find class)))
(setf (gethash name ,map) class))
',class)))