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.

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 5afc7f111f87eadc8bd97e70465d62272a6353e9..b0151200ff9e8d59763c8a1e02f78bd9c60fbe00 100644 (file)
--- 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 af294afe92c67a67cbd557a08efcc907d7f30776..02af244ac38bc570698fbdbac80177cbc55aab1c 100644 (file)
--- 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 8b456c3551fab900475969cfe4b14a2f23e1185a..a8e052efbef36659e8ead3953268e446fbcd7097 100644 (file)
--- 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