From: Michael Albinus Date: Sun, 20 Sep 2020 14:44:17 +0000 (+0200) Subject: Make D-Bus properties type safe X-Git-Tag: emacs-28.0.90~5982 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f8624fb834e2d49eb7876f9768d668194ce6e407;p=emacs.git 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. --- diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index ef5f0b6625b..bea55814868 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 14d52008ac1..1f52341ae44 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 aab08dd0d42..458ee81d70f 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 46e2e22aa0e..eb883e5dc83 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 8affc2ddd45..b12b02771ad 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