X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=lsp-dbus%2Flsp-dbus-marshal.lsp;h=26da795abfcd2cbcafd106bc5b5e86e4510bc165;hb=de600b7667b5df4b1fb48c0c496f8e2fc86c08c7;hp=4e72ef6f8bd78cdce14b60dd19554a603d33be0b;hpb=b803427b65b26ec297322de115e8dcbae55b033e;p=rrq%2Flsp-utils.git

diff --git a/lsp-dbus/lsp-dbus-marshal.lsp b/lsp-dbus/lsp-dbus-marshal.lsp
index 4e72ef6..26da795 100644
--- a/lsp-dbus/lsp-dbus-marshal.lsp
+++ b/lsp-dbus/lsp-dbus-marshal.lsp
@@ -1,24 +1,23 @@
 ;; This newlisp "module" implements dbus marshalling
 ;
 ; The newlisp representation is a simplified form using lists for
-; structs and arrays
+; structs and arrays.
 
-;;================
+;; (expand-signature S)
 ; 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.
+; newlisp list representation.
+;; Basic dbus types are basic newlisp types, including strings. Arrays
+;; and structs are sublists; the expanded 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))
+  (setf S (replace "{" (replace "}" (copy 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 '()))
@@ -29,39 +28,21 @@
           (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)))
+    (if (null? CUR) '() CUR)))
 
-;; Align AT to an I multiple by adding nul bytes, then extend it with
-;; DATA, and increment AT
+;; Align AT to an I multiple and pad DATA with as many NUL bytes at
+;; front, then increment AT past it all.
 (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 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)))
 
 ;; Pack a newlisp data element according to marshalling type The
 ;; newlisp data is integer, double, string or list (for container and
@@ -69,7 +50,7 @@
 (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)
+    ("b" 4 "lu")  ; 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)
@@ -99,24 +80,28 @@
  )
 
 (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 "s") (pack-data-string ES DATA)
+    (= ES "o") (pack-data-string ES DATA)
+    (= ES "g") (pack-data-signature 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)))
 
+;; pack types "s" and "o"
 (define (pack-data-string ES DATA)
-  (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 1))
+  (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4))
+
+;; pack type "g"
+(define (pack-data-signature ES DATA)
+  (pack-align (pack (format "bs%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))))
@@ -125,53 +110,69 @@
 ;; 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)
+  (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA)
     (apply extend (cons (pack-align "" 8)
                         (map pack-data-item ES DATA)))))
 
 ;;########## unpacking
 
+;; Advance AT to an I multiple.
 (define (align-AT I)
   (inc AT (% (- I (% AT I)) I)))
 
+;; Advance AT to an I multiple and unpack (by newlisp format) at that
+;; position in DATA. Then advance AT further past that unpacking but
+;; return the unpacked value.
 (define (unpack-align I FMT)
+  ##(println (list 'unpack-align I FMT AT (length DATA)))
   (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)))))
-
+;; Unpack a string or object path. The format is "lu" (UINT32) with
+;; the string length, then "s%db" with that string length and followed
+;; by a NUL byte.
+(define (unpack-data-string ES (N (unpack-align 4 "lu")))
+  (prog1 ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N))))
+
+;; Unpack a signature string. The format is "b" (BYTE) with the string
+;; length, then "s%db" with that string length and followed by a NUL
+;; byte. I.e. the same as unpack-data-string but with the string
+;; length in a BYTE rather than an UINT32.
+(define (unpack-data-signature ES)
+  (unpack-data-string ES (unpack-align 1 "b")))
+
+;; Unpack a variant item. This consists of "bbb" where the middle
+;; character is the type character for the data, preceded by a 1 byte
+;; and followed by a NUL byte. The subsequent data is unpacked
+;; according to that type character.
 (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-data-item ((expand-signature (unpack-data-signature "g")) 0)))
 
-;; Unpack the ES item from (AT DATA) and increment AT
+;; Unpack the ES type item from (AT DATA), optionally with
+;; pre-alignment, and increment AT past the padding and item.
 (define (unpack-data-item ES)
-  ;;(println (list 'unpack-data-item ES AT (unpack "b" (AT DATA))))
-  ;;(when (= ES "\000") (println (history true)))
+  ##(println (list 'unpack-data-item ES AT (length DATA)))
   (if (list? ES) (unpack-data-struct ES)
-    (find ES "+gosg") (unpack-data-string ES)
+    (= ES "s") (unpack-data-string ES)
+    (= ES "o") (unpack-data-string ES)
+    (= ES "g") (unpack-data-signature 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
+;; field telling how many bytes to unpack, followed by the array
+;; elements.
 (define (unpack-data-array ES)
-  ;;(println (list 'unpack-data-array ES))
   (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
+    (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
     (while (< AT N)
-      ;;(println (list 'item AT N))
+      ##(println "---next " (list AT N))
       (push (unpack-data-item ES) OUT -1))
     OUT))
 
 ;; Unpack a structure or array with ES fields.
 (define (unpack-data-struct ES)
+  ##(println (list 'unpack-data-struct ES AT))
   (if (= "a" (ES 0)) (unpack-data-array (ES 1))
     (begin (align-AT 8) (map unpack-data-item ES))))
 
@@ -179,7 +180,42 @@
 ;; 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))
+  ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
   (list (unpack-data-item (expand-signature SIGN)) AT))
 
+;; Unpack all dbus messages in the given DATA block. Each message
+;; consists of head and body. The head has signature "yyyyuua(yv)"
+;; where the array is an alist of key-value pairs, optionally
+;; including the 'SIGNATURE key with the signature for the body; if
+;; omitted, then the body is empty.
+;;
+;; The function returns the header list of key-value pairs optionally
+;; extended with the pair ("" body).
+(define (unpack-messages DATA)
+  (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
+    (while (and (< (+ AT 7) (length DATA))
+                (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
+      (setf AT (M 1))
+      ##(println "message head " (M 0))
+      ##(println (list 'remains AT (length DATA)))
+      (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
+      (dotimes (i (length M))
+        (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
+      ##(println "mapped headers " M)
+      ;; Add the body, if any, keyed by "".
+      (setf S (if (lookup 'SIGNATURE M) $it ""))
+      ##(println (list 'sign S))
+      (when (and (!= S "") (setf D (unpack-data S DATA AT)))
+        (setf AT (D 1))
+        (extend M (list (list "" (D 0)))))
+      ;; Collate message and move to the next portion in DATA
+      (push M OUT -1)
+      ##(println (list 'ending AT (length DATA)))
+      ;;(align-AT 4)
+      ##(println (list 'aligned AT (length DATA)))
+      (setf DATA (AT DATA))
+      (setf AT 0) 
+      )
+    OUT ))
+
+"lsp-dbus-marshal.lsp"