From: Michael Albinus Date: Sat, 12 Sep 2020 17:33:44 +0000 (+0200) Subject: Cleanup in dbus.el, dbus-tests.el X-Git-Tag: emacs-28.0.90~6105 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2fca3015ddcbdfee524ff58bb4ce31bf1f91a3c4;p=emacs.git 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. --- diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index fddd6df963b..d4e6cb943df 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -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. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 73401a8c921..d470bca226a 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -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)))