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

Make D-Bus properties type safe

Browse source 
* doc/misc/dbus.texi (Properties and Annotations):
Precise dbus-get-property and dbus-set-property.
(Type Conversion): Explain :byte and :boolean type conversion.
(Errors and Events): dbus-ignore-errors returns nil when there is
a D-Bus error.  Remove dbus-show-dbus-errors.

* etc/NEWS: Some D-Bus relevant changes.

* lisp/net/dbus.el (dbus-show-dbus-errors): Remove.
(dbus-ignore-errors): Replay implamentation without that variable.
(dbus-check-arguments): New defun.
(dbus-list-activatable-names, dbus-list-names)
(dbus-list-queued-owners, dbus-get-name-owner, dbus-introspect)
(dbus-get-all-properties, dbus-get-all-managed-objects): Don't debug.
(dbus-get-property, dbus-set-property): Propagate errors.
(dbus-register-property): Check for valid VALUE.
(dbus-property-handler): Simplify.

* src/dbusbind.c (Fdbus_message_internal): Adapt docstring.
Handle DBUS_MESSAGE_TYPE_INVALID.

* test/lisp/net/dbus-tests.el (dbus-show-dbus-errors): Don't declare.
(dbus-test06-register-property)
(dbus-test06-register-property-emits-signal): Adapt tests.
This commit is contained in:
Michael Albinus 2020-09-20 16:44:17 +02:00
parent 209dfa11a4
commit f8624fb834
5 changed files with 201 additions and 186 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
doc/misc/dbus.texi
View file

@ -732,8 +732,8 @@ A @var{property} value can be retrieved by the function
@defun dbus-get-property bus service path interface property
This function returns the value of @var{property} of @var{interface}.
It will be checked at @var{bus}, @var{service}, @var{path}. The
result can be any valid D-Bus value, or @code{nil} if there is no
@var{property}. Example:
result can be any valid D-Bus value. If there is no @var{property},
or @var{property} cannot be read, an error is raised. Example:
@lisp
(dbus-get-property
@ -749,7 +749,7 @@ 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}. @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:
Example:
@lisp
(dbus-set-property
@ -761,10 +761,11 @@ Otherwise, it returns @code{nil}. Example:
@end defun
@defun dbus-get-all-properties bus service path interface
This function returns all properties of @var{interface}. It will be
checked at @var{bus}, @var{service}, @var{path}. The result is a list
of cons. Every cons contains the name of the property, and its value.
If there are no properties, @code{nil} is returned. Example:
This function returns all readable properties of @var{interface}. It
will be checked at @var{bus}, @var{service}, @var{path}. The result
is a list of cons cells. Every cons cell contains the name of the
property, and its value. If there are no properties, @code{nil} is
returned. Example:
@lisp
(dbus-get-all-properties
@ -782,9 +783,9 @@ If there are no properties, @code{nil} is returned. Example:
@defun dbus-get-all-managed-objects bus service path
This function returns all objects at @var{bus}, @var{service},
@var{path}, and the children of @var{path}. The result is a list of
objects. Every object is a cons of an existing path name, and the
list of available interface objects. An interface object is another
cons, whose car is the interface name and cdr is the list of
objects. Every object is a cons cell of an existing path name, and
the list of available interface objects. An interface object is
another cons, whose car is the interface name and cdr is the list of
properties as returned by @code{dbus-get-all-properties} for that path
and interface. Example:
@ -1031,6 +1032,12 @@ represented outside this range are stripped off. For example,
@code{:byte ?\C-x} or @code{:byte ?\M-\C-x}. Signed and unsigned
integer D-Bus types expect a corresponding integer value.
All basic D-Bus types based on a number are truncated to their type
range. For example, @code{:byte 1025} is equal to @code{:byte 1}.
If typed explicitly, a non-@code{nil} boolean value like
{@code{:boolean 'symbol} is handled like @code{t} or @code{:boolean t}.
A D-Bus compound type is always represented as a list. The @sc{car}
of this list can be the type symbol @code{:array}, @code{:variant},
@code{:struct} or @code{:dict-entry}, which would result in a
@ -1070,7 +1077,7 @@ elements of this array. Example:
(format ; Body.
"This is a test notification, raised from\n%S" (emacs-version))
'(:array) ; No actions (empty array of strings).
'(:array :signature "@{sv@}") ; No hints
'(:array :signature "@{sv@}") ; No hints
; (empty array of dictionary entries).
:int32 -1) ; Default timeout.
@ -1955,8 +1962,9 @@ appended to the @code{dbus-error}.
@defspec dbus-ignore-errors forms@dots{}
This executes @var{forms} exactly like a @code{progn}, except that
@code{dbus-error} errors are ignored during the @var{forms}. These
errors can be made visible when @code{dbus-debug} is set to @code{t}.
@code{dbus-error} errors are ignored during the @var{forms} (the macro
returns @code{nil} then). These errors can be made visible when
@code{dbus-debug} is set to non-@code{nil}.
@end defspec
Incoming D-Bus messages are handled as Emacs events, @pxref{Misc
@ -2035,11 +2043,10 @@ This function returns the member name of the D-Bus object @var{event}
is coming from. It is either a signal name or a method name.
@end defun
@vindex dbus-show-dbus-errors
D-Bus error messages are not propagated during event handling, because
it is usually not desired. D-Bus errors in events can be made visible
by setting the user option @code{dbus-show-dbus-errors} to
non-@code{nil}. They can also be handled by a hook function.
D-Bus errors are not propagated during event handling, because it is
usually not desired. D-Bus errors in events can be made visible by
setting the variable @code{dbus-debug} to non-@code{nil}. They can
also be handled by a hook function.
@defvar dbus-event-error-functions
This hook variable keeps a list of functions, which are called when a

16
etc/NEWS
View file

@ -375,7 +375,7 @@ tags to be considered as well.
** Gnus
+++
*** New variable 'gnus-global-groups'.
*** New user option 'gnus-global-groups'.
Gnus handles private groups differently from public (i.e., NNTP-like)
groups. Most importantly, Gnus doesn't download external images from
mail-like groups. This can be overridden by putting group names in
@ -389,8 +389,8 @@ You can now score based on the relative age of an article with the new
+++
*** User-defined scoring is now possible.
The new type is 'score-fn'. More information in
(Gnus)Score File Format.
The new type is 'score-fn'. More information in the Gnus manual node
"(gnus) Score File Format".
+++
*** New backend 'nnselect'.
@ -1045,7 +1045,7 @@ whose default value is 5.
*** New user option 'reveal-auto-hide'.
If non-nil (the default), revealed text is automatically hidden when
point leaves the text. If nil, the text is not hidden again. Instead
`M-x reveal-hide-revealed' can be used to hide all the revealed text.
'M-x reveal-hide-revealed' can be used to hide all the revealed text.
+++
*** New user options to control the look of line/column numbers in the mode line.
@ -1205,7 +1205,7 @@ The old names are now obsolete.
+++
*** Property values can be typed explicitly.
'dbus-register-property' and 'dbus-set-property' accept now optional
type symbols.
type symbols. Both functions propagate D-Bus errors.
+++
*** Registered properties can have the new access type ':write'.
@ -1215,9 +1215,7 @@ type symbols.
+++
*** D-Bus errors, which have been converted from incoming D-Bus error
messages, contain the error name of that message now. They can be
made visible by setting user variable 'dbus-show-dbus-errors' to
non-nil, even if protected by 'dbus-ignore-errors' otherwise.
messages, contain the error name of that message now.
---
*** D-Bus events keep the type information of their arguments.
@ -1557,7 +1555,7 @@ non-nil value. Please report any bugs you find while using the native
image API via 'M-x report-emacs-bug'.
---
** The variable 'make-pointer-invisible' is now honored on macOS.
** The user option 'make-pointer-invisible' is now honored on macOS.
----------------------------------------------------------------------

154
lisp/net/dbus.el
View file

@ -162,11 +162,6 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
:link '(custom-manual "(dbus)Top")
:version "28.1")
(defcustom dbus-show-dbus-errors nil
"Propagate incoming D-Bus error messages."
:version "28.1"
:type 'boolean)
(defconst dbus-error-dbus "org.freedesktop.DBus.Error"
"The namespace for default error names.
See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
@ -225,17 +220,11 @@ shall be subdirectories of this path.")
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
Signals also D-Bus error when `dbus-show-dbus-errors' is non-nil
and a D-Bus error message has arrived. Otherwise, return result
of last form in BODY, or all other errors."
Otherwise, return result of last form in BODY, or all other errors."
(declare (indent 0) (debug t))
`(condition-case err
(progn ,@body)
(dbus-error
(when (or dbus-debug
(and dbus-show-dbus-errors
(= dbus-message-type-error (nth 2 last-input-event))))
(signal (car err) (cdr err))))))
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors)
"Functions to be called when a D-Bus error happens in the event handler.
@ -548,6 +537,21 @@ This is an internal function, it shall not be used outside dbus.el."
(apply #'dbus-message-internal dbus-message-type-error
bus service serial error-name args))
(defun dbus-check-arguments (bus service &rest args)
"Check arguments ARGS by side effect.
BUS, SERVICE and ARGS have the same format as in `dbus-call-method'.
Any wrong argument triggers a D-Bus error. Otherwise, return t.
This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
(apply #'dbus-message-internal dbus-message-type-invalid bus service args))
;;; Hash table of registered functions.
@ -1200,10 +1204,11 @@ function signals a `dbus-error' if the event is not well formed."
BUS defaults to `:system' when nil or omitted. The result is a
list of strings, which is nil when there are no activatable
service names at all."
(dbus-ignore-errors
(dbus-call-method
(or bus :system) dbus-service-dbus
dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
(or bus :system) dbus-service-dbus
dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))))
(defun dbus-list-names (bus)
"Return the service names registered at D-Bus BUS.
@ -1211,9 +1216,10 @@ The result is a list of strings, which is nil when there are no
registered service names at all. Well known names are strings
like \"org.freedesktop.DBus\". Names starting with \":\" are
unique names for services."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))))
(defun dbus-list-known-names (bus)
"Retrieve all services which correspond to a known name in BUS.
@ -1226,18 +1232,20 @@ A service has a known name if it doesn't start with \":\"."
"Return the unique names registered at D-Bus BUS and queued for SERVICE.
The result is a list of strings, or nil when there are no queued
name owner service names at all."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
dbus-interface-dbus "ListQueuedOwners" service)))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
dbus-interface-dbus "ListQueuedOwners" service))))
(defun dbus-get-name-owner (bus service)
"Return the name owner of SERVICE registered at D-Bus BUS.
The result is either a string, or nil if there is no name owner."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
dbus-interface-dbus "GetNameOwner" service)))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
dbus-interface-dbus "GetNameOwner" service))))
(defun dbus-ping (bus service &optional timeout)
"Check whether SERVICE is registered for D-Bus BUS.
@ -1307,10 +1315,11 @@ and PATH must be a valid object path. The last two parameters
are strings. The result, the introspection data, is a string in
XML format."
;; We don't want to raise errors.
(dbus-ignore-errors
(dbus-call-method
bus service path dbus-interface-introspectable "Introspect"
:timeout 1000)))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
bus service path dbus-interface-introspectable "Introspect"
:timeout 1000))))
(defalias 'dbus--parse-xml-buffer
(if (libxml-available-p)
@ -1512,12 +1521,11 @@ If NAME is a `signal' or a `property', DIRECTION is ignored."
"Return the value of PROPERTY of INTERFACE.
It will be checked at BUS, SERVICE, PATH. The result can be any
valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read."
(dbus-ignore-errors
;; "Get" returns a variant, so we must use the `car'.
(car
(dbus-call-method
bus service path dbus-interface-properties
"Get" :timeout 500 interface property))))
;; "Get" returns a variant, so we must use the `car'.
(car
(dbus-call-method
bus service path dbus-interface-properties
"Get" :timeout 500 interface property)))
(defun dbus-set-property (bus service path interface property &rest args)
"Set value of PROPERTY of INTERFACE to VALUE.
@ -1527,26 +1535,30 @@ property's access type is not `:write', 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 (cons :variant args))
;; Return VALUE.
(or (dbus-get-property bus service path interface property)
(if (keywordp (car args)) (cadr args) (car args)))))
;; "Set" requires a variant.
(dbus-call-method
bus service path dbus-interface-properties
"Set" :timeout 500 interface property (cons :variant args))
;; Return VALUE.
(condition-case err
(dbus-get-property bus service path interface property)
(dbus-error
(if (string-equal dbus-error-access-denied (cadr err))
(car args)
(signal (car err) (cdr err))))))
(defun dbus-get-all-properties (bus service path interface)
"Return all properties of INTERFACE at BUS, SERVICE, PATH.
The result is a list of entries. Every entry is a cons of the
name of the property, and its value. If there are no properties,
nil is returned."
(dbus-ignore-errors
;; "GetAll" returns "a{sv}".
(mapcar (lambda (dict)
(cons (car dict) (caadr dict)))
(dbus-call-method bus service path dbus-interface-properties
"GetAll" :timeout 500 interface))))
(let (dbus-debug)
(dbus-ignore-errors
;; "GetAll" returns "a{sv}".
(mapcar (lambda (dict)
(cons (car dict) (caadr dict)))
(dbus-call-method bus service path dbus-interface-properties
"GetAll" :timeout 500 interface)))))
(defun dbus-get-this-registered-property (bus _service path interface property)
"Return PROPERTY entry of `dbus-registered-objects-table'.
@ -1631,6 +1643,7 @@ clients from discovering the still incomplete interface.
(setq value (list type value)))
(setq value (if (member (car value) dbus-compound-types)
(list :variant value) (cons :variant value)))
(dbus-check-arguments bus service value)
;; Add handlers for the three property-related methods.
(dbus-register-method
@ -1647,19 +1660,6 @@ clients from discovering the still incomplete interface.
(unless (or dont-register-service (member service (dbus-list-names bus)))
(dbus-register-service bus service))
;; Send the PropertiesChanged signal.
(when emits-signal
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
;; changed_properties.
(if (eq access :write)
'(:array: :signature "{sv}")
`(:array (:dict-entry ,property ,value)))
;; invalidated_properties.
(if (eq access :write)
`(:array ,property)
'(:array))))
;; 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))
@ -1670,6 +1670,14 @@ clients from discovering the still incomplete interface.
bus service path interface property))))
(puthash key val dbus-registered-objects-table)
;; Set or Get the property, in order to validate the property's
;; value and to send the PropertiesChanged signal.
(when (member service (dbus-list-names bus))
(if (eq access :read)
(dbus-get-property bus service path interface property)
(apply
#'dbus-set-property bus service path interface property (cdr value))))
;; Return the object.
(list key (list service path)))))
@ -1704,7 +1712,7 @@ It will be registered for all objects created by `dbus-register-property'."
;; "Set" needs the third typed argument from `last-input-event'.
((string-equal method "Set")
(let* ((value (nth 11 last-input-event))
(let* ((value (dbus-flatten-types (nth 11 last-input-event)))
(entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
@ -1721,8 +1729,7 @@ It will be registered for all objects created by `dbus-register-property'."
(cons (append
(butlast (car entry))
;; Reuse ACCESS and EMITS-SIGNAL.
(list (append (butlast object)
(list (dbus-flatten-types value)))))
(list (append (butlast object) (list value))))
(dbus-get-other-registered-properties
bus service path interface property))
dbus-registered-objects-table)
@ -1733,7 +1740,7 @@ It will be registered for all objects created by `dbus-register-property'."
;; changed_properties.
(if (eq :write (car object))
'(:array: :signature "{sv}")
`(:array (:dict-entry ,property (:variant ,value))))
`(:array (:dict-entry ,property ,value)))
;; invalidated_properties.
(if (eq :write (car object))
`(:array ,property)
@ -1804,10 +1811,11 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow."
(let ((result
;; Direct call. Fails, if the target does not support the
;; object manager interface.
(dbus-ignore-errors
(dbus-call-method
bus service path dbus-interface-objectmanager
"GetManagedObjects" :timeout 1000))))
(let (dbus-debug)
(dbus-ignore-errors
(dbus-call-method
bus service path dbus-interface-objectmanager
"GetManagedObjects" :timeout 1000)))))
(if result
;; Massage the returned structure.

52
src/dbusbind.c
View file

@ -1269,6 +1269,10 @@ The following usages are expected:
(dbus-message-internal
dbus-message-type-error BUS SERVICE SERIAL ERROR-NAME &rest ARGS)
`dbus-check-arguments': (does not send a message)
(dbus-message-internal
dbus-message-type-invalid BUS SERVICE &rest ARGS)
usage: (dbus-message-internal &rest REST) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
@ -1286,7 +1290,7 @@ usage: (dbus-message-internal &rest REST) */)
dbus_uint32_t serial = 0;
unsigned int ui_serial;
int timeout = -1;
ptrdiff_t count;
ptrdiff_t count, count0;
char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
/* Initialize parameters. */
@ -1296,7 +1300,7 @@ usage: (dbus-message-internal &rest REST) */)
handler = Qnil;
CHECK_FIXNAT (message_type);
if (! (DBUS_MESSAGE_TYPE_INVALID < XFIXNAT (message_type)
if (! (DBUS_MESSAGE_TYPE_INVALID <= XFIXNAT (message_type)
&& XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES))
XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
mtype = XFIXNAT (message_type);
@ -1311,13 +1315,16 @@ usage: (dbus-message-internal &rest REST) */)
handler = args[6];
count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
}
else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
{
serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
if (mtype == DBUS_MESSAGE_TYPE_ERROR)
error_name = args[4];
count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4;
}
else /* DBUS_MESSAGE_TYPE_INVALID */
count = 3;
/* Check parameters. */
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
@ -1367,7 +1374,7 @@ usage: (dbus-message-internal &rest REST) */)
XD_OBJECT_TO_STRING (service),
ui_serial);
break;
default: /* DBUS_MESSAGE_TYPE_ERROR */
case DBUS_MESSAGE_TYPE_ERROR:
ui_serial = serial;
XD_DEBUG_MESSAGE ("%s %s %s %u %s",
XD_MESSAGE_TYPE_TO_STRING (mtype),
@ -1375,17 +1382,25 @@ usage: (dbus-message-internal &rest REST) */)
XD_OBJECT_TO_STRING (service),
ui_serial,
XD_OBJECT_TO_STRING (error_name));
break;
default: /* DBUS_MESSAGE_TYPE_INVALID */
XD_DEBUG_MESSAGE ("%s %s %s",
XD_MESSAGE_TYPE_TO_STRING (mtype),
XD_OBJECT_TO_STRING (bus),
XD_OBJECT_TO_STRING (service));
}
/* Retrieve bus address. */
connection = xd_get_connection_address (bus);
/* Create the D-Bus message. */
dmessage = dbus_message_new (mtype);
/* Create the D-Bus message. Since DBUS_MESSAGE_TYPE_INVALID is not
a valid message type, we mockup it with DBUS_MESSAGE_TYPE_SIGNAL. */
dmessage = dbus_message_new
((mtype == DBUS_MESSAGE_TYPE_INVALID) ? DBUS_MESSAGE_TYPE_SIGNAL : mtype);
if (dmessage == NULL)
XD_SIGNAL1 (build_string ("Unable to create a new message"));
if (STRINGP (service))
if ((STRINGP (service)) && (mtype != DBUS_MESSAGE_TYPE_INVALID))
{
if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
/* Set destination. */
@ -1427,7 +1442,8 @@ usage: (dbus-message-internal &rest REST) */)
XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
}
else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
{
if (!dbus_message_set_reply_serial (dmessage, serial))
XD_SIGNAL1 (build_string ("Unable to create a return message"));
@ -1449,6 +1465,7 @@ usage: (dbus-message-internal &rest REST) */)
dbus_message_iter_init_append (dmessage, &iter);
/* Append parameters to the message. */
count0 = count - 1;
for (; count < nargs; ++count)
{
dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
@ -1456,15 +1473,17 @@ usage: (dbus-message-internal &rest REST) */)
{
XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4,
XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s Parameter%"pD"d: %s",
count - count0,
XD_OBJECT_TO_STRING (args[count]),
count + 1 - count0,
XD_OBJECT_TO_STRING (args[count+1]));
++count;
}
else
{
XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4,
XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s", count - count0,
XD_OBJECT_TO_STRING (args[count]));
}
@ -1475,7 +1494,10 @@ usage: (dbus-message-internal &rest REST) */)
xd_append_arg (dtype, args[count], &iter);
}
if (!NILP (handler))
if (mtype == DBUS_MESSAGE_TYPE_INVALID)
result = Qt;
else if (!NILP (handler))
{
/* Send the message. The message is just added to the outgoing
message queue. */
@ -1500,7 +1522,8 @@ usage: (dbus-message-internal &rest REST) */)
result = Qnil;
}
XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
if (mtype != DBUS_MESSAGE_TYPE_INVALID)
XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
/* Cleanup. */
dbus_message_unref (dmessage);
@ -1548,7 +1571,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
}
/* Read message type, message serial, unique name, object path,
interface and member from the message. */
interface, member and error name from the message. */
mtype = dbus_message_get_type (dmessage);
ui_serial = serial =
((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
@ -1590,7 +1613,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
event.arg =
Fcons (value,
(mtype == DBUS_MESSAGE_TYPE_ERROR)
? Fcons (list2 (QCstring, build_string (error_name)), args) : args);
? Fcons (list2 (QCstring, build_string (error_name)), args)
: args);
}
else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */

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

@ -25,8 +25,6 @@
(defvar dbus-debug nil)
(declare-function dbus-get-unique-name "dbusbind.c" (bus))
(setq dbus-show-dbus-errors nil)
(defconst dbus--test-enabled-session-bus
(and (featurep 'dbusbind)
(dbus-ignore-errors (dbus-get-unique-name :session)))
@ -383,19 +381,14 @@ This includes initialization and closing the bus."
"foo"))
;; Due to `:read' access type, we don't get a proper reply
;; from `dbus-set-property'.
(should-not
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1 "foofoo"))
(let ((dbus-show-dbus-errors t))
(should
(equal
(butlast
(should-error
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1 "foofoo")))
`(dbus-error ,dbus-error-property-read-only))))
(should
(equal
(butlast
(should-error
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1 "foofoo")))
`(dbus-error ,dbus-error-property-read-only)))
(should
(string-equal
(dbus-get-property
@ -413,29 +406,29 @@ This includes initialization and closing the bus."
(,dbus--test-service ,dbus--test-path))))
;; Due to `:write' access type, we don't get a proper reply
;; from `dbus-get-property'.
(should-not
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2))
(let ((dbus-show-dbus-errors t))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2)))
`(dbus-error ,dbus-error-access-denied))))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2)))
`(dbus-error ,dbus-error-access-denied)))
(should
(string-equal
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2 "barbar")
"barbar"))
(should-not ;; Due to `:write' access type.
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2))
;; Still `:write' access type.
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property2)))
`(dbus-error ,dbus-error-access-denied)))
;; `:readwrite' property, typed value (Bug#43252).
(should
@ -465,32 +458,22 @@ This includes initialization and closing the bus."
"/baz/baz"))
;; Not registered property.
(should-not
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4))
(let ((dbus-show-dbus-errors t))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4)))
`(dbus-error ,dbus-error-unknown-property))))
(should-not
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4 "foobarbaz"))
(let ((dbus-show-dbus-errors t))
(should
(equal
(butlast
(should-error
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4 "foobarbaz")))
`(dbus-error ,dbus-error-unknown-property))))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4)))
`(dbus-error ,dbus-error-unknown-property)))
(should
(equal
(butlast
(should-error
(dbus-set-property
:session dbus--test-service dbus--test-path
dbus--test-interface property4 "foobarbaz")))
`(dbus-error ,dbus-error-unknown-property)))
;; `dbus-get-all-properties'. We cannot retrieve a value for
;; the property with `:write' access type.
@ -516,19 +499,14 @@ This includes initialization and closing the bus."
;; Unregister property.
(should (dbus-unregister-object registered))
(should-not (dbus-unregister-object registered))
(should-not
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1))
(let ((dbus-show-dbus-errors t))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1)))
`(dbus-error ,dbus-error-unknown-property)))))
(should
(equal
(butlast
(should-error
(dbus-get-property
:session dbus--test-service dbus--test-path
dbus--test-interface property1)))
`(dbus-error ,dbus-error-unknown-property))))
;; Cleanup.
(dbus-unregister-service :session dbus--test-service)))
@ -745,7 +723,7 @@ This includes initialization and closing the bus."
(read-event nil nil 0.1)))
(should
(equal
dbus--test-signal-received `(((,property ((((1) (2) (3)))))) ())))
dbus--test-signal-received `(((,property ((1 2 3)))) ())))
(should
(equal