Implement typed D-Bus properties (Bug#43252)
* doc/misc/dbus.texi (Properties and Annotations) (Receiving Method Call): Document optional type symbol in `dbus-set-property' and `dbus-register-property'. * lisp/net/dbus.el (dbus-error-unknown-interface) (dbus-error-unknown-method, dbus-error-unknown-object) (dbus-error-unknown-property): New defconsts. (dbus-peer-handler): Improve error handling. (dbus-introspect-get-signature): Handle also properties. (dbus-set-property, dbus-register-property): Allow optional TYPE symbol for VALUE. (Bug#43252) (dbus-property-handler): Implement property types. Improve error handling. * src/dbusbind.c (dbus-message-internal, dbus-registered-objects-table): Fix docstring. * test/lisp/net/dbus-tests.el (dbus-test05-register-property): Extend test. (dbus-test05-register-property-several-paths): New test.
This commit is contained in:
Michael Albinus
parent
65565a16cf
commit
39230fadbc
4 changed files with 301 additions and 104 deletions
|
|
@ -744,16 +744,17 @@ result can be any valid D-Bus value, or @code{nil} if there is no
|
|||
@end lisp
|
||||
@end defun
|
||||
|
||||
@defun dbus-set-property bus service path interface property value
|
||||
@defun dbus-set-property bus service path interface property [type] value
|
||||
This function sets the value of @var{property} of @var{interface} to
|
||||
@var{value}. It will be checked at @var{bus}, @var{service},
|
||||
@var{path}. When the value is successfully set, this function returns
|
||||
@var{value}. Otherwise, it returns @code{nil}. Example:
|
||||
@var{path}. @var{value} can be preceded by a @var{type} symbol. When
|
||||
the value is successfully set, this function returns @var{value}.
|
||||
Otherwise, it returns @code{nil}. Example:
|
||||
|
||||
@lisp
|
||||
(dbus-set-property
|
||||
:session "org.kde.kaccess" "/MainApplication"
|
||||
"com.trolltech.Qt.QApplication" "doubleClickInterval" 500)
|
||||
"com.trolltech.Qt.QApplication" "doubleClickInterval" :uint16 500)
|
||||
|
||||
@result{} 500
|
||||
@end lisp
|
||||
|
|
@ -1561,7 +1562,7 @@ The test then runs
|
|||
@end example
|
||||
@end defun
|
||||
|
||||
@defun dbus-register-property bus service path interface property access value &optional emits-signal dont-register-service
|
||||
@defun dbus-register-property bus service path interface property access [type] value &optional emits-signal dont-register-service
|
||||
With this function, an application declares a @var{property} on the D-Bus
|
||||
@var{bus}.
|
||||
|
||||
|
|
@ -1579,9 +1580,11 @@ discussion of @var{dont-register-service} below).
|
|||
|
||||
@var{access} indicates, whether the property can be changed by other
|
||||
services via D-Bus. It must be either the symbol @code{:read},
|
||||
@code{:write} or @code{:readwrite}. @var{value} is the initial value
|
||||
of the property, it can be of any valid type (@xref{dbus-call-method},
|
||||
for details).
|
||||
@code{:write} or @code{:readwrite}.
|
||||
|
||||
@var{value} is the initial value of the property, it can be of any
|
||||
valid type (@xref{dbus-call-method}, for details). @var{value} can be
|
||||
preceded by a @var{type} symbol.
|
||||
|
||||
If @var{property} already exists on @var{path}, it will be
|
||||
overwritten. For properties with access type @code{:read} this is the
|
||||
|
|
|
|||
214
lisp/net/dbus.el
214
lisp/net/dbus.el
|
|
@ -168,6 +168,19 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
|
|||
(concat dbus-error-dbus ".PropertyReadOnly")
|
||||
"Property you tried to set is read-only.")
|
||||
|
||||
(defconst dbus-error-unknown-interface
|
||||
(concat dbus-error-dbus ".UnknownInterface")
|
||||
"Interface you invoked a method on isn't known by the object.")
|
||||
|
||||
(defconst dbus-error-unknown-method (concat dbus-error-dbus ".UnknownMethod")
|
||||
"Method name you invoked isn't known by the object you invoked it on.")
|
||||
|
||||
(defconst dbus-error-unknown-object (concat dbus-error-dbus ".UnknownObject")
|
||||
"Object you invoked a method on isn't known.")
|
||||
|
||||
(defconst dbus-error-unknown-property (concat dbus-error-dbus ".UnknownProperty")
|
||||
"Property you tried to access isn't known by the object.")
|
||||
|
||||
|
||||
;;; Emacs defaults.
|
||||
(defconst dbus-service-emacs "org.gnu.Emacs"
|
||||
|
|
@ -1184,7 +1197,8 @@ check whether SERVICE is already running, you can instead write
|
|||
"Default handler for the \"org.freedesktop.DBus.Peer\" interface.
|
||||
It will be registered for all objects created by `dbus-register-service'."
|
||||
(let* ((last-input-event last-input-event)
|
||||
(method (dbus-event-member-name last-input-event)))
|
||||
(method (dbus-event-member-name last-input-event))
|
||||
(path (dbus-event-path-name last-input-event)))
|
||||
(cond
|
||||
;; "Ping" does not return an output parameter.
|
||||
((string-equal method "Ping")
|
||||
|
|
@ -1194,7 +1208,11 @@ It will be registered for all objects created by `dbus-register-service'."
|
|||
(signal
|
||||
'dbus-error
|
||||
(list
|
||||
(format "%s.GetMachineId not implemented" dbus-interface-peer)))))))
|
||||
(format "%s.GetMachineId not implemented" dbus-interface-peer))))
|
||||
(t `(:error ,dbus-error-unknown-method
|
||||
,(format-message
|
||||
"No such method \"%s.%s\" at path \"%s\""
|
||||
dbus-interface-peer method path))))))
|
||||
|
||||
|
||||
;;; D-Bus introspection.
|
||||
|
|
@ -1386,37 +1404,38 @@ string and a member of the list returned by
|
|||
|
||||
(defun dbus-introspect-get-signature
|
||||
(bus service path interface name &optional direction)
|
||||
"Return signature of a `method' or `signal' represented by NAME as a string.
|
||||
"Return signature of a `method', `property' or `signal' represented by NAME.
|
||||
If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
|
||||
If DIRECTION is nil, \"in\" is assumed.
|
||||
|
||||
If NAME is a `signal', and DIRECTION is non-nil, DIRECTION must
|
||||
be \"out\"."
|
||||
If NAME is a `signal' or a `property', DIRECTION is ignored."
|
||||
;; For methods, we use "in" as default direction.
|
||||
(let ((object (or (dbus-introspect-get-method
|
||||
bus service path interface name)
|
||||
(dbus-introspect-get-signal
|
||||
bus service path interface name)
|
||||
(dbus-introspect-get-property
|
||||
bus service path interface name))))
|
||||
(when (and (string-equal
|
||||
"method" (dbus-introspect-get-attribute object "name"))
|
||||
(not (stringp direction)))
|
||||
(when (and (eq 'method (car object)) (not (stringp direction)))
|
||||
(setq direction "in"))
|
||||
;; In signals, no direction is given.
|
||||
(when (string-equal "signal" (dbus-introspect-get-attribute object "name"))
|
||||
(when (eq 'signal (car object))
|
||||
(setq direction nil))
|
||||
;; Collect the signatures.
|
||||
(mapconcat
|
||||
(lambda (x)
|
||||
(let ((arg (dbus-introspect-get-argument
|
||||
bus service path interface name x)))
|
||||
(if (or (not (stringp direction))
|
||||
(string-equal
|
||||
direction
|
||||
(dbus-introspect-get-attribute arg "direction")))
|
||||
(dbus-introspect-get-attribute arg "type")
|
||||
"")))
|
||||
(dbus-introspect-get-argument-names bus service path interface name)
|
||||
"")))
|
||||
(if (eq 'property (car object))
|
||||
(dbus-introspect-get-attribute object "type")
|
||||
(mapconcat
|
||||
(lambda (x)
|
||||
(let ((arg (dbus-introspect-get-argument
|
||||
bus service path interface name x)))
|
||||
(if (or (not (stringp direction))
|
||||
(string-equal
|
||||
direction
|
||||
(dbus-introspect-get-attribute arg "direction")))
|
||||
(dbus-introspect-get-attribute arg "type")
|
||||
"")))
|
||||
(dbus-introspect-get-argument-names bus service path interface name)
|
||||
""))))
|
||||
|
||||
|
||||
;;; D-Bus properties.
|
||||
|
|
@ -1432,20 +1451,23 @@ valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read."
|
|||
bus service path dbus-interface-properties
|
||||
"Get" :timeout 500 interface property))))
|
||||
|
||||
(defun dbus-set-property (bus service path interface property value)
|
||||
(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. When the value is
|
||||
successfully set return VALUE. Otherwise, return nil."
|
||||
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.
|
||||
|
||||
\(dbus-set-property BUS SERVICE PATH INTERFACE PROPERTY [TYPE] VALUE)"
|
||||
(dbus-ignore-errors
|
||||
;; "Set" requires a variant.
|
||||
(dbus-call-method
|
||||
bus service path dbus-interface-properties
|
||||
"Set" :timeout 500 interface property (list :variant value))
|
||||
"Set" :timeout 500 interface property (cons :variant args))
|
||||
;; Return VALUE. The property could have the `:write' access type,
|
||||
;; so we ignore errors in `dbus-get-property'.
|
||||
(or
|
||||
(dbus-ignore-errors (dbus-get-property bus service path interface property))
|
||||
value)))
|
||||
(dbus-ignore-errors
|
||||
(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.
|
||||
|
|
@ -1481,8 +1503,7 @@ Filter out matching PATH."
|
|||
dbus-registered-objects-table)))
|
||||
|
||||
(defun dbus-register-property
|
||||
(bus service path interface property access value
|
||||
&optional emits-signal dont-register-service)
|
||||
(bus service path interface property access &rest args)
|
||||
"Register PROPERTY on the D-Bus BUS.
|
||||
|
||||
BUS is either a Lisp symbol, `:system' or `:session', or a string
|
||||
|
|
@ -1496,9 +1517,11 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
|
|||
name of the interface used at PATH, PROPERTY is the name of the
|
||||
property of INTERFACE. ACCESS indicates, whether the property
|
||||
can be changed by other services via D-Bus. It must be either
|
||||
the symbol `:read', `:write' or `:readwrite'. VALUE is the
|
||||
initial value of the property, it can be of any valid type (see
|
||||
`dbus-call-method' for details).
|
||||
the symbol `:read', `:write' or `:readwrite'.
|
||||
|
||||
VALUE is the initial value of the property, it can be of any
|
||||
valid type (see `dbus-call-method' for details). VALUE can be
|
||||
preceded by a TYPE symbol.
|
||||
|
||||
If PROPERTY already exists on PATH, it will be overwritten. For
|
||||
properties with access type `:read' this is the only way to
|
||||
|
|
@ -1516,52 +1539,72 @@ not registered. This means that other D-Bus clients have no way
|
|||
of noticing the newly registered property. When interfaces are
|
||||
constructed incrementally by adding single methods or properties
|
||||
at a time, DONT-REGISTER-SERVICE can be used to prevent other
|
||||
clients from discovering the still incomplete interface."
|
||||
(unless (member access '(:read :write :readwrite))
|
||||
(signal 'wrong-type-argument (list "Access type invalid" access)))
|
||||
clients from discovering the still incomplete interface.
|
||||
|
||||
;; Add handlers for the three property-related methods.
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "Get"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "GetAll"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "Set"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
\(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)))
|
||||
(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
|
||||
(setq type
|
||||
(cond
|
||||
((memq value '(t nil)) :boolean)
|
||||
((natnump value) :uint32)
|
||||
((fixnump value) :int32)
|
||||
((floatp value) :double)
|
||||
((stringp value) :string)
|
||||
(t
|
||||
(signal 'wrong-type-argument (list "Value type invalid" value))))))
|
||||
|
||||
;; Register SERVICE.
|
||||
(unless (or dont-register-service (member service (dbus-list-names bus)))
|
||||
(dbus-register-service bus service))
|
||||
;; Add handlers for the three property-related methods.
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "Get"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "GetAll"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
(dbus-register-method
|
||||
bus service path dbus-interface-properties "Set"
|
||||
#'dbus-property-handler 'dont-register)
|
||||
|
||||
;; Send the PropertiesChanged signal.
|
||||
(when emits-signal
|
||||
(dbus-send-signal
|
||||
bus service path dbus-interface-properties "PropertiesChanged"
|
||||
(if (member access '(:read :readwrite))
|
||||
`(:array (:dict-entry ,property (:variant ,value)))
|
||||
'(:array: :signature "{sv}"))
|
||||
(if (eq access :write)
|
||||
`(:array ,property)
|
||||
'(:array))))
|
||||
;; Register SERVICE.
|
||||
(unless (or dont-register-service (member service (dbus-list-names bus)))
|
||||
(dbus-register-service bus service))
|
||||
|
||||
;; Create a hash table entry. We use nil for the unique name,
|
||||
;; because the property might be accessed from anybody.
|
||||
(let ((key (list :property bus interface property))
|
||||
(val
|
||||
(cons
|
||||
(list
|
||||
nil service path
|
||||
(cons
|
||||
(if emits-signal (list access :emits-signal) (list access))
|
||||
value))
|
||||
(dbus-get-other-registered-properties
|
||||
bus service path interface property))))
|
||||
(puthash key val dbus-registered-objects-table)
|
||||
;; Send the PropertiesChanged signal.
|
||||
(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}"))
|
||||
(if (eq access :write)
|
||||
`(:array ,property)
|
||||
'(:array))))
|
||||
|
||||
;; Return the object.
|
||||
(list key (list service path))))
|
||||
;; Create a hash table entry. We use nil for the unique name,
|
||||
;; because the property might be accessed from anybody.
|
||||
(let ((key (list :property bus interface property))
|
||||
(val
|
||||
(cons
|
||||
(list
|
||||
nil service path
|
||||
(cons
|
||||
(if emits-signal (list access :emits-signal) (list access))
|
||||
(if type (list type value) (list value))))
|
||||
(dbus-get-other-registered-properties
|
||||
bus service path interface property))))
|
||||
(puthash key val dbus-registered-objects-table)
|
||||
|
||||
;; Return the object.
|
||||
(list key (list service path)))))
|
||||
|
||||
(defun dbus-property-handler (&rest args)
|
||||
"Default handler for the \"org.freedesktop.DBus.Properties\" interface.
|
||||
|
|
@ -1580,7 +1623,7 @@ It will be registered for all objects created by `dbus-register-property'."
|
|||
(object (car (last (car entry)))))
|
||||
(cond
|
||||
((not (consp object))
|
||||
`(:error ,dbus-error-invalid-args
|
||||
`(:error ,dbus-error-unknown-property
|
||||
,(format-message
|
||||
"No such property \"%s\" at path \"%s\"" property path)))
|
||||
((memq :write (car object))
|
||||
|
|
@ -1588,7 +1631,7 @@ It will be registered for all objects created by `dbus-register-property'."
|
|||
,(format-message
|
||||
"Property \"%s\" at path \"%s\" is not readable" property path)))
|
||||
;; Return the result.
|
||||
(t `((:variant ,(cdar (last (car entry)))))))))
|
||||
(t (list :variant (cdar (last (car entry))))))))
|
||||
|
||||
;; "Set" expects a variant.
|
||||
((string-equal method "Set")
|
||||
|
|
@ -1598,7 +1641,7 @@ It will be registered for all objects created by `dbus-register-property'."
|
|||
(object (car (last (car entry)))))
|
||||
(cond
|
||||
((not (consp object))
|
||||
`(:error ,dbus-error-invalid-args
|
||||
`(:error ,dbus-error-unknown-property
|
||||
,(format-message
|
||||
"No such property \"%s\" at path \"%s\"" property path)))
|
||||
((memq :read (car object))
|
||||
|
|
@ -1606,8 +1649,10 @@ It will be registered for all objects created by `dbus-register-property'."
|
|||
,(format-message
|
||||
"Property \"%s\" at path \"%s\" is not writable" property path)))
|
||||
(t (puthash (list :property bus interface property)
|
||||
(cons (append (butlast (car entry))
|
||||
(list (cons (car object) value)))
|
||||
(cons (append
|
||||
(butlast (car entry))
|
||||
;; Reuse ACCESS und TYPE from registration.
|
||||
(list (list (car object) (cadr object) value)))
|
||||
(dbus-get-other-registered-properties
|
||||
bus service path interface property))
|
||||
dbus-registered-objects-table)
|
||||
|
|
@ -1639,11 +1684,16 @@ It will be registered for all objects created by `dbus-register-property'."
|
|||
(push
|
||||
(list :dict-entry
|
||||
(car (last key))
|
||||
(list :variant (cdar (last item))))
|
||||
(cons :variant (cdar (last item))))
|
||||
result)))))
|
||||
dbus-registered-objects-table)
|
||||
;; Return the result, or an empty array.
|
||||
(list :array (or result '(:signature "{sv}"))))))))
|
||||
(list :array (or result '(:signature "{sv}")))))
|
||||
|
||||
(t `(:error ,dbus-error-unknown-method
|
||||
,(format-message
|
||||
"No such method \"%s.%s\" at path \"%s\""
|
||||
dbus-interface-properties method path))))))
|
||||
|
||||
|
||||
;;; D-Bus object manager.
|
||||
|
|
@ -1849,6 +1899,8 @@ this connection to those buses."
|
|||
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
|
||||
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
|
||||
;;
|
||||
;; * Cache introspection data.
|
||||
;;
|
||||
;; * Run handlers in own threads.
|
||||
|
||||
;;; dbus.el ends here
|
||||
|
|
|
|||
|
|
@ -1252,7 +1252,7 @@ The following usages are expected:
|
|||
|
||||
`dbus-method-error-internal':
|
||||
(dbus-message-internal
|
||||
dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
|
||||
dbus-message-type-error BUS SERVICE SERIAL ERROR-NAME &rest ARGS)
|
||||
|
||||
usage: (dbus-message-internal &rest REST) */)
|
||||
(ptrdiff_t nargs, Lisp_Object *args)
|
||||
|
|
@ -1572,10 +1572,9 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
|
|||
EVENT_INIT (event);
|
||||
event.kind = DBUS_EVENT;
|
||||
event.frame_or_window = Qnil;
|
||||
event.arg =
|
||||
Fcons (value,
|
||||
(mtype == DBUS_MESSAGE_TYPE_ERROR)
|
||||
? (Fcons (build_string (error_name), args)) : args);
|
||||
event.arg = Fcons (value,
|
||||
(mtype == DBUS_MESSAGE_TYPE_ERROR)
|
||||
? (Fcons (build_string (error_name), args)) : args);
|
||||
}
|
||||
|
||||
else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
|
||||
|
|
@ -1748,7 +1747,8 @@ syms_of_dbusbind (void)
|
|||
DEFSYM (QCstruct, ":struct");
|
||||
DEFSYM (QCdict_entry, ":dict-entry");
|
||||
|
||||
/* Lisp symbols of objects in `dbus-registered-objects-table'. */
|
||||
/* Lisp symbols of objects in `dbus-registered-objects-table'.
|
||||
`:property', which does exist there as well, is not used here. */
|
||||
DEFSYM (QCserial, ":serial");
|
||||
DEFSYM (QCmethod, ":method");
|
||||
DEFSYM (QCsignal, ":signal");
|
||||
|
|
@ -1826,8 +1826,8 @@ 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 cons cell containing the value of the property (TYPE
|
||||
`:property').
|
||||
`:signal'), or a list containing the value of the property and its
|
||||
attributes (TYPE `:property').
|
||||
|
||||
For entries of type `:signal', there is also a fifth element RULE,
|
||||
which keeps the match string the signal is registered with.
|
||||
|
|
|
|||
|
|
@ -259,6 +259,12 @@ This includes initialization and closing the bus."
|
|||
(property2 "Property2")
|
||||
(property3 "Property3"))
|
||||
|
||||
;; Not registered property.
|
||||
(should-not
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1))
|
||||
|
||||
;; `:read' property.
|
||||
(should
|
||||
(equal
|
||||
|
|
@ -307,12 +313,12 @@ This includes initialization and closing the bus."
|
|||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property2))
|
||||
|
||||
;; `:readwrite' property.
|
||||
;; `:readwrite' property, typed value (Bug#43252).
|
||||
(should
|
||||
(equal
|
||||
(dbus-register-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property3 :readwrite "baz")
|
||||
dbus--test-interface property3 :readwrite :object-path "/baz")
|
||||
`((:property :session "org.gnu.Emacs.TestDBus" ,property3)
|
||||
(,dbus--test-service ,dbus--test-path))))
|
||||
(should
|
||||
|
|
@ -320,19 +326,19 @@ This includes initialization and closing the bus."
|
|||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property3)
|
||||
"baz"))
|
||||
"/baz"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-set-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property3 "bazbaz")
|
||||
"bazbaz"))
|
||||
dbus--test-interface property3 :object-path "/baz/baz")
|
||||
"/baz/baz"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property3)
|
||||
"bazbaz"))
|
||||
"/baz/baz"))
|
||||
|
||||
;; `dbus-get-all-properties'. We cannot retrieve a value for
|
||||
;; the property with `:write' access type.
|
||||
|
|
@ -341,7 +347,7 @@ This includes initialization and closing the bus."
|
|||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface)))
|
||||
(should (string-equal (cdr (assoc property1 result)) "foo"))
|
||||
(should (string-equal (cdr (assoc property3 result)) "bazbaz"))
|
||||
(should (string-equal (cdr (assoc property3 result)) "/baz/baz"))
|
||||
(should-not (assoc property2 result))))
|
||||
|
||||
;; FIXME: This is wrong! The properties are missing.
|
||||
|
|
@ -357,6 +363,142 @@ This includes initialization and closing the bus."
|
|||
;; Cleanup.
|
||||
(dbus-unregister-service :session dbus--test-service)))
|
||||
|
||||
;; The following test is inspired by Bug#43146.
|
||||
(ert-deftest dbus-test05-register-property-several-paths ()
|
||||
"Check property registration for an own service at several paths."
|
||||
(skip-unless dbus--test-enabled-session-bus)
|
||||
(dbus-ignore-errors (dbus-unregister-service :session dbus--test-service))
|
||||
|
||||
(unwind-protect
|
||||
(let ((property1 "Property1")
|
||||
(property2 "Property2")
|
||||
(property3 "Property3"))
|
||||
|
||||
;; First path.
|
||||
(should
|
||||
(equal
|
||||
(dbus-register-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1 :readwrite "foo")
|
||||
`((:property :session "org.gnu.Emacs.TestDBus" ,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)
|
||||
(,dbus--test-service ,dbus--test-path))))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1)
|
||||
"foo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property2)
|
||||
"bar"))
|
||||
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-set-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1 "foofoo")
|
||||
"foofoo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-set-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property2 "barbar")
|
||||
"barbar"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property1)
|
||||
"foofoo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface property2)
|
||||
"barbar"))
|
||||
|
||||
;; Second path.
|
||||
(should
|
||||
(equal
|
||||
(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)
|
||||
(,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)
|
||||
(,dbus--test-service ,(concat dbus--test-path dbus--test-path)))))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property2)
|
||||
"foo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property3)
|
||||
"bar"))
|
||||
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-set-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property2 "foofoo")
|
||||
"foofoo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-set-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property3 "barbar")
|
||||
"barbar"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property2)
|
||||
"foofoo"))
|
||||
(should
|
||||
(string-equal
|
||||
(dbus-get-property
|
||||
:session dbus--test-service (concat dbus--test-path dbus--test-path)
|
||||
dbus--test-interface property3)
|
||||
"barbar"))
|
||||
|
||||
;; Everything is still fine, tested with `dbus-get-all-properties'.
|
||||
(let ((result
|
||||
(dbus-get-all-properties
|
||||
:session dbus--test-service dbus--test-path
|
||||
dbus--test-interface)))
|
||||
(should (string-equal (cdr (assoc property1 result)) "foofoo"))
|
||||
(should (string-equal (cdr (assoc property2 result)) "barbar"))
|
||||
(should-not (assoc property3 result)))
|
||||
(let ((result
|
||||
(dbus-get-all-properties
|
||||
:session dbus--test-service
|
||||
(concat dbus--test-path dbus--test-path) dbus--test-interface)))
|
||||
(should (string-equal (cdr (assoc property2 result)) "foofoo"))
|
||||
(should (string-equal (cdr (assoc property3 result)) "barbar"))
|
||||
(should-not (assoc property1 result))))
|
||||
|
||||
;; Cleanup.
|
||||
(dbus-unregister-service :session dbus--test-service)))
|
||||
|
||||
(defun dbus-test-all (&optional interactive)
|
||||
"Run all tests for \\[dbus]."
|
||||
(interactive "p")
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue