andros/emacs-gpu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Handle several children of PATH in dbus-managed-objects-handler

Browse source 
* 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.
This commit is contained in:
Michael Albinus 2020-10-29 16:56:40 +01:00
parent f5e080fb1f
commit 372739b406
3 changed files with 44 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
lisp/net/dbus.el
View file

@ -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.

18
src/dbusbind.c
View file

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

15
test/lisp/net/dbus-tests.el
View file

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