master 9ba575a 1/2: More work on D-Bus error messages

[Michael Albinus]

branch: master
commit 9ba575aeb3a28a856f40675510c5ccfcd10ef665
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    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.
---
 lisp/net/dbus.el            |  45 +++++----
 src/dbusbind.c              |  12 ++-
 test/lisp/net/dbus-tests.el | 222 ++++++++++++++++++++++++++++++++++++++++----
 3 files changed, 237 insertions(+), 42 deletions(-)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index ad5ff8d..ba6a66d 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -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}"))))))))
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 4fce925..b637c0e 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -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.  */
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 45c9851..5e72145 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -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]."