[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master f8624fb: Make D-Bus properties type safe
|
From: |
Michael Albinus |
|
Subject: |
master f8624fb: Make D-Bus properties type safe |
|
Date: |
Sun, 20 Sep 2020 10:44:25 -0400 (EDT) |
branch: master
commit f8624fb834e2d49eb7876f9768d668194ce6e407
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>
Make D-Bus properties type safe
* 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.
---
doc/misc/dbus.texi | 43 +++++++------
etc/NEWS | 16 ++---
lisp/net/dbus.el | 154 +++++++++++++++++++++++---------------------
src/dbusbind.c | 52 +++++++++++----
test/lisp/net/dbus-tests.el | 122 ++++++++++++++---------------------
5 files changed, 201 insertions(+), 186 deletions(-)
diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi
index ef5f0b6..bea5581 100644
--- a/doc/misc/dbus.texi
+++ b/doc/misc/dbus.texi
@@ -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
diff --git a/etc/NEWS b/etc/NEWS
index 14d5200..1f52341 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -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.
----------------------------------------------------------------------
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index aab08dd..458ee81 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -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.
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 46e2e22..eb883e5 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -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. */
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 8affc2d..b12b027 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master f8624fb: Make D-Bus properties type safe,
Michael Albinus <=