2 files changed, 98 insertions, 44 deletions

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)))