procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement D-Bus properties with compound type.

Browse source 
* lisp/net/dbus.el (dbus-set-property): Fix thinko.
(dbus-register-property, dbus-property-handler): Support compound
properties.

* src/dbusbind.c (dbus-registered-objects-table): Fix docstring.

* test/lisp/net/dbus-tests.el (dbus--test-interface): Make it
different to `dbus--test-service'.
(dbus-test05-register-property)
(dbus-test05-register-property-several-paths): Adapt tests.
This commit is contained in:
Michael Albinus 2020-09-10 18:49:22 +02:00
parent 70a8d06fe1
commit be5047c0d2
3 changed files with 68 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

93
lisp/net/dbus.el
View file

@ -1462,7 +1462,7 @@ VALUE. Otherwise, return nil.
;; "Set" requires a variant.
(dbus-call-method
bus service path dbus-interface-properties
"Set" :timeout 500 interface property (cons :variant args))
"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
@ -1543,13 +1543,15 @@ clients from discovering the still incomplete interface.
\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \
[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)"
(let ((type (when (symbolp (car args)) (pop args)))
(let ((signature "s") ;; FIXME: For the time being.
;; Read basic type symbol.
(type (when (symbolp (car args)) (pop args)))
(value (pop args))
(emits-signal (pop args))
(dont-register-service (pop args)))
(unless (member access '(:read :write :readwrite))
(signal 'wrong-type-argument (list "Access type invalid" access)))
(unless type
(unless (or type (consp value))
(setq type
(cond
((memq value '(t nil)) :boolean)
@ -1559,6 +1561,8 @@ clients from discovering the still incomplete interface.
((stringp value) :string)
(t
(signal 'wrong-type-argument (list "Value type invalid" value))))))
(unless (consp value)
(setq value (list type value)))
;; Add handlers for the three property-related methods.
(dbus-register-method
@ -1579,12 +1583,14 @@ clients from discovering the still incomplete interface.
(when emits-signal
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
(if (member access '(:read :readwrite))
`(:array
(:dict-entry
,property
,(if type (list :variant type value) (list :variant value))))
'(:array: :signature "{sv}"))
;; changed_properties.
(if (eq access :write)
'(:array: :signature "{sv}")
`(:array
(:dict-entry
,property
,(if type (list :variant type value) (list :variant value)))))
;; invalidated_properties.
(if (eq access :write)
`(:array ,property)
'(:array))))
@ -1595,10 +1601,7 @@ clients from discovering the still incomplete interface.
(val
(cons
(list
nil service path
(cons
(if emits-signal (list access :emits-signal) (list access))
(if type (list type value) (list value))))
nil service path (list access emits-signal signature value))
(dbus-get-other-registered-properties
bus service path interface property))))
(puthash key val dbus-registered-objects-table)
@ -1626,16 +1629,19 @@ It will be registered for all objects created by `dbus-register-property'."
`(:error ,dbus-error-unknown-property
,(format-message
"No such property \"%s\" at path \"%s\"" property path)))
((memq :write (car object))
((eq :write (car object))
`(:error ,dbus-error-access-denied
,(format-message
"Property \"%s\" at path \"%s\" is not readable" property path)))
;; Return the result.
(t (list :variant (cdar (last (car entry))))))))
;; Return the result. Since variant is a list, we must embed
;; it into another list.
(t (list (if (eq :array (car (nth 3 object)))
(list :variant (nth 3 object))
(cons :variant (nth 3 object))))))))
;; "Set" expects a variant.
;; "Set" expects the same type as registered.
((string-equal method "Set")
(let* ((value (caar (cddr args)))
(let* ((value (caar (nth 2 args)))
(entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
@ -1644,27 +1650,30 @@ It will be registered for all objects created by `dbus-register-property'."
`(:error ,dbus-error-unknown-property
,(format-message
"No such property \"%s\" at path \"%s\"" property path)))
((memq :read (car object))
((eq :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)
(t (unless (consp value)
(setq value (list (car (nth 3 object)) value)))
(puthash (list :property bus interface property)
(cons (append
(butlast (car entry))
;; Reuse ACCESS und TYPE from registration.
(list (list (car object) (cadr object) value)))
;; Reuse ACCESS, EMITS-SIGNAL and TYPE.
(list (append (butlast object) (list value))))
(dbus-get-other-registered-properties
bus service path interface property))
dbus-registered-objects-table)
;; Send the "PropertiesChanged" signal.
(when (member :emits-signal (car object))
(when (nth 1 object)
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
(if (or (member :read (car object))
(member :readwrite (car object)))
`(:array (:dict-entry ,property (:variant ,value)))
'(:array: :signature "{sv}"))
(if (eq (car object) :write)
;; changed_properties.
(if (eq :write (car object))
'(:array: :signature "{sv}")
`(:array (:dict-entry ,property (:variant ,value))))
;; invalidated_properties.
(if (eq :write (car object))
`(:array ,property)
'(:array))))
;; Return empty reply.
@ -1677,18 +1686,22 @@ It will be registered for all objects created by `dbus-register-property'."
(lambda (key val)
(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))
(cons :variant (cdar (last item))))
result)))))
(let ((object (car (last item))))
(when (and (equal (butlast key) (list :property bus interface))
(string-equal path (nth 2 item))
(consp object)
(not (eq :write (car object))))
(push
(list :dict-entry
(car (last key))
(if (eq :array (car (nth 3 object)))
(list :variant (nth 3 object))
(cons :variant (nth 3 object))))
result))))))
dbus-registered-objects-table)
;; Return the result, or an empty array.
(list :array (or result '(:signature "{sv}")))))
;; Return the result, or an empty array. An array must be
;; embedded in a list.
(list (cons :array (or result '(:signature "{sv}"))))))
(t `(:error ,dbus-error-unknown-method
,(format-message
@ -1896,6 +1909,8 @@ this connection to those buses."
;;; TODO:
;; Support other compound properties but array.
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
;;

9
src/dbusbind.c
View file

@ -1824,10 +1824,11 @@ SERVICE PATH OBJECT [RULE]) ...). SERVICE is the service name as
registered, UNAME is the corresponding unique name. In case of
registered methods and properties, UNAME is nil. PATH is the object
path of the sending object. All of them can be nil, which means a
wildcard then. OBJECT is either the handler to be called when a D-Bus
message, which matches the key criteria, arrives (TYPE `:method' and
`:signal'), or a list containing the value of the property and its
attributes (TYPE `:property').
wildcard then.
OBJECT is either the handler to be called when a D-Bus message, which
matches the key criteria, arrives (TYPE `:method' and `:signal'), or a
list (ACCESS EMITS-SIGNAL SIGNATURE VALUE) for TYPE `:property'.
For entries of type `:signal', there is also a fifth element RULE,
which keeps the match string the signal is registered with.

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

@ -41,7 +41,7 @@
(defconst dbus--test-path "/org/gnu/Emacs/TestDBus"
"Test object path.")
(defconst dbus--test-interface "org.gnu.Emacs.TestDBus"
(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
"Test interface.")
(defun dbus--test-availability (bus)
@ -249,6 +249,7 @@ This includes initialization and closing the bus."
;; Cleanup.
(dbus-unregister-service :session dbus--test-service)))
;; TODO: Test emits-signal, unregister.
(ert-deftest dbus-test05-register-property ()
"Check property registration for an own service."
(skip-unless dbus--test-enabled-session-bus)
@ -271,7 +272,7 @@ This includes initialization and closing the bus."
(dbus-register-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1 :read "foo")
`((:property :session "org.gnu.Emacs.TestDBus" ,property1)
`((:property :session ,dbus--test-interface ,property1)
(,dbus--test-service ,dbus--test-path))))
(should
(string-equal
@ -296,7 +297,7 @@ This includes initialization and closing the bus."
(dbus-register-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2 :write "bar")
`((:property :session "org.gnu.Emacs.TestDBus" ,property2)
`((:property :session ,dbus--test-interface ,property2)
(,dbus--test-service ,dbus--test-path))))
(should-not ;; Due to `:write' access type.
(dbus-get-property
@ -319,7 +320,7 @@ This includes initialization and closing the bus."
(dbus-register-property
:session dbus--test-service dbus--test-path
dbus--test-interface property3 :readwrite :object-path "/baz")
`((:property :session "org.gnu.Emacs.TestDBus" ,property3)
`((:property :session ,dbus--test-interface ,property3)
(,dbus--test-service ,dbus--test-path))))
(should
(string-equal
@ -381,14 +382,14 @@ This includes initialization and closing the bus."
(dbus-register-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1 :readwrite "foo")
`((:property :session "org.gnu.Emacs.TestDBus" ,property1)
`((:property :session ,dbus--test-interface ,property1)
(,dbus--test-service ,dbus--test-path))))
(should
(equal
(dbus-register-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2 :readwrite "bar")
`((:property :session "org.gnu.Emacs.TestDBus" ,property2)
`((:property :session ,dbus--test-interface ,property2)
(,dbus--test-service ,dbus--test-path))))
(should
(string-equal
@ -434,14 +435,14 @@ This includes initialization and closing the bus."
(dbus-register-property
:session dbus--test-service (concat dbus--test-path dbus--test-path)
dbus--test-interface property2 :readwrite "foo")
`((:property :session "org.gnu.Emacs.TestDBus" ,property2)
`((:property :session ,dbus--test-interface ,property2)
(,dbus--test-service ,(concat dbus--test-path dbus--test-path)))))
(should
(equal
(dbus-register-property
:session dbus--test-service (concat dbus--test-path dbus--test-path)
dbus--test-interface property3 :readwrite "bar")
`((:property :session "org.gnu.Emacs.TestDBus" ,property3)
`((:property :session ,dbus--test-interface ,property3)
(,dbus--test-service ,(concat dbus--test-path dbus--test-path)))))
(should
(string-equal