Ignore too small data snippets.

[rrq/lsp-utils.git] / lsp-dbus / lsp-dbus-marshal.lsp

diff --git a/lsp-dbus/lsp-dbus-marshal.lsp b/lsp-dbus/lsp-dbus-marshal.lsp
index 81b6aa50184d682c66fa267375b3632dac125133..26da795abfcd2cbcafd106bc5b5e86e4510bc165 100644 (file)
--- a/lsp-dbus/lsp-dbus-marshal.lsp
+++ b/lsp-dbus/lsp-dbus-marshal.lsp
@@ -15,6 +15,7 @@
 ; Ex: "a(yi)" = (("a" ("y" "i")))
 ; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v")))
 (define (expand-signature S)
+  (setf S (replace "{" (replace "}" (copy S) ")") "("))
   (let ((STACK '()) (CUR '()) (A 0))
     (dolist (X (explode S))
       (case X
@@ -49,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)
@@ -123,6 +124,7 @@
 ;; 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)))
 
@@ -144,13 +146,12 @@
 ;; and followed by a NUL byte. The subsequent data is unpacked
 ;; according to that type character.
 (define (unpack-data-variant)
-  (let ((ES ((unpack "bs1b" (AT DATA)) 1)))
-    (inc AT 3)
-    (unpack-data-item ES)))
+  (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
 
 ;; 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 (length DATA)))
   (if (list? ES) (unpack-data-struct ES)
     (= ES "s") (unpack-data-string ES)
     (= ES "o") (unpack-data-string ES)
@@ -163,12 +164,15 @@
 ;; elements.
 (define (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 "---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))))
 
@@ -176,6 +180,7 @@
 ;; a pair (unpacked pos) of unpacked data and how much data is
 ;; consumed.
 (define (unpack-data SIGN DATA (AT 0))
+  ##(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
@@ -188,18 +193,29 @@
 ;; extended with the pair ("" body).
 (define (unpack-messages DATA)
   (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil))
-    (while (and (< AT (length DATA))
+    (while (and (< (+ AT 7) (length DATA))
                 (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
       (setf AT (M 1))
-      (setf M (M 0 -1)) ; Drop
-      (dotimes (i (length M 0))
+      ##(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)))
-      (setf S (if (lookup 'SIGNATURE M) ($it 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)))))
-      (push  M OUT -1)
+      ;; 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"