From: Michael Albinus Date: Thu, 29 Oct 2020 15:56:40 +0000 (+0100) Subject: Handle several children of PATH in dbus-managed-objects-handler X-Git-Tag: emacs-28.0.90~5355 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=372739b4069dee1911606817cf962b6ff8b49bac;p=emacs.git 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. --- diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index bb2420e1f49..8b40808005b 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 7904606d39e..dc4db5c8513 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 3bb2264defb..d630f80706e 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 @@ -1911,13 +1912,6 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." `((:property :session ,dbus--test-interface "Property1") (,dbus--test-service ,path1)))) - (should - (equal - (dbus-get-property - :session dbus--test-service path1 dbus--test-interface - "Property1") - "Simple string one.")) - (should (equal (dbus-register-property @@ -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)))