mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-30 12:21:25 -08:00
Cleanup in dbus.el, dbus-tests.el
* lisp/net/dbus.el (dbus-error-no-reply): New defconst. (dbus-call-method): Use it. (dbus-call-method-asynchronously, dbus-register-signal): Fix docstring. (dbus-unregister-object): Obey :serial entries in `dbus-registered-objects-table'. * test/lisp/net/dbus-tests.el (dbus-test04-register-method) (dbus-test05-register-property): Extend tests.
This commit is contained in:
Michael Albinus
parent
62f239eec2
commit
2fca3015dd
2 changed files with 98 additions and 44 deletions
|
|
@ -178,6 +178,9 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
|
|||
(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs")
|
||||
"Invalid arguments passed to a method call.")
|
||||
|
||||
(defconst dbus-error-no-reply (concat dbus-error-dbus ".NoReply")
|
||||
"No reply to a message expecting one, usually means a timeout occurred.")
|
||||
|
||||
(defconst dbus-error-property-read-only
|
||||
(concat dbus-error-dbus ".PropertyReadOnly")
|
||||
"Property you tried to set is read-only.")
|
||||
|
|
@ -369,23 +372,24 @@ object is returned instead of a list containing this single Lisp object.
|
|||
|
||||
(puthash key result dbus-return-values-table)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-timeout ((if timeout (/ timeout 1000.0) 25)
|
||||
(signal 'dbus-error (list "call timed out")))
|
||||
(while (eq (car result) :pending)
|
||||
(let ((event (let ((inhibit-redisplay t) unread-command-events)
|
||||
(read-event nil nil check-interval))))
|
||||
(when event
|
||||
(if (ignore-errors (dbus-check-event event))
|
||||
(setf result (gethash key dbus-return-values-table))
|
||||
(setf unread-command-events
|
||||
(nconc unread-command-events
|
||||
(cons event nil)))))
|
||||
(when (< check-interval 1)
|
||||
(setf check-interval (* check-interval 1.05))))))
|
||||
(when (eq (car result) :error)
|
||||
(signal (cadr result) (cddr result)))
|
||||
(cdr result))
|
||||
(progn
|
||||
(with-timeout
|
||||
((if timeout (/ timeout 1000.0) 25)
|
||||
(signal 'dbus-error `(,dbus-error-no-reply "Call timed out")))
|
||||
(while (eq (car result) :pending)
|
||||
(let ((event (let ((inhibit-redisplay t) unread-command-events)
|
||||
(read-event nil nil check-interval))))
|
||||
(when event
|
||||
(if (ignore-errors (dbus-check-event event))
|
||||
(setf result (gethash key dbus-return-values-table))
|
||||
(setf unread-command-events
|
||||
(nconc unread-command-events
|
||||
(cons event nil)))))
|
||||
(when (< check-interval 1)
|
||||
(setf check-interval (* check-interval 1.05))))))
|
||||
(when (eq (car result) :error)
|
||||
(signal (cadr result) (cddr result)))
|
||||
(cdr result))
|
||||
(remhash key dbus-return-values-table))))
|
||||
|
||||
(defun dbus-call-method-asynchronously
|
||||
|
|
@ -430,7 +434,7 @@ Example:
|
|||
|
||||
\(dbus-call-method-asynchronously
|
||||
:system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
|
||||
\"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message
|
||||
\"org.freedesktop.Hal.Device\" \"GetPropertyString\" #\\='message
|
||||
\"system.kernel.machine\")
|
||||
|
||||
-| i686
|
||||
|
|
@ -710,7 +714,7 @@ Example:
|
|||
|
||||
\(dbus-register-signal
|
||||
:system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
|
||||
\"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler)
|
||||
\"org.freedesktop.Hal.Manager\" \"DeviceAdded\" #\\='my-signal-handler)
|
||||
|
||||
=> ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\")
|
||||
(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler))
|
||||
|
|
@ -922,16 +926,19 @@ association to the service from D-Bus."
|
|||
(progn
|
||||
(maphash
|
||||
(lambda (k v)
|
||||
(dolist (e v)
|
||||
(ignore-errors
|
||||
(and
|
||||
;; Bus.
|
||||
(equal bus (cadr k))
|
||||
;; Service.
|
||||
(string-equal service (cadr e))
|
||||
;; Non-empty object path.
|
||||
(nth 2 e)
|
||||
(throw :found t)))))
|
||||
(when (consp v)
|
||||
(dolist (e v)
|
||||
(ignore-errors
|
||||
(and
|
||||
;; Type.
|
||||
(eq type (car k))
|
||||
;; Bus.
|
||||
(equal bus (cadr k))
|
||||
;; Service.
|
||||
(string-equal service (cadr e))
|
||||
;; Non-empty object path.
|
||||
(nth 2 e)
|
||||
(throw :found t))))))
|
||||
dbus-registered-objects-table)
|
||||
nil))))
|
||||
(dbus-unregister-service bus service))
|
||||
|
|
@ -1934,6 +1941,8 @@ this connection to those buses."
|
|||
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
|
||||
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
|
||||
;;
|
||||
;; * Implement org.freedesktop.DBus.Monitoring.BecomeMonitor.
|
||||
;;
|
||||
;; * Cache introspection data.
|
||||
;;
|
||||
;; * Run handlers in own threads.
|
||||
|
|
|
|||
|
|
@ -214,28 +214,39 @@ This includes initialization and closing the bus."
|
|||
(dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
|
||||
|
||||
(unwind-protect
|
||||
(let ((method "Method")
|
||||
(handler #'dbus--test-method-handler))
|
||||
(let ((method1 "Method1")
|
||||
(method2 "Method2")
|
||||
(handler #'dbus--test-method-handler)
|
||||
registered)
|
||||
|
||||
(should
|
||||
(equal
|
||||
(setq
|
||||
registered
|
||||
(dbus-register-method
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface method1 handler))
|
||||
`((:method :session ,dbus--test-interface ,method1)
|
||||
(,dbus--test-service ,dbus--test-path ,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-interface method2 handler)
|
||||
`((:method :session ,dbus--test-interface ,method2)
|
||||
(,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))
|
||||
dbus--test-interface method1))
|
||||
;; One argument, returns the argument.
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-call-method
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface method "foo")
|
||||
dbus--test-interface method1 "foo")
|
||||
"foo"))
|
||||
;; Two arguments, D-Bus error activated as `(:error ...)' list.
|
||||
(should
|
||||
|
|
@ -243,7 +254,7 @@ This includes initialization and closing the bus."
|
|||
(should-error
|
||||
(dbus-call-method
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface method "foo" "bar"))
|
||||
dbus--test-interface method1 "foo" "bar"))
|
||||
`(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)")))
|
||||
;; Three arguments, D-Bus error activated by `dbus-error' signal.
|
||||
(should
|
||||
|
|
@ -251,15 +262,28 @@ This includes initialization and closing the bus."
|
|||
(should-error
|
||||
(dbus-call-method
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface method "foo" "bar" "baz"))
|
||||
dbus--test-interface method1 "foo" "bar" "baz"))
|
||||
`(dbus-error
|
||||
,dbus-error-failed
|
||||
"D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))))
|
||||
"D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\"")))
|
||||
|
||||
;; Unregister method.
|
||||
(should (dbus-unregister-object registered))
|
||||
(should-not (dbus-unregister-object registered))
|
||||
(should
|
||||
(equal
|
||||
;; We don't care the error message text.
|
||||
(butlast
|
||||
(should-error
|
||||
(dbus-call-method
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface method1 :timeout 10 "foo")))
|
||||
`(dbus-error ,dbus-error-no-reply))))
|
||||
|
||||
;; Cleanup.
|
||||
(dbus-unregister-service :session dbus--test-service)))
|
||||
|
||||
;; TODO: Test emits-signal, unregister.
|
||||
;; TODO: Test emits-signal.
|
||||
(ert-deftest dbus-test05-register-property ()
|
||||
"Check property registration for an own service."
|
||||
(skip-unless dbus--test-enabled-session-bus)
|
||||
|
|
@ -269,14 +293,17 @@ This includes initialization and closing the bus."
|
|||
(let ((property1 "Property1")
|
||||
(property2 "Property2")
|
||||
(property3 "Property3")
|
||||
(property4 "Property4"))
|
||||
(property4 "Property4")
|
||||
registered)
|
||||
|
||||
;; `:read' property.
|
||||
(should
|
||||
(equal
|
||||
(dbus-register-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1 :read "foo")
|
||||
(setq
|
||||
registered
|
||||
(dbus-register-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1 :read "foo"))
|
||||
`((:property :session ,dbus--test-interface ,property1)
|
||||
(,dbus--test-service ,dbus--test-path))))
|
||||
(should
|
||||
|
|
@ -419,7 +446,25 @@ This includes initialization and closing the bus."
|
|||
(should (setq result (cadr (assoc dbus--test-interface result))))
|
||||
(should (string-equal (cdr (assoc property1 result)) "foo"))
|
||||
(should (string-equal (cdr (assoc property3 result)) "/baz/baz"))
|
||||
(should-not (assoc property2 result))))
|
||||
(should-not (assoc property2 result)))
|
||||
|
||||
;; Unregister property.
|
||||
(should (dbus-unregister-object registered))
|
||||
(should-not (dbus-unregister-object registered))
|
||||
(should-not
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1))
|
||||
(let ((dbus-show-dbus-errors t))
|
||||
(should
|
||||
(equal
|
||||
;; We don't care the error message text.
|
||||
(butlast
|
||||
(should-error
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1)))
|
||||
`(dbus-error ,dbus-error-unknown-property)))))
|
||||
|
||||
;; Cleanup.
|
||||
(dbus-unregister-service :session dbus--test-service)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue