lsp-dbus/lsp-dbus-marshal.lsp

   1 ;; This newlisp "module" implements dbus marshalling
   2 ;
   3 ; The newlisp representation is a simplified form using lists for
   4 ; structs and arrays.
   5
   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.
  12 ;
  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   (let ((STACK '()) (CUR '()) (A 0))
  19     (dolist (X (explode S))
  20       (case X
  21         (")" (setf X CUR) (setf CUR (pop STACK)))
  22         ("(" (push CUR STACK) (setf CUR '()))
  23         (true true))
  24       (when (and (!= X "a") (!= X "("))
  25         (while (and CUR (= "a" (last CUR)))
  26           (setf X (list (last CUR) X))
  27           (setf CUR (chop CUR))))
  28       (when (!= "(" X)
  29         (push X CUR -1)))
  30     (if (null? CUR) '() CUR)))
  31
  32 ;; Align AT to an I multiple and pad DATA with as many NUL bytes at
  33 ;; front, then increment AT past it all.
  34 (define (pack-align DATA (I (length DATA)))
  35   (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
  36     (setf DATA (extend PAD DATA))
  37     (inc AT (length DATA))
  38     DATA))
  39
  40 ;; Pack data from DATA according to signature. The DATA is a nested
  41 ;; list where container types are sub lists. Variant types also appear
  42 ;; as pairs of signature and value.
  43 (define (pack-data SIGN DATA)
  44   (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
  45
  46 ;; Pack a newlisp data element according to marshalling type The
  47 ;; newlisp data is integer, double, string or list (for container and
  48 ;; variant elements).
  49 (constant
  50  'FMTMAP ; mapping dbus type code to byte size and newlisp code
  51  '( ("y" 1 "b")  ; BYTE (unsigned 8-bit integer)
  52     ("b" 1 "b")  ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
  53     ("n" 2 "d")  ; INT16 (signed 16-bit integer)
  54     ("q" 2 "u")  ; UINT16 (unsigned 16-bit integer)
  55     ("i" 4 "ld") ; INT32 (signed 32-bit integer)
  56     ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
  57     ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
  58     ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
  59     ("d" 8 "lf") ; DOUBLE (64-bit float)
  60     ("h" 4 "lu") ; UINT32 (unix file descriptor)
  61     ("a" ? ?)    ; ARRAY = UINT32 byte-length, items
  62     ("s" ? ?)    ; STRING = length + data + NUL
  63     ("o" ? ?)    ; OBJECT_PATH = BYTE length + data + NUL
  64     ("g" ? ?)    ; SIGNATURE = BYTE length + data + NUL
  65     ("(" ? ?)    ; STRUCT begin in signature = (8-align) + data
  66     (")" 0 ?)    ; STRUCT end in signature
  67     ("v" ? ?)    ; VARIANT = signature + data
  68     ("{" ? ?)    ; DICT_ENTRY begin
  69     ("}" ? ?)    ; DICT_ENTRY end
  70     ("r" ? ?)    ; reserved STRUCT in bindings?
  71     ("e" ? ?)    ; reserved DICT_ENTRY in bindings ?
  72     ("m" ? ?)    ; reserved 'maybe'
  73     ("*" ? ?)    ; reserved 'single complete type'
  74     ("?" ? ?)    ; reserved 'basic type'
  75     ("@" ? ?)    ; reserved
  76     ("&" ? ?)    ; reserved
  77     ("^" ? ?)    ; reserved
  78     )
  79  )
  80
  81 (define (pack-data-item ES DATA)
  82   (if (list? ES) (pack-data-struct ES DATA)
  83     (= ES "s") (pack-data-string ES DATA)
  84     (= ES "o") (pack-data-string ES DATA)
  85     (= ES "g") (pack-data-signature ES DATA)
  86     (= ES "v") (apply pack-data-variant DATA)
  87     (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
  88
  89 (define (pack-data-variant ES DATA)
  90   (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
  91           (pack-data-item ES DATA)))
  92
  93 ;; pack types "s" and "o"
  94 (define (pack-data-string ES DATA)
  95   (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))
  96
  97 ;; pack type "g"
  98 (define (pack-data-signature ES DATA)
  99   (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1))
 100
 101 ;; Pack an array. DATA elements marshalled by repeating ES, preceded
 102 ;; by the array length in bytes as aligned UINT32.
 103 (define (pack-data-array ES DATA)
 104   (let ((PAD (pack-align "" 4))
 105         (X (inc AT 4)) ; start index of array bytes
 106         (DATA (apply extend (map (curry pack-data-item ES) DATA))))
 107     (extend PAD (pack "lu" (- AT X)) DATA)))
 108
 109 ;; Pack a struct. ES and DATA elements marshalled pairwise in order
 110 ;; following an initial8-byte alignment.
 111 (define (pack-data-struct ES DATA)
 112   (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
 113     (apply extend (cons (pack-align "" 8)
 114                         (map pack-data-item ES DATA)))))
 115
 116 ;;########## unpacking
 117
 118 ;; Advance AT to an I multiple.
 119 (define (align-AT I)
 120   (inc AT (% (- I (% AT I)) I)))
 121
 122 ;; Advance AT to an I multiple and unpack (by newlisp format) at that
 123 ;; position in DATA. Then advance AT further past that unpacking but
 124 ;; return the unpacked value.
 125 (define (unpack-align I FMT)
 126   (align-AT I)
 127   (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
 128
 129 ;; Unpack a string or object path. The format is "lu" (UINT32) with
 130 ;; the string length, then "s%db" with that string length and followed
 131 ;; by a NUL byte.
 132 (define (unpack-data-string ES (N (unpack-align 4 "lu")))
 133   (prog1 ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))
 134
 135 ;; Unpack a signature string. The format is "b" (BYTE) with the string
 136 ;; length, then "s%db" with that string length and followed by a NUL
 137 ;; byte. I.e. the same as unpack-data-string but with the string
 138 ;; length in a BYTE rather than an UINT32.
 139 (define (unpack-data-signature ES)
 140   (unpack-data-string ES (unpack-align 1 "b")))
 141
 142 ;; Unpack a variant item. This consists of "bbb" where the middle
 143 ;; character is the type character for the data, preceded by a 1 byte
 144 ;; and followed by a NUL byte. The subsequent data is unpacked
 145 ;; according to that type character.
 146 (define (unpack-data-variant)
 147   (let ((ES ((unpack "bs1b" (AT DATA)) 1)))
 148     (inc AT 3)
 149     (unpack-data-item ES)))
 150
 151 ;; Unpack the ES type item from (AT DATA), optionally with
 152 ;; pre-alignment, and increment AT past the padding and item.
 153 (define (unpack-data-item ES)
 154   (if (list? ES) (unpack-data-struct ES)
 155     (= ES "s") (unpack-data-string ES)
 156     (= ES "o") (unpack-data-string ES)
 157     (= ES "g") (unpack-data-signature ES)
 158     (= ES "v") (unpack-data-variant)
 159     (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
 160
 161 ;; Unpack array with ES elements. The array begins with an UINT32
 162 ;; field telling how many bytes to unpack, followed by the array
 163 ;; elements.
 164 (define (unpack-data-array ES)
 165   (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
 166     (while (< AT N)
 167       (push (unpack-data-item ES) OUT -1))
 168     OUT))
 169
 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))))
 174
 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
 177 ;; consumed.
 178 (define (unpack-data SIGN DATA (AT 0))
 179   (list (unpack-data-item (expand-signature SIGN)) AT))
 180
 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.
 186 ;;
 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)))
 193       (setf AT (M 1))
 194       (setf M (M 0 -1)) ; Drop
 195       (dotimes (i (length M 0))
 196         (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
 197       (setf S (if (lookup 'SIGNATURE M) ($it 0) ""))
 198       (when (and (!= S "") (setf D (unpack-data S DATA AT)))
 199         (setf AT (D 1))
 200         (extend M (list (list "" (D 0)))))
 201       (push  M OUT -1)
 202       (setf DATA (AT DATA))
 203       (setf AT 0)
 204       )
 205     OUT ))