1 ;; This newlisp "module" implements dbus marshalling
3 ; The newlisp representation is a simplified form using lists for
6 ;; (expand-signature S)
7 ; Expland a signature string into a nested list to correspond to the
8 ; newlisp list representation.
9 ;; Basic dbus types are basic newlisp types, including strings. Arrays
10 ;; and structs are sublists; the expanded signature marks array
11 ;; sublists with an initial "a", otherwise it's a struct sublist.
13 ; Ex: "yi" = ("y" "i")
14 ; Ex: "y(ai)" = ("y" (("a" "i")))
15 ; Ex: "a(yi)" = (("a" ("y" "i")))
16 ; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
17 (define (expand-signature S)
18 (setf S (replace "{" (replace "}" (copy S) ")") "("))
19 (let ((STACK '()) (CUR '()) (A 0))
20 (dolist (X (explode S))
22 (")" (setf X CUR) (setf CUR (pop STACK)))
23 ("(" (push CUR STACK) (setf CUR '()))
25 (when (and (!= X "a") (!= X "("))
26 (while (and CUR (= "a" (last CUR)))
27 (setf X (list (last CUR) X))
28 (setf CUR (chop CUR))))
31 (if (null? CUR) '() CUR)))
33 ;; Align AT to an I multiple and pad DATA with as many NUL bytes at
34 ;; front, then increment AT past it all.
35 (define (pack-align DATA (I (length DATA)))
36 (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
37 (setf DATA (extend PAD DATA))
38 (inc AT (length DATA))
41 ;; Pack data from DATA according to signature. The DATA is a nested
42 ;; list where container types are sub lists. Variant types also appear
43 ;; as pairs of signature and value.
44 (define (pack-data SIGN DATA)
45 (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
47 ;; Pack a newlisp data element according to marshalling type The
48 ;; newlisp data is integer, double, string or list (for container and
51 'FMTMAP ; mapping dbus type code to byte size and newlisp code
52 '( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
53 ("b" 4 "lu") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
54 ("n" 2 "d") ; INT16 (signed 16-bit integer)
55 ("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
56 ("i" 4 "ld") ; INT32 (signed 32-bit integer)
57 ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
58 ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
59 ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
60 ("d" 8 "lf") ; DOUBLE (64-bit float)
61 ("h" 4 "lu") ; UINT32 (unix file descriptor)
62 ("a" ? ?) ; ARRAY = UINT32 byte-length, items
63 ("s" ? ?) ; STRING = length + data + NUL
64 ("o" ? ?) ; OBJECT_PATH = BYTE length + data + NUL
65 ("g" ? ?) ; SIGNATURE = BYTE length + data + NUL
66 ("(" ? ?) ; STRUCT begin in signature = (8-align) + data
67 (")" 0 ?) ; STRUCT end in signature
68 ("v" ? ?) ; VARIANT = signature + data
69 ("{" ? ?) ; DICT_ENTRY begin
70 ("}" ? ?) ; DICT_ENTRY end
71 ("r" ? ?) ; reserved STRUCT in bindings?
72 ("e" ? ?) ; reserved DICT_ENTRY in bindings ?
73 ("m" ? ?) ; reserved 'maybe'
74 ("*" ? ?) ; reserved 'single complete type'
75 ("?" ? ?) ; reserved 'basic type'
82 (define (pack-data-item ES DATA)
83 (if (list? ES) (pack-data-struct ES DATA)
84 (= ES "s") (pack-data-string ES DATA)
85 (= ES "o") (pack-data-string ES DATA)
86 (= ES "g") (pack-data-signature ES DATA)
87 (= ES "v") (apply pack-data-variant DATA)
88 (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
90 (define (pack-data-variant ES DATA)
91 (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
92 (pack-data-item ES DATA)))
94 ;; pack types "s" and "o"
95 (define (pack-data-string ES DATA)
96 (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))
99 (define (pack-data-signature ES DATA)
100 (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1))
102 ;; Pack an array. DATA elements marshalled by repeating ES, preceded
103 ;; by the array length in bytes as aligned UINT32.
104 (define (pack-data-array ES DATA)
105 (let ((PAD (pack-align "" 4))
106 (X (inc AT 4)) ; start index of array bytes
107 (DATA (apply extend (map (curry pack-data-item ES) DATA))))
108 (extend PAD (pack "lu" (- AT X)) DATA)))
110 ;; Pack a struct. ES and DATA elements marshalled pairwise in order
111 ;; following an initial8-byte alignment.
112 (define (pack-data-struct ES DATA)
113 (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
114 (apply extend (cons (pack-align "" 8)
115 (map pack-data-item ES DATA)))))
117 ;;########## unpacking
119 ;; Advance AT to an I multiple.
121 (inc AT (% (- I (% AT I)) I)))
123 ;; Advance AT to an I multiple and unpack (by newlisp format) at that
124 ;; position in DATA. Then advance AT further past that unpacking but
125 ;; return the unpacked value.
126 (define (unpack-align I FMT)
128 (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
130 ;; Unpack a string or object path. The format is "lu" (UINT32) with
131 ;; the string length, then "s%db" with that string length and followed
133 (define (unpack-data-string ES (N (unpack-align 4 "lu")))
134 (prog1 ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))
136 ;; Unpack a signature string. The format is "b" (BYTE) with the string
137 ;; length, then "s%db" with that string length and followed by a NUL
138 ;; byte. I.e. the same as unpack-data-string but with the string
139 ;; length in a BYTE rather than an UINT32.
140 (define (unpack-data-signature ES)
141 (unpack-data-string ES (unpack-align 1 "b")))
143 ;; Unpack a variant item. This consists of "bbb" where the middle
144 ;; character is the type character for the data, preceded by a 1 byte
145 ;; and followed by a NUL byte. The subsequent data is unpacked
146 ;; according to that type character.
147 (define (unpack-data-variant)
148 (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
150 ;; Unpack the ES type item from (AT DATA), optionally with
151 ;; pre-alignment, and increment AT past the padding and item.
152 (define (unpack-data-item ES)
153 (if (list? ES) (unpack-data-struct ES)
154 (= ES "s") (unpack-data-string ES)
155 (= ES "o") (unpack-data-string ES)
156 (= ES "g") (unpack-data-signature ES)
157 (= ES "v") (unpack-data-variant)
158 (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
160 ;; Unpack array with ES elements. The array begins with an UINT32
161 ;; field telling how many bytes to unpack, followed by the array
163 (define (unpack-data-array ES)
164 (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
165 (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
167 (push (unpack-data-item ES) OUT -1))
170 ;; Unpack a structure or array with ES fields.
171 (define (unpack-data-struct ES)
172 (if (= "a" (ES 0)) (unpack-data-array (ES 1))
173 (begin (align-AT 8) (map unpack-data-item ES))))
175 ;; Unpack from a DATA string according to signature SIGN This returns
176 ;; a pair (unpacked pos) of unpacked data and how much data is
178 (define (unpack-data SIGN DATA (AT 0))
179 (list (unpack-data-item (expand-signature SIGN)) AT))
181 ;; Unpack all dbus messages in the given DATA block. Each message
182 ;; consists of head and body. The head has signature "yyyyuua(yv)"
183 ;; where the array is an alist of key-value pairs, optionally
184 ;; including the 'SIGNATURE key with the signature for the body; if
185 ;; omitted, then the body is empty.
187 ;; The function returns the header list of key-value pairs optionally
188 ;; extended with the pair ("" body).
189 (define (unpack-messages DATA)
190 (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
191 (while (and (< AT (length DATA))
192 (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
194 (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
195 (dotimes (i (length M 0))
196 (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
197 ;; Add the body, if any, keyed by "".
198 (setf S (if (lookup 'SIGNATURE M) $it ""))
199 (when (and (!= S "") (setf D (unpack-data S DATA AT)))
201 (extend M (list (list "" (D 0)))))
202 ;; Collate message and move to the next portion in DATA
204 (setf DATA (AT DATA))
209 "lsp-dbus-marshal.lsp"