master 6d6ef7b: Work on D-Bus properties etc

[Michael Albinus]

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

    Work on D-Bus properties etc
    
    * lisp/net/dbus.el (seq, subr-x): Require.
    (dbus-error-disconnected, dbus-error-service-unknown): New defconst.
    (dbus-set-property, dbus-register-property): Use `keywordp'.  Fix
    proper value sending a signal.
    
    * test/lisp/net/dbus-tests.el (dbus-test04-register-method):
    Extend test.
    (dbus--test-signal-received): New defvar.
    (dbus--test-signal-handler): New defun.
    (dbus-test05-register-signal)
    (dbus-test06-register-property-emits-signal): New tests.
    (dbus-test06-register-property)
    (dbus-test06-register-property-several-paths): Rename tests.
---
 lisp/net/dbus.el            |  23 +++++---
 test/lisp/net/dbus-tests.el | 136 +++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 147 insertions(+), 12 deletions(-)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index fa91064..aab08dd 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -51,6 +51,8 @@
 (unless (boundp 'dbus-debug)
   (defvar dbus-debug nil))
 
+(require 'seq)
+(require 'subr-x)
 (require 'xml)
 
 ;;; D-Bus constants.
@@ -169,12 +171,15 @@ See URL 
`https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
   "The namespace for default error names.
 See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
 
-(defconst dbus-error-failed (concat dbus-error-dbus ".Failed")
-  "A generic error; \"something went wrong\" - see the error message for 
more.")
-
 (defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied")
   "Security restrictions don't allow doing what you're trying to do.")
 
+(defconst dbus-error-disconnected (concat dbus-error-dbus ".Disconnected")
+  "The connection is disconnected and you're trying to use it.")
+
+(defconst dbus-error-failed (concat dbus-error-dbus ".Failed")
+  "A generic error; \"something went wrong\" - see the error message for 
more.")
+
 (defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs")
   "Invalid arguments passed to a method call.")
 
@@ -185,6 +190,9 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
   (concat dbus-error-dbus ".PropertyReadOnly")
   "Property you tried to set is read-only.")
 
+(defconst dbus-error-service-unknown (concat dbus-error-dbus ".ServiceUnknown")
+  "The bus doesn't know how to launch a service to supply the bus name you 
wanted.")
+
 (defconst dbus-error-unknown-interface
   (concat dbus-error-dbus ".UnknownInterface")
   "Interface you invoked a method on isn't known by the object.")
@@ -1526,7 +1534,7 @@ return nil.
     "Set" :timeout 500 interface property (cons :variant args))
    ;; Return VALUE.
    (or (dbus-get-property bus service path interface property)
-       (if (symbolp (car args)) (cadr args) (car args)))))
+       (if (keywordp (car args)) (cadr args) (car args)))))
 
 (defun dbus-get-all-properties (bus service path interface)
   "Return all properties of INTERFACE at BUS, SERVICE, PATH.
@@ -1603,7 +1611,7 @@ 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 (;; Read basic type symbol.
-        (type (when (symbolp (car args)) (pop args)))
+        (type (when (keywordp (car args)) (pop args)))
         (value (pop args))
         (emits-signal (pop args))
         (dont-register-service (pop args)))
@@ -1646,10 +1654,7 @@ clients from discovering the still incomplete interface.
        ;; changed_properties.
        (if (eq access :write)
            '(:array: :signature "{sv}")
-         `(:array
-           (:dict-entry
-            ,property
-            ,(if type (list :variant type value) (list :variant value)))))
+         `(:array (:dict-entry ,property ,value)))
        ;; invalidated_properties.
        (if (eq access :write)
            `(:array ,property)
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index d470bca..18c2a2a 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -219,6 +219,17 @@ This includes initialization and closing the bus."
             (handler #'dbus--test-method-handler)
             registered)
 
+        ;; The service is not registered yet.
+        (should
+         (equal
+          (should-error
+           (dbus-call-method
+            :session dbus--test-service dbus--test-path
+            dbus--test-interface method1 :timeout 10 "foo"))
+          `(dbus-error
+            ,dbus-error-service-unknown "The name is not activatable")))
+
+        ;; Register.
         (should
          (equal
           (setq
@@ -283,8 +294,61 @@ This includes initialization and closing the bus."
     ;; Cleanup.
     (dbus-unregister-service :session dbus--test-service)))
 
-;; TODO: Test emits-signal.
-(ert-deftest dbus-test05-register-property ()
+(defvar dbus--test-signal-received nil
+  "Received signal value in `dbus--test-signal-handler'.")
+
+(defun dbus--test-signal-handler (&rest args)
+  "Signal handler for `dbus-test05-register-signal'."
+  (setq dbus--test-signal-received args))
+
+(ert-deftest dbus-test05-register-signal ()
+  "Check signal registration for an own service."
+  (skip-unless dbus--test-enabled-session-bus)
+  (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
+
+  (unwind-protect
+      (let ((member "Member")
+            (handler #'dbus--test-signal-handler)
+            registered)
+
+        ;; Register signal handler.
+        (should
+         (equal
+          (setq
+           registered
+           (dbus-register-signal
+            :session dbus--test-service dbus--test-path
+            dbus--test-interface member handler))
+          `((:signal :session ,dbus--test-interface ,member)
+            (,dbus--test-service ,dbus--test-path ,handler))))
+
+        ;; Send one argument, basic type.
+        (setq dbus--test-signal-received nil)
+        (dbus-send-signal
+         :session dbus--test-service dbus--test-path
+         dbus--test-interface member "foo")
+        (while (null dbus--test-signal-received)
+          (read-event nil nil 0.1))
+        (should (equal dbus--test-signal-received '("foo")))
+
+        ;; Send two arguments, compound types.
+        (setq dbus--test-signal-received nil)
+        (dbus-send-signal
+         :session dbus--test-service dbus--test-path
+         dbus--test-interface member
+         '(:array :byte 1 :byte 2 :byte 3) '(:variant :string "bar"))
+        (while (null dbus--test-signal-received)
+          (read-event nil nil 0.1))
+        (should (equal dbus--test-signal-received '((1 2 3) ("bar"))))
+
+        ;; Unregister signal.
+        (should (dbus-unregister-object registered))
+        (should-not (dbus-unregister-object registered)))
+
+    ;; Cleanup.
+    (dbus-unregister-service :session dbus--test-service)))
+
+(ert-deftest dbus-test06-register-property ()
   "Check property registration for an own service."
   (skip-unless dbus--test-enabled-session-bus)
   (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
@@ -470,7 +534,7 @@ This includes initialization and closing the bus."
     (dbus-unregister-service :session dbus--test-service)))
 
 ;; The following test is inspired by Bug#43146.
-(ert-deftest dbus-test05-register-property-several-paths ()
+(ert-deftest dbus-test06-register-property-several-paths ()
   "Check property registration for an own service at several paths."
   (skip-unless dbus--test-enabled-session-bus)
   (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
@@ -625,6 +689,72 @@ This includes initialization and closing the bus."
     ;; Cleanup.
     (dbus-unregister-service :session dbus--test-service)))
 
+(ert-deftest dbus-test06-register-property-emits-signal ()
+  "Check property registration for an own service, including signalling."
+  (skip-unless dbus--test-enabled-session-bus)
+  (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
+
+  (unwind-protect
+      (let ((property "Property")
+            (handler #'dbus--test-signal-handler))
+
+        ;; Register signal handler.
+        (should
+         (equal
+          (dbus-register-signal
+           :session dbus--test-service dbus--test-path
+           dbus-interface-properties "PropertiesChanged" handler)
+          `((:signal :session ,dbus-interface-properties "PropertiesChanged")
+            (,dbus--test-service ,dbus--test-path ,handler))))
+
+        ;; Register property.
+        (setq dbus--test-signal-received nil)
+        (should
+         (equal
+          (dbus-register-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface property :readwrite "foo" 'emits-signal)
+          `((:property :session ,dbus--test-interface ,property)
+            (,dbus--test-service ,dbus--test-path))))
+        (while (null dbus--test-signal-received)
+          (read-event nil nil 0.1))
+        ;; It returns two arguments, "changed_properties" (an array of
+        ;; dict entries) and "invalidated_properties" (an array of
+        ;; strings).
+        (should (equal dbus--test-signal-received `(((,property ("foo"))) ())))
+
+        (should
+         (equal
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface property)
+          "foo"))
+
+        ;; Set property.  The new value shall be signalled.
+        (setq dbus--test-signal-received nil)
+        (should
+         (equal
+          (dbus-set-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface property
+           '(:array :byte 1 :byte 2 :byte 3))
+          '(1 2 3)))
+        (while (null dbus--test-signal-received)
+          (read-event nil nil 0.1))
+        (should
+         (equal
+          dbus--test-signal-received `(((,property ((((1) (2) (3)))))) ())))
+
+        (should
+         (equal
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface property)
+          '(1 2 3))))
+
+    ;; Cleanup.
+    (dbus-unregister-service :session dbus--test-service)))
+
 (defun dbus-test-all (&optional interactive)
   "Run all tests for \\[dbus]."
   (interactive "p")