master be5047c: Implement D-Bus properties with compound type.

[Michael Albinus]

branch: master
commit be5047c0d2a3696f8cbd0e36987ef78ded6df09b
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Implement D-Bus properties with compound type.
    
    * lisp/net/dbus.el (dbus-set-property): Fix thinko.
    (dbus-register-property, dbus-property-handler): Support compound
    properties.
    
    * src/dbusbind.c (dbus-registered-objects-table): Fix docstring.
    
    * test/lisp/net/dbus-tests.el (dbus--test-interface): Make it
    different to `dbus--test-service'.
    (dbus-test05-register-property)
    (dbus-test05-register-property-several-paths): Adapt tests.
---
 lisp/net/dbus.el            | 93 ++++++++++++++++++++++++++-------------------
 src/dbusbind.c              |  9 +++--
 test/lisp/net/dbus-tests.el | 17 +++++----
 3 files changed, 68 insertions(+), 51 deletions(-)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 5afc7f1..b015120 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -1462,7 +1462,7 @@ VALUE.  Otherwise, return nil.
    ;; "Set" requires a variant.
    (dbus-call-method
     bus service path dbus-interface-properties
-    "Set" :timeout 500 interface property (cons :variant args))
+    "Set" :timeout 500 interface property (list :variant args))
    ;; Return VALUE.  The property could have the `:write' access type,
    ;; so we ignore errors in `dbus-get-property'.
    (dbus-ignore-errors
@@ -1543,13 +1543,15 @@ clients from discovering the still incomplete interface.
 
 \(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \
 [TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)"
-  (let ((type (when (symbolp (car args)) (pop args)))
+  (let ((signature "s") ;; FIXME: For the time being.
+        ;; Read basic type symbol.
+        (type (when (symbolp (car args)) (pop args)))
         (value (pop args))
         (emits-signal (pop args))
         (dont-register-service (pop args)))
     (unless (member access '(:read :write :readwrite))
       (signal 'wrong-type-argument (list "Access type invalid" access)))
-    (unless type
+    (unless (or type (consp value))
       (setq type
             (cond
              ((memq value '(t nil)) :boolean)
@@ -1559,6 +1561,8 @@ clients from discovering the still incomplete interface.
              ((stringp value) :string)
              (t
               (signal 'wrong-type-argument (list "Value type invalid" 
value))))))
+    (unless (consp value)
+      (setq value (list type value)))
 
     ;; Add handlers for the three property-related methods.
     (dbus-register-method
@@ -1579,12 +1583,14 @@ clients from discovering the still incomplete interface.
     (when emits-signal
       (dbus-send-signal
        bus service path dbus-interface-properties "PropertiesChanged"
-       (if (member access '(:read :readwrite))
-           `(:array
-             (:dict-entry
-              ,property
-              ,(if type (list :variant type value) (list :variant value))))
-         '(:array: :signature "{sv}"))
+       ;; changed_properties.
+       (if (eq access :write)
+           '(:array: :signature "{sv}")
+         `(:array
+           (:dict-entry
+            ,property
+            ,(if type (list :variant type value) (list :variant value)))))
+       ;; invalidated_properties.
        (if (eq access :write)
            `(:array ,property)
          '(:array))))
@@ -1595,10 +1601,7 @@ clients from discovering the still incomplete interface.
          (val
            (cons
            (list
-            nil service path
-            (cons
-             (if emits-signal (list access :emits-signal) (list access))
-             (if type (list type value) (list value))))
+            nil service path (list access emits-signal signature value))
             (dbus-get-other-registered-properties
              bus service path interface property))))
       (puthash key val dbus-registered-objects-table)
@@ -1626,16 +1629,19 @@ It will be registered for all objects created by 
`dbus-register-property'."
           `(:error ,dbus-error-unknown-property
             ,(format-message
               "No such property \"%s\" at path \"%s\"" property path)))
-         ((memq :write (car object))
+         ((eq :write (car object))
           `(:error ,dbus-error-access-denied
             ,(format-message
               "Property \"%s\" at path \"%s\" is not readable" property path)))
-        ;; Return the result.
-         (t (list :variant (cdar (last (car entry))))))))
+        ;; Return the result.  Since variant is a list, we must embed
+        ;; it into another list.
+         (t (list (if (eq :array (car (nth 3 object)))
+                      (list :variant (nth 3 object))
+                    (cons :variant (nth 3 object))))))))
 
-     ;; "Set" expects a variant.
+     ;; "Set" expects the same type as registered.
      ((string-equal method "Set")
-      (let* ((value (caar (cddr args)))
+      (let* ((value (caar (nth 2 args)))
             (entry (dbus-get-this-registered-property
                      bus service path interface property))
             (object (car (last (car entry)))))
@@ -1644,27 +1650,30 @@ It will be registered for all objects created by 
`dbus-register-property'."
           `(:error ,dbus-error-unknown-property
             ,(format-message
               "No such property \"%s\" at path \"%s\"" property path)))
-         ((memq :read (car object))
+         ((eq :read (car object))
           `(:error ,dbus-error-property-read-only
             ,(format-message
               "Property \"%s\" at path \"%s\" is not writable" property path)))
-         (t (puthash (list :property bus interface property)
+         (t (unless (consp value)
+              (setq value (list (car (nth 3 object)) value)))
+            (puthash (list :property bus interface property)
                     (cons (append
                             (butlast (car entry))
-                            ;; Reuse ACCESS und TYPE from registration.
-                           (list (list (car object) (cadr object) value)))
+                            ;; Reuse ACCESS, EMITS-SIGNAL and TYPE.
+                           (list (append (butlast object) (list value))))
                            (dbus-get-other-registered-properties
                             bus service path interface property))
                     dbus-registered-objects-table)
            ;; Send the "PropertiesChanged" signal.
-           (when (member :emits-signal (car object))
+           (when (nth 1 object)
              (dbus-send-signal
               bus service path dbus-interface-properties "PropertiesChanged"
-              (if (or (member :read (car object))
-                       (member :readwrite (car object)))
-                   `(:array (:dict-entry ,property (:variant ,value)))
-                 '(:array: :signature "{sv}"))
-               (if (eq (car object) :write)
+               ;; changed_properties.
+              (if (eq :write (car object))
+                   '(:array: :signature "{sv}")
+                 `(:array (:dict-entry ,property (:variant ,value))))
+               ;; invalidated_properties.
+               (if (eq :write (car object))
                    `(:array ,property)
                  '(:array))))
             ;; Return empty reply.
@@ -1677,18 +1686,22 @@ It will be registered for all objects created by 
`dbus-register-property'."
         (lambda (key val)
            (when (consp val)
              (dolist (item val)
-              (when (and (equal (butlast key) (list :property bus interface))
-                         (string-equal path (nth 2 item))
-                         (consp (car (last item)))
-                          (not (memq :write (caar (last item)))))
-                (push
-                 (list :dict-entry
-                       (car (last key))
-                       (cons :variant (cdar (last item))))
-                  result)))))
+               (let ((object (car (last item))))
+                (when (and (equal (butlast key) (list :property bus interface))
+                           (string-equal path (nth 2 item))
+                           (consp object)
+                            (not (eq :write (car object))))
+                  (push
+                   (list :dict-entry
+                          (car (last key))
+                          (if (eq :array (car (nth 3 object)))
+                              (list :variant (nth 3 object))
+                            (cons :variant (nth 3 object))))
+                    result))))))
         dbus-registered-objects-table)
-       ;; Return the result, or an empty array.
-       (list :array (or result '(:signature "{sv}")))))
+       ;; Return the result, or an empty array.  An array must be
+       ;; embedded in a list.
+       (list (cons :array (or result '(:signature "{sv}"))))))
 
      (t `(:error ,dbus-error-unknown-method
           ,(format-message
@@ -1896,6 +1909,8 @@ this connection to those buses."
 
 ;;; TODO:
 
+;; Support other compound properties but array.
+
 ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
 ;;   org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
 ;;
diff --git a/src/dbusbind.c b/src/dbusbind.c
index af294af..02af244 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -1824,10 +1824,11 @@ SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the 
service name as
 registered, UNAME is the corresponding unique name.  In case of
 registered methods and properties, UNAME is nil.  PATH is the object
 path of the sending object.  All of them can be nil, which means a
-wildcard then.  OBJECT is either the handler to be called when a D-Bus
-message, which matches the key criteria, arrives (TYPE `:method' and
-`:signal'), or a list containing the value of the property and its
-attributes (TYPE `:property').
+wildcard then.
+
+OBJECT is either the handler to be called when a D-Bus message, which
+matches the key criteria, arrives (TYPE `:method' and `:signal'), or a
+list (ACCESS EMITS-SIGNAL SIGNATURE VALUE) for TYPE `:property'.
 
 For entries of type `:signal', there is also a fifth element RULE,
 which keeps the match string the signal is registered with.
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 8b456c3..a8e052e 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -41,7 +41,7 @@
 (defconst dbus--test-path "/org/gnu/Emacs/TestDBus"
   "Test object path.")
 
-(defconst dbus--test-interface "org.gnu.Emacs.TestDBus"
+(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
   "Test interface.")
 
 (defun dbus--test-availability (bus)
@@ -249,6 +249,7 @@ This includes initialization and closing the bus."
     ;; Cleanup.
     (dbus-unregister-service :session dbus--test-service)))
 
+;; TODO: Test emits-signal, unregister.
 (ert-deftest dbus-test05-register-property ()
   "Check property registration for an own service."
   (skip-unless dbus--test-enabled-session-bus)
@@ -271,7 +272,7 @@ This includes initialization and closing the bus."
           (dbus-register-property
            :session dbus--test-service dbus--test-path
            dbus--test-interface property1 :read "foo")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property1)
+          `((:property :session ,dbus--test-interface ,property1)
             (,dbus--test-service ,dbus--test-path))))
         (should
          (string-equal
@@ -296,7 +297,7 @@ This includes initialization and closing the bus."
           (dbus-register-property
            :session dbus--test-service dbus--test-path
            dbus--test-interface property2 :write "bar")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property2)
+          `((:property :session ,dbus--test-interface ,property2)
             (,dbus--test-service ,dbus--test-path))))
         (should-not ;; Due to `:write' access type.
          (dbus-get-property
@@ -319,7 +320,7 @@ This includes initialization and closing the bus."
           (dbus-register-property
            :session dbus--test-service dbus--test-path
            dbus--test-interface property3 :readwrite :object-path "/baz")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property3)
+          `((:property :session ,dbus--test-interface ,property3)
             (,dbus--test-service ,dbus--test-path))))
         (should
          (string-equal
@@ -381,14 +382,14 @@ This includes initialization and closing the bus."
           (dbus-register-property
            :session dbus--test-service dbus--test-path
            dbus--test-interface property1 :readwrite "foo")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property1)
+          `((:property :session ,dbus--test-interface ,property1)
             (,dbus--test-service ,dbus--test-path))))
         (should
          (equal
           (dbus-register-property
            :session dbus--test-service dbus--test-path
            dbus--test-interface property2 :readwrite "bar")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property2)
+          `((:property :session ,dbus--test-interface ,property2)
             (,dbus--test-service ,dbus--test-path))))
         (should
          (string-equal
@@ -434,14 +435,14 @@ This includes initialization and closing the bus."
           (dbus-register-property
            :session dbus--test-service (concat dbus--test-path dbus--test-path)
            dbus--test-interface property2 :readwrite "foo")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property2)
+          `((:property :session ,dbus--test-interface ,property2)
             (,dbus--test-service ,(concat dbus--test-path dbus--test-path)))))
         (should
          (equal
           (dbus-register-property
            :session dbus--test-service (concat dbus--test-path dbus--test-path)
            dbus--test-interface property3 :readwrite "bar")
-          `((:property :session "org.gnu.Emacs.TestDBus" ,property3)
+          `((:property :session ,dbus--test-interface ,property3)
             (,dbus--test-service ,(concat dbus--test-path dbus--test-path)))))
         (should
          (string-equal