master 372739b 3/3: Handle several children of PATH in dbus-managed-objects-handler

[Michael Albinus]

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

    Handle several children of PATH in dbus-managed-objects-handler
    
    * lisp/net/dbus.el (dbus-managed-objects-handler): Handle several
    children of PATH.  (Bug#44298)
    
    * src/dbusbind.c (xd_signature, xd_append_arg): Check object path.
    
    * test/lisp/net/dbus-tests.el (dbus-test09-get-managed-objects):
    Tag it :expensive-test.  Remove superfluous check.
---
 lisp/net/dbus.el            | 51 ++++++++++++++++++++++++---------------------
 src/dbusbind.c              | 18 ++++++++++------
 test/lisp/net/dbus-tests.el | 15 +++++--------
 3 files changed, 44 insertions(+), 40 deletions(-)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index bb2420e..8b40808 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -1942,35 +1942,38 @@ It will be registered for all objects created by 
`dbus-register-service'."
       ;; Check for object path wildcard interfaces.
       (maphash
        (lambda (key val)
-        (when (and (equal (butlast key 2) (list :property bus))
-                   (null (nth 2 (car-safe val))))
-          (push (nth 2 key) interfaces)))
+        (when (equal (butlast key 2) (list :property bus))
+           (dolist (item val)
+            (unless (nth 2 item) ; Path.
+              (push (nth 2 key) interfaces)))))
        dbus-registered-objects-table)
 
       ;; Check all registered object paths.
       (maphash
        (lambda (key val)
-        (let ((object (or (nth 2 (car-safe val)) "")))
-          (when (and (equal (butlast key 2) (list :property bus))
-                     (string-prefix-p path object))
-            (dolist (interface (cons (nth 2 key) interfaces))
-              (unless (assoc object result)
-                (push (list object) result))
-              (unless (assoc interface (cdr (assoc object result)))
-                (setcdr
-                 (assoc object result)
-                 (append
-                  (list (cons
-                   interface
-                   ;; We simulate "org.freedesktop.DBus.Properties.GetAll"
-                   ;; by using an appropriate D-Bus event.
-                   (let ((last-input-event
-                          (append
-                           (butlast last-input-event 4)
-                           (list object dbus-interface-properties
-                                  "GetAll" #'dbus-property-handler))))
-                     (dbus-property-handler interface))))
-                  (cdr (assoc object result)))))))))
+        (when (equal (butlast key 2) (list :property bus))
+           (dolist (item val)
+            (let ((object (or (nth 2 item) ""))) ; Path.
+              (when (string-prefix-p path object)
+                (dolist (interface (cons (nth 2 key) (delete-dups interfaces)))
+                  (unless (assoc object result)
+                    (push (list object) result))
+                  (unless (assoc interface (cdr (assoc object result)))
+                    (setcdr
+                     (assoc object result)
+                     (append
+                      (list (cons
+                             interface
+                             ;; We simulate
+                             ;; "org.freedesktop.DBus.Properties.GetAll"
+                             ;; by using an appropriate D-Bus event.
+                             (let ((last-input-event
+                                    (append
+                                     (butlast last-input-event 4)
+                                     (list object dbus-interface-properties
+                                            "GetAll" 
#'dbus-property-handler))))
+                               (dbus-property-handler interface))))
+                      (cdr (assoc object result)))))))))))
        dbus-registered-objects-table)
 
       ;; Return the result, or an empty array.
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 7904606..dc4db5c 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -409,9 +409,12 @@ xd_signature (char *signature, int dtype, int parent_type, 
Lisp_Object object)
     case DBUS_TYPE_STRING:
     case DBUS_TYPE_OBJECT_PATH:
     case DBUS_TYPE_SIGNATURE:
-      /* We dont check the syntax of object path and signature.  This
-        will be done by libdbus.  */
-      CHECK_STRING (object);
+      /* We dont check the syntax of signature.  This will be done by
+        libdbus.  */
+      if (dtype == DBUS_TYPE_OBJECT_PATH)
+       XD_DBUS_VALIDATE_PATH (object)
+      else
+       CHECK_STRING (object);
       sprintf (signature, "%c", dtype);
       break;
 
@@ -732,9 +735,12 @@ xd_append_arg (int dtype, Lisp_Object object, 
DBusMessageIter *iter)
       case DBUS_TYPE_STRING:
       case DBUS_TYPE_OBJECT_PATH:
       case DBUS_TYPE_SIGNATURE:
-       /* We dont check the syntax of object path and signature.
-          This will be done by libdbus.  */
-       CHECK_STRING (object);
+       /* We dont check the syntax of signature.  This will be done
+          by libdbus.  */
+       if (dtype == DBUS_TYPE_OBJECT_PATH)
+         XD_DBUS_VALIDATE_PATH (object)
+       else
+         CHECK_STRING (object);
        {
          /* We need to send a valid UTF-8 string.  We could encode `object'
             but by not encoding it, we guarantee it's valid utf-8, even if
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 3bb2264..d630f80 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -125,7 +125,6 @@
   (should-error
    (dbus-check-arguments :session dbus--test-service :object-path)
    :type 'wrong-type-argument)
-  ;; Raises an error on stderr.
   (should-error
    (dbus-check-arguments :session dbus--test-service :object-path "string")
    :type 'dbus-error)
@@ -1891,6 +1890,7 @@ The argument EXPECTED-ARGS is a list of expected 
arguments for the method."
 
 (ert-deftest dbus-test09-get-managed-objects ()
   "Check `dbus-get-all-managed-objects'."
+  :tags '(:expensive-test)
   (skip-unless dbus--test-enabled-session-bus)
   (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
   (dbus-register-service :session dbus--test-service)
@@ -1901,7 +1901,8 @@ The argument EXPECTED-ARGS is a list of expected 
arguments for the method."
             (path3 (concat dbus--test-path "/path3")))
 
         (should-not
-         (dbus-get-all-managed-objects :session dbus--test-service 
dbus--test-path))
+         (dbus-get-all-managed-objects
+          :session dbus--test-service dbus--test-path))
 
         (should
          (equal
@@ -1913,13 +1914,6 @@ The argument EXPECTED-ARGS is a list of expected 
arguments for the method."
 
         (should
          (equal
-          (dbus-get-property
-           :session dbus--test-service path1 dbus--test-interface
-           "Property1")
-          "Simple string one."))
-
-        (should
-         (equal
           (dbus-register-property
            :session dbus--test-service path2 dbus--test-interface
            "Property1" :readwrite "Simple string two.")
@@ -1955,7 +1949,8 @@ The argument EXPECTED-ARGS is a list of expected 
arguments for the method."
            "Property1")
           "Simple string three."))
 
-        (let ((result (dbus-get-all-managed-objects :session 
dbus--test-service dbus--test-path)))
+        (let ((result (dbus-get-all-managed-objects
+                       :session dbus--test-service dbus--test-path)))
           (should
            (= 3 (length result)))