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 ;;================
   7 ; Expland a signature string into a nested list to correspond to the
   8 ; newlisp list representation. Basic dbus types are basic newlisp
   9 ; types, including strings. Arrays and structs are sublists. The
  10 ; signature marks array sublists with an initial "a", otherwise it's a
  11 ; 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   (println (list 'expand-signature S))
  19   (let ((STACK '()) (CUR '()) (A 0))
  20     (dolist (X (explode S))
  21       ;;(println "CUR=" CUR " X=" X)
  22       (case X
  23         (")" (setf X CUR) (setf CUR (pop STACK)))
  24         ("(" (push CUR STACK) (setf CUR '()))
  25         (true true))
  26       (when (and (!= X "a") (!= X "("))
  27         (while (and CUR (= "a" (last CUR)))
  28           (setf X (list (last CUR) X))
  29           (setf CUR (chop CUR))))
  30       (when (!= "(" X)
  31         (push X CUR -1)))
  32     (if (null? CUR) '() (1 CUR) CUR (CUR 0)) ))
  33
  34 ;; Join arguments with a given byte-alignment
  35 (define (pad-join N)
  36   ;;(println (list 'pad-join AT N (args)))
  37   (let ((OUT ""))
  38     (dolist (S (args))
  39       (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
  40         (extend OUT PAD S)))
  41     OUT))
  42
  43 ;; Pack data from DATA according to signature. The DATA is a nested
  44 ;; list where container types are sub lists. Variant types also appear
  45 ;; as pairs of signature and value.
  46 (define (pack-data SIGN DATA)
  47   (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
  48
  49 ;; Align AT to an I multiple by adding nul bytes, then extend it with
  50 ;; DATA, and increment AT
  51 (define (pack-align DATA (I (length DATA)))
  52   (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
  53     ;;(println (list 'align AT I (length PAD)))
  54     (setf DATA (extend PAD DATA))
  55     (inc AT (length DATA))
  56     DATA))
  57
  58 ;; Advance AT to align by I
  59 (define (align-unpack I FMT N)
  60   ((list (inc AT (% (- I (% AT I)) I)) ; align to I
  61          (unpack FMT (AT DATA))
  62          (inc AT N))
  63    1 0)) ; return second term's first item
  64
  65
  66 ;; Pack a newlisp data element according to marshalling type The
  67 ;; newlisp data is integer, double, string or list (for container and
  68 ;; variant elements).
  69 (constant
  70  'FMTMAP ; mapping dbus type code to byte size and newlisp code
  71  '( ("y" 1 "b")  ; BYTE (unsigned 8-bit integer)
  72     ("b" 1 "b")  ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
  73     ("n" 2 "d")  ; INT16 (signed 16-bit integer)
  74     ("q" 2 "u")  ; UINT16 (unsigned 16-bit integer)
  75     ("i" 4 "ld") ; INT32 (signed 32-bit integer)
  76     ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
  77     ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
  78     ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
  79     ("d" 8 "lf") ; DOUBLE (64-bit float)
  80     ("h" 4 "lu") ; UINT32 (unix file descriptor)
  81     ("a" ? ?)    ; ARRAY = UINT32 byte-length, items
  82     ("s" ? ?)    ; STRING = length + data + NUL
  83     ("o" ? ?)    ; OBJECT_PATH = BYTE length + data + NUL
  84     ("g" ? ?)    ; SIGNATURE = BYTE length + data + NUL
  85     ("(" ? ?)    ; STRUCT begin in signature = (8-align) + data
  86     (")" 0 ?)    ; STRUCT end in signature
  87     ("v" ? ?)    ; VARIANT = signature + data
  88     ("{" ? ?)    ; DICT_ENTRY begin
  89     ("}" ? ?)    ; DICT_ENTRY end
  90     ("r" ? ?)    ; reserved STRUCT in bindings?
  91     ("e" ? ?)    ; reserved DICT_ENTRY in bindings ?
  92     ("m" ? ?)    ; reserved 'maybe'
  93     ("*" ? ?)    ; reserved 'single complete type'
  94     ("?" ? ?)    ; reserved 'basic type'
  95     ("@" ? ?)    ; reserved
  96     ("&" ? ?)    ; reserved
  97     ("^" ? ?)    ; reserved
  98     )
  99  )
 100
 101 (define (pack-data-item ES DATA)
 102   ;;(println (list 'pack-data-item AT ES DATA))
 103   (if (list? ES) (pack-data-struct ES DATA)
 104     (find ES "osg") (pack-data-string ES DATA)
 105     (= ES "v") (apply pack-data-variant DATA)
 106     (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
 107
 108 (define (pack-data-variant ES DATA)
 109   ;;(println (list 'pack-data-variant AT ES DATA))
 110   (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
 111           (pack-data-item ES DATA)))
 112
 113 (define (pack-data-string ES DATA)
 114   (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 1))
 115
 116 ;; Pack an array. DATA elements marshalled by repeating ES, preceded
 117 ;; by the array length in bytes as aligned UINT32.
 118 (define (pack-data-array ES DATA)
 119   ;;(println (list 'pack-data-array AT ES DATA))
 120   (let ((PAD (pack-align "" 4))
 121         (X (inc AT 4)) ; start index of array bytes
 122         (DATA (apply extend (map (curry pack-data-item ES) DATA))))
 123     (extend PAD (pack "lu" (- AT X)) DATA)))
 124
 125 ;; Pack a struct. ES and DATA elements marshalled pairwise in order
 126 ;; following an initial8-byte alignment.
 127 (define (pack-data-struct ES DATA)
 128   ;;(println (list 'pack-data-struct AT ES DATA))
 129   (if (= "a" (ES 0))
 130       (pack-data-array (ES 1) DATA)
 131     (apply extend (cons (pack-align "" 8)
 132                         (map pack-data-item ES DATA)))))
 133
 134 ;;########## unpacking
 135
 136 (define (align-AT I)
 137   (inc AT (% (- I (% AT I)) I)))
 138
 139 (define (unpack-align I FMT)
 140   (align-AT I)
 141   (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
 142
 143 (define (unpack-data-string ES)
 144   ;;(println (list 'unpack-data-string ES AT (unpack "bbbb" (AT DATA))))
 145   (let ((N (if (= "g" ES) (unpack-align 1 "b") (unpack-align 4 "lu"))))
 146     (prog1 (unpack (string "s" N) (AT DATA)) (inc AT (+ 1 N)))))
 147
 148 (define (unpack-data-variant)
 149   ;;(println (unpack "bbbb" (AT DATA)))
 150   (let ((ES (char ((unpack "bbb" (AT DATA)) 1))))
 151     (inc AT 3)
 152     (unpack-data-item ES)))
 153
 154 ;; Unpack the ES item from (AT DATA) and increment AT
 155 (define (unpack-data-item ES)
 156   ;;(println (list 'unpack-data-item ES AT (unpack "b" (AT DATA))))
 157   ;;(when (= ES "\000") (println (history true)))
 158   (if (list? ES) (unpack-data-struct ES)
 159     (find ES "+gosg") (unpack-data-string ES)
 160     (= ES "v") (unpack-data-variant)
 161     (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
 162
 163 ;; Unpack array with ES elements. The array begins with an UINT32
 164 ;; field telling how many bytes to unpack
 165 (define (unpack-data-array ES)
 166   ;;(println (list 'unpack-data-array ES))
 167   (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
 168     (while (< AT N)
 169       ;;(println (list 'item AT N))
 170       (push (unpack-data-item ES) OUT -1))
 171     OUT))
 172
 173 ;; Unpack a structure or array with ES fields.
 174 (define (unpack-data-struct ES)
 175   (if (= "a" (ES 0)) (unpack-data-array (ES 1))
 176     (begin (align-AT 8) (map unpack-data-item ES))))
 177
 178 ;; Unpack from a DATA string according to signature SIGN This returns
 179 ;; a pair (unpacked pos) of unpacked data and how much data is
 180 ;; consumed.
 181 (define (unpack-data SIGN DATA (AT 0))
 182   ;;(println (list 'unpack-data SIGN "DATA length " (length DATA)))
 183   ;;(map println (explode (unpack (dup "b" (length (AT DATA))) (AT DATA)) 20))
 184   (list (unpack-data-item (expand-signature SIGN)) AT))
 185