From 9ba575aeb3a28a856f40675510c5ccfcd10ef665 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 6 Sep 2020 20:45:29 +0200 Subject: [PATCH] More work on D-Bus error messages * lisp/net/dbus.el (dbus-get-property): Adapt docstring. (dbus-set-property): Handle case of `:write' access type. (dbus-get-other-registered-properties): Rename from `dbus-get-other-registered-property'. (dbus-property-handler): Fix thinkos. * src/dbusbind.c (xd_read_message_1): Add error_name to event args in case of DBUS_MESSAGE_TYPE_ERROR. * test/lisp/net/dbus-tests.el (dbus--test-enabled-session-bus) (dbus--test-enabled-system-bus): Make them defconst. (dbus--test-service, dbus--test-path, dbus--test-interface): New defconst. Replace all occurences of `dbus-service-emacs' by `dbus--test-service'. (dbus--test-method-handler): New defun. (dbus-test04-register-method, dbus-test05-register-property): New tests. --- lisp/net/dbus.el | 45 +++++--- src/dbusbind.c | 12 +- test/lisp/net/dbus-tests.el | 222 +++++++++++++++++++++++++++++++++--- 3 files changed, 237 insertions(+), 42 deletions(-) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index ad5ff8d450e..ba6a66d79c7 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -565,8 +565,9 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method bus service nil dbus-interface-peer "Ping" - #'dbus-peer-handler 'dont-register) + (dbus-register-method + bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method @@ -1423,7 +1424,7 @@ be \"out\"." (defun dbus-get-property (bus service path interface property) "Return the value of PROPERTY of INTERFACE. It will be checked at BUS, SERVICE, PATH. The result can be any -valid D-Bus value, or nil if there is no PROPERTY." +valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read." (dbus-ignore-errors ;; "Get" returns a variant, so we must use the `car'. (car @@ -1440,8 +1441,11 @@ successfully set return VALUE. Otherwise, return nil." (dbus-call-method bus service path dbus-interface-properties "Set" :timeout 500 interface property (list :variant value)) - ;; Return VALUE. - (dbus-get-property bus service path interface property))) + ;; Return VALUE. The property could have the `:write' access type, + ;; so we ignore errors in `dbus-get-property'. + (or + (dbus-ignore-errors (dbus-get-property bus service path interface property)) + value))) (defun dbus-get-all-properties (bus service path interface) "Return all properties of INTERFACE at BUS, SERVICE, PATH. @@ -1465,7 +1469,8 @@ Filter out not matching PATH." (gethash (list :property bus interface property) dbus-registered-objects-table))) -(defun dbus-get-other-registered-property (bus _service path interface property) +(defun dbus-get-other-registered-properties + (bus _service path interface property) "Return PROPERTY entry of `dbus-registered-objects-table'. Filter out matching PATH." ;; Remove matching entries. @@ -1551,7 +1556,7 @@ clients from discovering the still incomplete interface." (cons (if emits-signal (list access :emits-signal) (list access)) value)) - (dbus-get-other-registered-property + (dbus-get-other-registered-properties bus service path interface property)))) (puthash key val dbus-registered-objects-table) @@ -1578,7 +1583,7 @@ It will be registered for all objects created by `dbus-register-property'." `(:error ,dbus-error-invalid-args ,(format-message "No such property \"%s\" at path \"%s\"" property path))) - ((eq (car object) :write) + ((memq :write (car object)) `(:error ,dbus-error-access-denied ,(format-message "Property \"%s\" at path \"%s\" is not readable" property path))) @@ -1596,14 +1601,14 @@ It will be registered for all objects created by `dbus-register-property'." `(:error ,dbus-error-invalid-args ,(format-message "No such property \"%s\" at path \"%s\"" property path))) - ((eq (car object) :read) + ((memq :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) (cons (append (butlast (car entry)) (list (cons (car object) value))) - (dbus-get-other-registered-property + (dbus-get-other-registered-properties bus service path interface property)) dbus-registered-objects-table) ;; Send the "PropertiesChanged" signal. @@ -1625,15 +1630,17 @@ It will be registered for all objects created by `dbus-register-property'." (let (result) (maphash (lambda (key val) - (dolist (item val) - (when (and (equal (butlast key) (list :property bus interface)) - (string-equal path (nth 2 item)) - (not (functionp (car (last item))))) - (push - (list :dict-entry - (car (last key)) - (list :variant (cdar (last item)))) - result)))) + (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)) + (list :variant (cdar (last item)))) + result))))) dbus-registered-objects-table) ;; Return the result, or an empty array. (list :array (or result '(:signature "{sv}")))))))) diff --git a/src/dbusbind.c b/src/dbusbind.c index 4fce92521a4..b637c0e58aa 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -1508,7 +1508,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) int mtype; dbus_uint32_t serial; unsigned int ui_serial; - const char *uname, *path, *interface, *member; + const char *uname, *path, *interface, *member, *error_name; dmessage = dbus_connection_pop_message (connection); @@ -1544,10 +1544,11 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) path = dbus_message_get_path (dmessage); interface = dbus_message_get_interface (dmessage); member = dbus_message_get_member (dmessage); + error_name =dbus_message_get_error_name (dmessage); - XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s", + XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s", XD_MESSAGE_TYPE_TO_STRING (mtype), - ui_serial, uname, path, interface, member, + ui_serial, uname, path, interface, member, error_name, XD_OBJECT_TO_STRING (args)); if (mtype == DBUS_MESSAGE_TYPE_INVALID) @@ -1571,7 +1572,10 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) EVENT_INIT (event); event.kind = DBUS_EVENT; event.frame_or_window = Qnil; - event.arg = Fcons (value, args); + event.arg = + Fcons (value, + (mtype == DBUS_MESSAGE_TYPE_ERROR) + ? (Fcons (build_string (error_name), args)) : args); } else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 45c98513653..5e721459971 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -25,16 +25,25 @@ (defvar dbus-debug nil) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) -(defvar dbus--test-enabled-session-bus +(defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :session))) "Check, whether we are registered at the session bus.") -(defvar dbus--test-enabled-system-bus +(defconst dbus--test-enabled-system-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :system))) "Check, whether we are registered at the system bus.") +(defconst dbus--test-service "org.gnu.Emacs.TestDBus" + "Test service.") + +(defconst dbus--test-path "/org/gnu/Emacs/TestDBus" + "Test object path.") + +(defconst dbus--test-interface "org.gnu.Emacs.TestDBus" + "Test interface.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -85,19 +94,19 @@ (defun dbus--test-register-service (bus) "Check service registration at BUS." ;; Cleanup. - (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + (dbus-ignore-errors (dbus-unregister-service bus dbus--test-service)) ;; Register an own service. - (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :primary-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :already-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) ;; Unregister the service. - (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :released)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :non-existent)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) ;; `dbus-service-dbus' is reserved for the BUS itself. (should-error (dbus-register-service bus dbus-service-dbus)) @@ -106,7 +115,7 @@ (ert-deftest dbus-test02-register-service-session () "Check service registration at `:session' bus." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs))) + (dbus-register-service :session dbus--test-service))) (dbus--test-register-service :session) (let ((service "org.freedesktop.Notifications")) @@ -124,7 +133,7 @@ (ert-deftest dbus-test02-register-service-system () "Check service registration at `:system' bus." (skip-unless (and dbus--test-enabled-system-bus - (dbus-register-service :system dbus-service-emacs))) + (dbus-register-service :system dbus--test-service))) (dbus--test-register-service :system)) (ert-deftest dbus-test02-register-service-own-bus () @@ -148,7 +157,7 @@ This includes initialization and closing the bus." (featurep 'dbusbind) (dbus-init-bus bus) (dbus-get-unique-name bus) - (dbus-register-service bus dbus-service-emacs)))) + (dbus-register-service bus dbus--test-service)))) ;; Run the test. (dbus--test-register-service bus)) @@ -159,19 +168,194 @@ This includes initialization and closing the bus." "Check `dbus-interface-peer' methods." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs) + (dbus-register-service :session dbus--test-service) ;; "GetMachineId" is not implemented (yet). When it returns a ;; value, another D-Bus client like dbus-monitor is reacting ;; on `dbus-interface-peer'. We cannot test then. (not (dbus-ignore-errors (dbus-call-method - :session dbus-service-emacs dbus-path-dbus + :session dbus--test-service dbus-path-dbus dbus-interface-peer "GetMachineId" :timeout 100))))) - (should (dbus-ping :session dbus-service-emacs 100)) - (dbus-unregister-service :session dbus-service-emacs) - (should-not (dbus-ping :session dbus-service-emacs 100))) + (should (dbus-ping :session dbus--test-service 100)) + (dbus-unregister-service :session dbus--test-service) + (should-not (dbus-ping :session dbus--test-service 100))) + +(defun dbus--test-method-handler (&rest args) + "Method handler for `dbus-test04-register-method'." + (cond + ;; No argument. + ((null args) + :ignore) + ;; One argument. + ((= 1 (length args)) + (car args)) + ;; Two arguments. + ((= 2 (length args)) + `(:error ,dbus-error-invalid-args + ,(format-message "Wrong arguments %s" args))) + ;; More than two arguments. + (t (signal 'dbus-error (cons "D-Bus signal" args))))) + +(ert-deftest dbus-test04-register-method () + "Check method 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 ((method "Method") + (handler #'dbus--test-method-handler)) + + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method handler) + `((:method :session ,dbus--test-interface ,method) + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; No argument, returns nil. + (should-not + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method)) + ;; One argument, returns the argument. + (should + (string-equal + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method "foo") + "foo")) + ;; Two arguments, D-Bus error activated as `(:error ...)' list. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method "foo" "bar")) + `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) + ;; Three arguments, D-Bus error activated by `dbus-error' signal. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method "foo" "bar" "baz")) + `(dbus-error + ,dbus-error-failed + "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\"")))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test05-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)) + + (unwind-protect + (let ((property1 "Property1") + (property2 "Property2") + (property3 "Property3")) + + ;; `:read' property. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 :read "foo") + `((:property :session "org.gnu.Emacs.TestDBus" ,property1) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + (should-not ;; Due to `:read' access type. + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 "foofoo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + + ;; `:write' property. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 :write "bar") + `((:property :session "org.gnu.Emacs.TestDBus" ,property2) + (,dbus--test-service ,dbus--test-path)))) + (should-not ;; Due to `:write' access type. + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2)) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 "barbar") + "barbar")) + (should-not ;; Due to `:write' access type. + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2)) + + ;; `:readwrite' property. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 :readwrite "baz") + `((:property :session "org.gnu.Emacs.TestDBus" ,property3) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "baz")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 "bazbaz") + "bazbaz")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "bazbaz")) + + ;; `dbus-get-all-properties'. We cannot retrieve a value for + ;; the property with `:write' access type. + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (string-equal (cdr (assoc property1 result)) "foo")) + (should (string-equal (cdr (assoc property3 result)) "bazbaz")) + (should-not (assoc property2 result)))) + + ;; FIXME: This is wrong! The properties are missing. + ;; (should + ;; (equal + ;; (dbus-get-all-managed-objects + ;; :session dbus--test-service dbus--test-path) + ;; `((,dbus--test-path + ;; ((,dbus-interface-peer) + ;; (,dbus-interface-objectmanager) + ;; (,dbus-interface-properties))))))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." -- 2.39.5