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.
This commit is contained in:
Michael Albinus
parent
3444f397c7
commit
9ba575aeb3
3 changed files with 237 additions and 42 deletions
|
|
@ -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}"))))))))
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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]."
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue