+;; This newlisp "module" implements dbus marshalling
+;
+; The newlisp representation is a simplified form using lists for
+; structs and arrays
+
+;;================
+; Expland a signature string into a nested list to correspond to the
+; newlisp list representation. Basic dbus types are basic newlisp
+; types, including strings. Arrays and structs are sublists. The
+; signature marks array sublists with an initial "a", otherwise it's a
+; struct sublist.
+;
+; Ex: "yi" = ("y" "i")
+; Ex: "y(ai)" = ("y" (("a" "i")))
+; Ex: "a(yi)" = (("a" ("y" "i")))
+; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
+(define (expand-signature S)
+ (println (list 'expand-signature S))
+ (let ((STACK '()) (CUR '()) (A 0))
+ (dolist (X (explode S))
+ ;;(println "CUR=" CUR " X=" X)
+ (case X
+ (")" (setf X CUR) (setf CUR (pop STACK)))
+ ("(" (push CUR STACK) (setf CUR '()))
+ (true true))
+ (when (and (!= X "a") (!= X "("))
+ (while (and CUR (= "a" (last CUR)))
+ (setf X (list (last CUR) X))
+ (setf CUR (chop CUR))))
+ (when (!= "(" X)
+ (push X CUR -1)))
+ (if (null? CUR) '() (1 CUR) CUR (CUR 0)) ))
+
+;; Join arguments with a given byte-alignment
+(define (pad-join N)
+ ;;(println (list 'pad-join AT N (args)))
+ (let ((OUT ""))
+ (dolist (S (args))
+ (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N))))
+ (extend OUT PAD S)))
+ OUT))
+
+;; Pack data from DATA according to signature. The DATA is a nested
+;; list where container types are sub lists. Variant types also appear
+;; as pairs of signature and value.
+(define (pack-data SIGN DATA)
+ (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA)))
+
+;; Align AT to an I multiple by adding nul bytes, then extend it with
+;; DATA, and increment AT
+(define (pack-align DATA (I (length DATA)))
+ (let ((PAD (dup "\000" (% (- I (% AT I)) I))))
+ ;;(println (list 'align AT I (length PAD)))
+ (setf DATA (extend PAD DATA))
+ (inc AT (length DATA))
+ DATA))
+
+;; Advance AT to align by I
+(define (align-unpack I FMT N)
+ ((list (inc AT (% (- I (% AT I)) I)) ; align to I
+ (unpack FMT (AT DATA))
+ (inc AT N))
+ 1 0)) ; return second term's first item
+
+
+;; Pack a newlisp data element according to marshalling type The
+;; newlisp data is integer, double, string or list (for container and
+;; variant elements).
+(constant
+ 'FMTMAP ; mapping dbus type code to byte size and newlisp code
+ '( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
+ ("b" 1 "b") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
+ ("n" 2 "d") ; INT16 (signed 16-bit integer)
+ ("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
+ ("i" 4 "ld") ; INT32 (signed 32-bit integer)
+ ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
+ ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
+ ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
+ ("d" 8 "lf") ; DOUBLE (64-bit float)
+ ("h" 4 "lu") ; UINT32 (unix file descriptor)
+ ("a" ? ?) ; ARRAY = UINT32 byte-length, items
+ ("s" ? ?) ; STRING = length + data + NUL
+ ("o" ? ?) ; OBJECT_PATH = BYTE length + data + NUL
+ ("g" ? ?) ; SIGNATURE = BYTE length + data + NUL
+ ("(" ? ?) ; STRUCT begin in signature = (8-align) + data
+ (")" 0 ?) ; STRUCT end in signature
+ ("v" ? ?) ; VARIANT = signature + data
+ ("{" ? ?) ; DICT_ENTRY begin
+ ("}" ? ?) ; DICT_ENTRY end
+ ("r" ? ?) ; reserved STRUCT in bindings?
+ ("e" ? ?) ; reserved DICT_ENTRY in bindings ?
+ ("m" ? ?) ; reserved 'maybe'
+ ("*" ? ?) ; reserved 'single complete type'
+ ("?" ? ?) ; reserved 'basic type'
+ ("@" ? ?) ; reserved
+ ("&" ? ?) ; reserved
+ ("^" ? ?) ; reserved
+ )
+ )
+
+(define (pack-data-item ES DATA)
+ ;;(println (list 'pack-data-item AT ES DATA))
+ (if (list? ES) (pack-data-struct ES DATA)
+ (find ES "osg") (pack-data-string ES DATA)
+ (= ES "v") (apply pack-data-variant DATA)
+ (if (lookup ES FMTMAP) (pack-align (pack $it DATA)))))
+
+(define (pack-data-variant ES DATA)
+ ;;(println (list 'pack-data-variant AT ES DATA))
+ (extend (pack-align (pack "bbb" 1 (char ES) 0) 1)
+ (pack-data-item ES DATA)))
+
+(define (pack-data-string ES DATA)
+ (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 1))
+
+;; Pack an array. DATA elements marshalled by repeating ES, preceded
+;; by the array length in bytes as aligned UINT32.
+(define (pack-data-array ES DATA)
+ ;;(println (list 'pack-data-array AT ES DATA))
+ (let ((PAD (pack-align "" 4))
+ (X (inc AT 4)) ; start index of array bytes
+ (DATA (apply extend (map (curry pack-data-item ES) DATA))))
+ (extend PAD (pack "lu" (- AT X)) DATA)))
+
+;; Pack a struct. ES and DATA elements marshalled pairwise in order
+;; following an initial8-byte alignment.
+(define (pack-data-struct ES DATA)
+ ;;(println (list 'pack-data-struct AT ES DATA))
+ (if (= "a" (ES 0))
+ (pack-data-array (ES 1) DATA)
+ (apply extend (cons (pack-align "" 8)
+ (map pack-data-item ES DATA)))))
+
+;;########## unpacking
+
+(define (align-AT I)
+ (inc AT (% (- I (% AT I)) I)))
+
+(define (unpack-align I FMT)
+ (align-AT I)
+ (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
+
+(define (unpack-data-string ES)
+ ;;(println (list 'unpack-data-string ES AT (unpack "bbbb" (AT DATA))))
+ (let ((N (if (= "g" ES) (unpack-align 1 "b") (unpack-align 4 "lu"))))
+ (prog1 (unpack (string "s" N) (AT DATA)) (inc AT (+ 1 N)))))
+
+(define (unpack-data-variant)
+ ;;(println (unpack "bbbb" (AT DATA)))
+ (let ((ES (char ((unpack "bbb" (AT DATA)) 1))))
+ (inc AT 3)
+ (unpack-data-item ES)))
+
+;; Unpack the ES item from (AT DATA) and increment AT
+(define (unpack-data-item ES)
+ ;;(println (list 'unpack-data-item ES AT (unpack "b" (AT DATA))))
+ ;;(when (= ES "\000") (println (history true)))
+ (if (list? ES) (unpack-data-struct ES)
+ (find ES "+gosg") (unpack-data-string ES)
+ (= ES "v") (unpack-data-variant)
+ (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1)))))
+
+;; Unpack array with ES elements. The array begins with an UINT32
+;; field telling how many bytes to unpack
+(define (unpack-data-array ES)
+ ;;(println (list 'unpack-data-array ES))
+ (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
+ (while (< AT N)
+ ;;(println (list 'item AT N))
+ (push (unpack-data-item ES) OUT -1))
+ OUT))
+
+;; Unpack a structure or array with ES fields.
+(define (unpack-data-struct ES)
+ (if (= "a" (ES 0)) (unpack-data-array (ES 1))
+ (begin (align-AT 8) (map unpack-data-item ES))))
+
+;; Unpack from a DATA string according to signature SIGN This returns
+;; a pair (unpacked pos) of unpacked data and how much data is
+;; consumed.
+(define (unpack-data SIGN DATA (AT 0))
+ ;;(println (list 'unpack-data SIGN "DATA length " (length DATA)))
+ ;;(map println (explode (unpack (dup "b" (length (AT DATA))) (AT DATA)) 20))
+ (list (unpack-data-item (expand-signature SIGN)) AT))
+