`: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
(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
(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.
(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.
(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)
`(: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)))
`(: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.
(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}"))))))))
(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))
(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))
(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"))
(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 ()
(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))
"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]."