From 6d6ef7b1d00696e38080b8b158d8b9b196bc8bcb Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 17 Sep 2020 17:13:55 +0200 Subject: [PATCH] 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 fa910643a35..aab08dd0d42 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 d470bca226a..18c2a2ad6d2 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") -- 2.39.5