master dbd8994: D-Bus: Implement other compound types of properties

[Michael Albinus]

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

    D-Bus: Implement other compound types of properties
    
    * doc/misc/dbus.texi (Errors and Events):
    * etc/NEWS: Mention dbus-show-dbus-errors.
    
    * lisp/net/dbus.el (dbus-compound-types): New defconst.
    (dbus): New defgroup.
    (dbus-show-dbus-errors): New defcustom.
    (dbus-ignore-errors): Use it.
    (dbus-set-property): Simplify.
    (dbus-property-handler): Implement other compound types of properties.
    
    * test/lisp/net/dbus-tests.el (dbus--test-register-service)
    (dbus-test05-register-property): Extend tests.
---
 doc/misc/dbus.texi          |  9 ++---
 etc/NEWS                    | 10 +++---
 lisp/net/dbus.el            | 48 +++++++++++++++++++--------
 test/lisp/net/dbus-tests.el | 81 +++++++++++++++++++++++++++++++++++++++------
 4 files changed, 115 insertions(+), 33 deletions(-)

diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi
index 2880b7f..dcee55d 100644
--- a/doc/misc/dbus.texi
+++ b/doc/misc/dbus.texi
@@ -2031,10 +2031,11 @@ This function returns the member name of the D-Bus 
object @var{event}
 is coming from.  It is either a signal name or a method name.
 @end defun
 
-D-Bus errors are not propagated during event handling, because it is
-usually not desired.  D-Bus errors in events can be made visible by
-setting the variable @code{dbus-debug} to @code{t}.  They can also be
-handled by a hook function.
+@vindex dbus-show-dbus-errors
+D-Bus error messages are not propagated during event handling, because
+it is usually not desired.  D-Bus errors in events can be made visible
+by setting the user option @code{dbus-show-dbus-errors} to
+non-@code{nil}.  They can also be handled by a hook function.
 
 @defvar dbus-event-error-functions
 This hook variable keeps a list of functions, which are called when a
diff --git a/etc/NEWS b/etc/NEWS
index 9d26620..73d3b7f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -959,14 +959,14 @@ window after starting).  This variable defaults to nil.
 ** Miscellaneous
 
 +++
-*** New command 'submit-emacs-patch'
+*** New command 'submit-emacs-patch'.
 This works along the lines of 'report-emacs-bug', but is more geared
 towards sending a patch to the Emacs issue tracker.
 
 +++
 *** New minor mode 'button-mode'.
 This minor mode does nothing else than install 'button-buffer-map' as
-a minor mode map (which binds the TAB/S-TAB key bindings to navigate
+a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate
 to buttons), and can be used in any view-mode-like buffer that has
 buttons in it.
 
@@ -1112,9 +1112,11 @@ type symbols.
 +++
 *** In case of problems, handlers can emit proper D-Bus error messages now.
 
----
++++
 *** D-Bus errors, which have been converted from incoming D-Bus error
-messages, contain the error name of that message now.
+messages, contain the error name of that message now.  They can be
+made visible by setting user variable 'dbus-show-dbus-errors' to
+non-nil, even if protected by 'dbus-ignore-errors' otherwise.
 
 
 * New Modes and Packages in Emacs 28.1
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index b015120..fddd6df 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -55,6 +55,9 @@
 
 ;;; D-Bus constants.
 
+(defconst dbus-compound-types '(:array :variant :struct :dict-entry)
+  "D-Bus compound types, represented as list.")
+
 (defconst dbus-service-dbus "org.freedesktop.DBus"
   "The bus name used to talk to the bus itself.")
 
@@ -151,6 +154,17 @@ See URL 
`https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
 
 ;;; Default D-Bus errors.
 
+(defgroup dbus nil
+  "Elisp bindings for D-Bus."
+  :group 'comm
+  :link '(custom-manual "(dbus)Top")
+  :version "28.1")
+
+(defcustom dbus-show-dbus-errors nil
+  "Propagate incoming D-Bus error messages."
+  :version "28.1"
+  :type 'boolean)
+
 (defconst dbus-error-dbus "org.freedesktop.DBus.Error"
   "The namespace for default error names.
 See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
@@ -183,6 +197,7 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
 
 
 ;;; Emacs defaults.
+
 (defconst dbus-service-emacs "org.gnu.Emacs"
   "The well known service name of Emacs.")
 
@@ -199,11 +214,17 @@ shall be subdirectories of this path.")
 
 (defmacro dbus-ignore-errors (&rest body)
   "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
-Otherwise, return result of last form in BODY, or all other errors."
+Signals also D-Bus error when `dbus-show-dbus-errors' is non-nil
+and a D-Bus error message has arrived.  Otherwise, return result
+of last form in BODY, or all other errors."
   (declare (indent 0) (debug t))
   `(condition-case err
        (progn ,@body)
-     (dbus-error (when dbus-debug (signal (car err) (cdr err))))))
+     (dbus-error
+      (when (or dbus-debug
+                (and dbus-show-dbus-errors
+                     (= dbus-message-type-error (nth 2 last-input-event))))
+        (signal (car err) (cdr err))))))
 
 (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors)
   "Functions to be called when a D-Bus error happens in the event handler.
@@ -1454,8 +1475,9 @@ valid D-Bus value, or nil if there is no PROPERTY, or 
PROPERTY cannot be read."
 (defun dbus-set-property (bus service path interface property &rest args)
   "Set value of PROPERTY of INTERFACE to VALUE.
 It will be checked at BUS, SERVICE, PATH.  VALUE can be preceded
-by a TYPE symbol.  When the value is successfully set return
-VALUE.  Otherwise, return nil.
+by a TYPE symbol.  When the value is successfully set, and the
+property's access type is not `:write', return VALUE.  Otherwise,
+return nil.
 
 \(dbus-set-property BUS SERVICE PATH INTERFACE PROPERTY [TYPE] VALUE)"
   (dbus-ignore-errors
@@ -1463,11 +1485,9 @@ VALUE.  Otherwise, return nil.
    (dbus-call-method
     bus service path dbus-interface-properties
     "Set" :timeout 500 interface property (list :variant args))
-   ;; Return VALUE.  The property could have the `:write' access type,
-   ;; so we ignore errors in `dbus-get-property'.
-   (dbus-ignore-errors
-     (or (dbus-get-property bus service path interface property)
-         (if (symbolp (car args)) (cadr args) (car args))))))
+   ;; Return VALUE.
+   (or (dbus-get-property bus service path interface property)
+       (if (symbolp (car args)) (cadr args) (car args)))))
 
 (defun dbus-get-all-properties (bus service path interface)
   "Return all properties of INTERFACE at BUS, SERVICE, PATH.
@@ -1635,11 +1655,11 @@ It will be registered for all objects created by 
`dbus-register-property'."
               "Property \"%s\" at path \"%s\" is not readable" property path)))
         ;; Return the result.  Since variant is a list, we must embed
         ;; it into another list.
-         (t (list (if (eq :array (car (nth 3 object)))
+         (t (list (if (memq (car (nth 3 object)) dbus-compound-types)
                       (list :variant (nth 3 object))
                     (cons :variant (nth 3 object))))))))
 
-     ;; "Set" expects the same type as registered.
+     ;; "Set" expects the same type as registered.  FIXME: Implement!
      ((string-equal method "Set")
       (let* ((value (caar (nth 2 args)))
             (entry (dbus-get-this-registered-property
@@ -1694,7 +1714,7 @@ It will be registered for all objects created by 
`dbus-register-property'."
                   (push
                    (list :dict-entry
                           (car (last key))
-                          (if (eq :array (car (nth 3 object)))
+                          (if (memq (car (nth 3 object)) dbus-compound-types)
                               (list :variant (nth 3 object))
                             (cons :variant (nth 3 object))))
                     result))))))
@@ -1909,8 +1929,8 @@ this connection to those buses."
 
 ;;; TODO:
 
-;; Support other compound properties but array.
-
+;; * Check property type in org.freedesktop.DBus.Properties.Set.
+;;
 ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
 ;;   org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
 ;;
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index a8e052e..73401a8 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -25,6 +25,8 @@
 (defvar dbus-debug nil)
 (declare-function dbus-get-unique-name "dbusbind.c" (bus))
 
+(setq dbus-show-dbus-errors nil)
+
 (defconst dbus--test-enabled-session-bus
   (and (featurep 'dbusbind)
        (dbus-ignore-errors (dbus-get-unique-name :session)))
@@ -109,8 +111,16 @@
   (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))
-  (should-error (dbus-unregister-service bus dbus-service-dbus)))
+  (should
+   (equal
+    (butlast
+     (should-error (dbus-register-service bus dbus-service-dbus)))
+    `(dbus-error ,dbus-error-invalid-args)))
+  (should
+   (equal
+    (butlast
+     (should-error (dbus-unregister-service bus dbus-service-dbus)))
+    `(dbus-error ,dbus-error-invalid-args))))
 
 (ert-deftest dbus-test02-register-service-session ()
   "Check service registration at `:session' bus."
@@ -258,13 +268,8 @@ This includes initialization and closing the bus."
   (unwind-protect
       (let ((property1 "Property1")
             (property2 "Property2")
-            (property3 "Property3"))
-
-        ;; Not registered property.
-        (should-not
-         (dbus-get-property
-          :session dbus--test-service dbus--test-path
-          dbus--test-interface property1))
+            (property3 "Property3")
+            (property4 "Property4"))
 
         ;; `:read' property.
         (should
@@ -280,10 +285,22 @@ This includes initialization and closing the bus."
            :session dbus--test-service dbus--test-path
            dbus--test-interface property1)
           "foo"))
-        (should-not ;; Due to `:read' access type.
+        ;; Due to `:read' access type, we don't get a proper reply
+        ;; from `dbus-set-property'.
+        (should-not
          (dbus-set-property
           :session dbus--test-service dbus--test-path
           dbus--test-interface property1 "foofoo"))
+        (let ((dbus-show-dbus-errors t))
+          (should
+           (equal
+            ;; We don't care the error message text.
+            (butlast
+             (should-error
+              (dbus-set-property
+               :session dbus--test-service dbus--test-path
+               dbus--test-interface property1 "foofoo")))
+            `(dbus-error ,dbus-error-property-read-only))))
         (should
          (string-equal
           (dbus-get-property
@@ -299,10 +316,22 @@ This includes initialization and closing the bus."
            dbus--test-interface property2 :write "bar")
           `((:property :session ,dbus--test-interface ,property2)
             (,dbus--test-service ,dbus--test-path))))
-        (should-not ;; Due to `:write' access type.
+        ;; Due to `:write' access type, we don't get a proper reply
+        ;; from `dbus-get-property'.
+        (should-not
          (dbus-get-property
           :session dbus--test-service dbus--test-path
           dbus--test-interface property2))
+        (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 property2)))
+            `(dbus-error ,dbus-error-access-denied))))
         (should
          (string-equal
           (dbus-set-property
@@ -341,6 +370,36 @@ This includes initialization and closing the bus."
            dbus--test-interface property3)
           "/baz/baz"))
 
+        ;; Not registered property.
+        (should-not
+         (dbus-get-property
+          :session dbus--test-service dbus--test-path
+          dbus--test-interface property4))
+        (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 property4)))
+            `(dbus-error ,dbus-error-unknown-property))))
+        (should-not
+         (dbus-set-property
+          :session dbus--test-service dbus--test-path
+          dbus--test-interface property4 "foobarbaz"))
+        (let ((dbus-show-dbus-errors t))
+          (should
+           (equal
+            ;; We don't care the error message text.
+            (butlast
+             (should-error
+              (dbus-set-property
+               :session dbus--test-service dbus--test-path
+               dbus--test-interface property4 "foobarbaz")))
+            `(dbus-error ,dbus-error-unknown-property))))
+
         ;; `dbus-get-all-properties'.  We cannot retrieve a value for
         ;; the property with `:write' access type.
         (let ((result