From: Michael Albinus Date: Wed, 16 Sep 2020 12:32:57 +0000 (+0200) Subject: D-Bus: keep type information in D-Bus events X-Git-Tag: emacs-28.0.90~6042 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=92f342f38dd82aae4a662708dd6280fdfb2e013b;p=emacs.git D-Bus: keep type information in D-Bus events * doc/misc/dbus.texi (Errors and Events): * etc/NEWS: D-Bus events keep the type information of their arguments. * lisp/net/dbus.el (dbus-check-event): Fix docstring. (dbus-delete-types, dbus-flatten-types): New defuns. (dbus-handle-event, dbus-register-property, dbus-property-handler): Handle type information. (dbus-set-property): Fix thinko. * src/dbusbind.c (XD_BASIC_DBUS_TYPE): Simplify. (xd_dbus_type_to_symbol): New function. (xd_retrieve_arg): Return type information for the arguments. (xd_read_message_1): Return type information for the error name. (dbus-registered-objects-table): Fix docstring. --- diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 1d4db7e7ab3..ef5f0b6625b 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -1346,6 +1346,8 @@ message arrives, and @var{handler} is called. Example: @cindex method calls, returning @cindex returning method calls +@c https://wiki.ubuntu.com/DebuggingDBus + You can offer an own service in D-Bus, which will be visible by other D-Bus clients. See @uref{https://dbus.freedesktop.org/doc/dbus-api-design.html} for a discussion of the design. @@ -1981,8 +1983,10 @@ of the D-Bus object emitting the message. @var{interface} and @var{member} denote the message which has been sent. @var{handler} is the callback function which has been registered for -this message (@pxref{Signals}). When a @code{dbus-event} event -arrives, @var{handler} is called with @var{args} as arguments. +this message (@pxref{Signals}). @var{args} are the typed arguments as +returned from the message. They are passed to @var{handler} without +type information, when it is called during event handling in +@code{dbus-handle-event}. In order to inspect the @code{dbus-event} data, you could extend the definition of the callback function in @ref{Signals}: diff --git a/etc/NEWS b/etc/NEWS index e5a34a8978e..81a4273b0f5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -87,7 +87,7 @@ useful on systems such as FreeBSD which ships only with "etc/termcap". +++ *** Emacs now defaults to UTF-8 instead of ISO-8859-1. -This is only for the default, where the user has set no LANG (or +This is only for the default, where the user has set no 'LANG' (or similar) variable or environment. This change should lead to no user-visible changes for normal usage. @@ -128,12 +128,12 @@ and mode line. ('mwheel-mode' is enabled by default on most graphical displays.) --- -** The default value of 'frame-title-format' and icon-title-format' has changed. +** The default value of 'frame-title-format' and 'icon-title-format' has changed. These variables are used to display the title bar of visible frames and the title bar of an iconified frame. They now show the name of the current buffer and the text "GNU Emacs" instead of the value of 'invocation-name'. To get the old behavior back, add the following to -your Init file: +your init file: (setq frame-title-format '(multiple-frames "%b" ("" invocation-name "@" system-name))) @@ -313,14 +313,14 @@ details of marking the file at the end of the region. directories with the help of new command 'dired-vc-next-action'. +++ -*** 'dired-jump' and 'dired-jump-other-window' moved from dired-x to dired. +*** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'. The 'dired-jump' and 'dired-jump-other-window' commands have been moved from the 'dired-x' package to 'dired'. The user option 'dired-bind-jump' no longer has any effect and is now obsolete. The commands are now bound to 'C-x C-j' and 'C-x 4 C-j' by default. To get the old behavior of 'dired-bind-jump' back and unbind the above -keys, add the following to your Init file: +keys, add the following to your init file: (global-set-key "\C-x\C-j" nil) (global-set-key "\C-x4\C-j" nil) @@ -825,7 +825,7 @@ background colors or transparency, such as xbm, pbm, svg, png and gif. ** EWW +++ -*** New variable 'eww-retrieve-command'. +*** New user option 'eww-retrieve-command'. This can be used to download data via an external command. If nil (the default), then 'url-retrieve' is used. @@ -999,10 +999,10 @@ window after starting). This variable defaults to nil. ** Miscellaneous +++ -*** New variables to control the look of line/column numbers in the mode line. +*** New user options to control the look of line/column numbers in the mode line. 'mode-line-position-line-format' is the line number format (when -'line-number-mode') is on, and 'mode-line-position-column-format' is -the column number format (when 'column-number-mode') is on. These are +'line-number-mode' is on), and 'mode-line-position-column-format' is +the column number format (when 'column-number-mode' is on). These are also used if both modes are on, which leads to the default in that case going from "(5,9)" to "(L5,C9)". @@ -1166,6 +1166,9 @@ 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. +--- +*** D-Bus events keep the type information of their arguments. + * New Modes and Packages in Emacs 28.1 @@ -1306,7 +1309,7 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'semantic-flex-token-start', 'semantic-flex-token-text', 'semantic-imenu-bucketize-type-parts', 'semantic-imenu-expand-type-parts', 'semantic-imenu-expandable-token', -'semantic-init-db-hooks)', 'semantic-init-hooks', +'semantic-init-db-hooks', 'semantic-init-hooks', 'semantic-init-mode-hooks', 'semantic-java-prototype-nonterminal', 'semantic-nonterminal-abstract', 'semantic-nonterminal-full-name', 'semantic-nonterminal-leaf', 'semantic-nonterminal-protection', @@ -1367,8 +1370,8 @@ This removes the final remaining trace of old-style backquotes. 'emacs_function' and 'emacs_finalizer' for module functions and finalizers, respectively. -** Module functions can now be made interactive. Use -'make_interactive' to give a module function an interactive +** Module functions can now be made interactive. +Use 'make_interactive' to give a module function an interactive specification. ** Module functions can now install an optional finalizer that is @@ -1440,8 +1443,8 @@ This can be used to parse RGB color specs in several formats and convert them to a list '(R G B)' of primary color values. --- -** Variable 'uniquify-buffer-name-style' can now be a function. -This variable can be one of the predefined styles or a function to +** User option 'uniquify-buffer-name-style' can now be a function. +This user option can be one of the predefined styles or a function to personalize the uniquified buffer name. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index d4e6cb943df..fa910643a35 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1016,8 +1016,9 @@ D-Bus message. SERVICE and PATH are the unique name and the object path of the D-Bus object emitting the message. INTERFACE and MEMBER denote the message which has been sent. HANDLER is the function which has been registered for this message. ARGS -are the arguments passed to HANDLER, when it is called during -event handling in `dbus-handle-event'. +are the typed arguments as returned from the message. They are +passed to HANDLER without type information, when it is called +during event handling in `dbus-handle-event'. This function signals a `dbus-error' if the event is not well formed." @@ -1053,22 +1054,53 @@ formed." (functionp (nth 8 event))) (signal 'dbus-error (list "Not a valid D-Bus event" event)))) +(defun dbus-delete-types (&rest args) + "Delete type information from arguments retrieved via `dbus-handle-event'. +Basic type arguments (TYPE VALUE) will be transformed into VALUE, and +compound type arguments (TYPE VALUE) will be transformed into (VALUE)." + (car + (mapcar + (lambda (elt) + (cond + ((atom elt) elt) + ((memq (car elt) dbus-compound-types) + (mapcar #'dbus-delete-types (cdr elt))) + (t (cadr elt)))) + args))) + +(defun dbus-flatten-types (arg) + "Flatten type information from argument retrieved via `dbus-handle-event'. +Basic type arguments (TYPE VALUE) will be transformed into TYPE VALUE, and +compound type arguments (TYPE VALUE) will be kept as is." + (let (result) + (dolist (elt arg) + (cond + ((atom elt) (push elt result)) + ((and (not (memq (car elt) dbus-compound-types))) + (push (car elt) result) + (push (cadr elt) result)) + (t + (push (cons (car elt) (dbus-flatten-types (cdr elt))) result)))) + (nreverse result))) + ;;;###autoload (defun dbus-handle-event (event) "Handle events from the D-Bus. EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being -part of the event, is called with arguments ARGS. +part of the event, is called with arguments ARGS (without type information). If the HANDLER returns a `dbus-error', it is propagated as return message." (interactive "e") (condition-case err - (let (result) + (let (args result) ;; We ignore not well-formed events. (dbus-check-event event) + ;; Remove type information. + (setq args (mapcar #'dbus-delete-types (nthcdr 9 event))) ;; Error messages must be propagated. (when (= dbus-message-type-error (nth 2 event)) - (signal 'dbus-error (nthcdr 9 event))) + (signal 'dbus-error args)) ;; Apply the handler. - (setq result (apply (nth 8 event) (nthcdr 9 event))) + (setq result (apply (nth 8 event) args)) ;; Return an (error) message when it is a message call. (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors @@ -1491,7 +1523,7 @@ return nil. ;; "Set" requires a variant. (dbus-call-method bus service path dbus-interface-properties - "Set" :timeout 500 interface property (list :variant args)) + "Set" :timeout 500 interface property (cons :variant args)) ;; Return VALUE. (or (dbus-get-property bus service path interface property) (if (symbolp (car args)) (cadr args) (car args))))) @@ -1570,8 +1602,7 @@ clients from discovering the still incomplete interface. \(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \ [TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)" - (let ((signature "s") ;; FIXME: For the time being. - ;; Read basic type symbol. + (let (;; Read basic type symbol. (type (when (symbolp (car args)) (pop args))) (value (pop args)) (emits-signal (pop args)) @@ -1590,6 +1621,8 @@ clients from discovering the still incomplete interface. (signal 'wrong-type-argument (list "Value type invalid" value)))))) (unless (consp value) (setq value (list type value))) + (setq value (if (member (car value) dbus-compound-types) + (list :variant value) (cons :variant value))) ;; Add handlers for the three property-related methods. (dbus-register-method @@ -1627,8 +1660,7 @@ clients from discovering the still incomplete interface. (let ((key (list :property bus interface property)) (val (cons - (list - nil service path (list access emits-signal signature value)) + (list nil service path (list access emits-signal value)) (dbus-get-other-registered-properties bus service path interface property)))) (puthash key val dbus-registered-objects-table) @@ -1639,12 +1671,13 @@ clients from discovering the still incomplete interface. (defun dbus-property-handler (&rest args) "Default handler for the \"org.freedesktop.DBus.Properties\" interface. It will be registered for all objects created by `dbus-register-property'." - (let ((bus (dbus-event-bus-name last-input-event)) - (service (dbus-event-service-name last-input-event)) - (path (dbus-event-path-name last-input-event)) - (method (dbus-event-member-name last-input-event)) - (interface (car args)) - (property (cadr args))) + (let* ((last-input-event last-input-event) + (bus (dbus-event-bus-name last-input-event)) + (service (dbus-event-service-name last-input-event)) + (path (dbus-event-path-name last-input-event)) + (method (dbus-event-member-name last-input-event)) + (interface (car args)) + (property (cadr args))) (cond ;; "Get" returns a variant. ((string-equal method "Get") @@ -1662,13 +1695,11 @@ It will be registered for all objects created by `dbus-register-property'." "Property \"%s\" at path \"%s\" is not readable" property path))) ;; Return the result. Since variant is a list, we must embed ;; it into another list. - (t (list (if (memq (car (nth 3 object)) dbus-compound-types) - (list :variant (nth 3 object)) - (cons :variant (nth 3 object)))))))) + (t (list (nth 2 object)))))) - ;; "Set" expects the same type as registered. FIXME: Implement! + ;; "Set" needs the third typed argument from `last-input-event'. ((string-equal method "Set") - (let* ((value (caar (nth 2 args))) + (let* ((value (nth 11 last-input-event)) (entry (dbus-get-this-registered-property bus service path interface property)) (object (car (last (car entry))))) @@ -1681,13 +1712,12 @@ It will be registered for all objects created by `dbus-register-property'." `(:error ,dbus-error-property-read-only ,(format-message "Property \"%s\" at path \"%s\" is not writable" property path))) - (t (unless (consp value) - (setq value (list (car (nth 3 object)) value))) - (puthash (list :property bus interface property) + (t (puthash (list :property bus interface property) (cons (append (butlast (car entry)) - ;; Reuse ACCESS, EMITS-SIGNAL and TYPE. - (list (append (butlast object) (list value)))) + ;; Reuse ACCESS and EMITS-SIGNAL. + (list (append (butlast object) + (list (dbus-flatten-types value))))) (dbus-get-other-registered-properties bus service path interface property)) dbus-registered-objects-table) @@ -1719,11 +1749,7 @@ It will be registered for all objects created by `dbus-register-property'." (consp object) (not (eq :write (car object)))) (push - (list :dict-entry - (car (last key)) - (if (memq (car (nth 3 object)) dbus-compound-types) - (list :variant (nth 3 object)) - (cons :variant (nth 3 object)))) + (list :dict-entry (car (last key)) (nth 2 object)) result)))))) dbus-registered-objects-table) ;; Return the result, or an empty array. An array must be diff --git a/src/dbusbind.c b/src/dbusbind.c index 02af244ac38..46e2e22aa0e 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -129,36 +129,23 @@ static bool xd_in_read_queued_messages = 0; #define XD_BASIC_DBUS_TYPE(type) \ (dbus_type_is_valid (type) && dbus_type_is_basic (type)) #else -#ifdef DBUS_TYPE_UNIX_FD -#define XD_BASIC_DBUS_TYPE(type) \ - ((type == DBUS_TYPE_BYTE) \ - || (type == DBUS_TYPE_BOOLEAN) \ - || (type == DBUS_TYPE_INT16) \ - || (type == DBUS_TYPE_UINT16) \ - || (type == DBUS_TYPE_INT32) \ - || (type == DBUS_TYPE_UINT32) \ - || (type == DBUS_TYPE_INT64) \ - || (type == DBUS_TYPE_UINT64) \ - || (type == DBUS_TYPE_DOUBLE) \ - || (type == DBUS_TYPE_STRING) \ - || (type == DBUS_TYPE_OBJECT_PATH) \ - || (type == DBUS_TYPE_SIGNATURE) \ - || (type == DBUS_TYPE_UNIX_FD)) -#else #define XD_BASIC_DBUS_TYPE(type) \ - ((type == DBUS_TYPE_BYTE) \ - || (type == DBUS_TYPE_BOOLEAN) \ - || (type == DBUS_TYPE_INT16) \ - || (type == DBUS_TYPE_UINT16) \ - || (type == DBUS_TYPE_INT32) \ - || (type == DBUS_TYPE_UINT32) \ - || (type == DBUS_TYPE_INT64) \ - || (type == DBUS_TYPE_UINT64) \ - || (type == DBUS_TYPE_DOUBLE) \ - || (type == DBUS_TYPE_STRING) \ - || (type == DBUS_TYPE_OBJECT_PATH) \ - || (type == DBUS_TYPE_SIGNATURE)) + ((type == DBUS_TYPE_BYTE) \ + || (type == DBUS_TYPE_BOOLEAN) \ + || (type == DBUS_TYPE_INT16) \ + || (type == DBUS_TYPE_UINT16) \ + || (type == DBUS_TYPE_INT32) \ + || (type == DBUS_TYPE_UINT32) \ + || (type == DBUS_TYPE_INT64) \ + || (type == DBUS_TYPE_UINT64) \ + || (type == DBUS_TYPE_DOUBLE) \ + || (type == DBUS_TYPE_STRING) \ + || (type == DBUS_TYPE_OBJECT_PATH) \ + || (type == DBUS_TYPE_SIGNATURE) \ +#ifdef DBUS_TYPE_UNIX_FD + || (type == DBUS_TYPE_UNIX_FD) \ #endif + ) #endif /* This was a macro. On Solaris 2.11 it was said to compile for @@ -192,6 +179,33 @@ xd_symbol_to_dbus_type (Lisp_Object object) : DBUS_TYPE_INVALID); } +/* Determine the Lisp symbol of DBusType. */ +static Lisp_Object +xd_dbus_type_to_symbol (int type) +{ + return + (type == DBUS_TYPE_BYTE) ? QCbyte + : (type == DBUS_TYPE_BOOLEAN) ? QCboolean + : (type == DBUS_TYPE_INT16) ? QCint16 + : (type == DBUS_TYPE_UINT16) ? QCuint16 + : (type == DBUS_TYPE_INT32) ? QCint32 + : (type == DBUS_TYPE_UINT32) ? QCuint32 + : (type == DBUS_TYPE_INT64) ? QCint64 + : (type == DBUS_TYPE_UINT64) ? QCuint64 + : (type == DBUS_TYPE_DOUBLE) ? QCdouble + : (type == DBUS_TYPE_STRING) ? QCstring + : (type == DBUS_TYPE_OBJECT_PATH) ? QCobject_path + : (type == DBUS_TYPE_SIGNATURE) ? QCsignature +#ifdef DBUS_TYPE_UNIX_FD + : (type == DBUS_TYPE_UNIX_FD) ? QCunix_fd +#endif + : (type == DBUS_TYPE_ARRAY) ? QCarray + : (type == DBUS_TYPE_VARIANT) ? QCvariant + : (type == DBUS_TYPE_STRUCT) ? QCstruct + : (type == DBUS_TYPE_DICT_ENTRY) ? QCdict_entry + : Qnil; +} + /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */ #define XD_DBUS_TYPE_P(object) \ (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID))) @@ -816,7 +830,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); val = val & 0xFF; XD_DEBUG_MESSAGE ("%c %u", dtype, val); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_BOOLEAN: @@ -824,7 +838,8 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_bool_t val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true"); - return (val == FALSE) ? Qnil : Qt; + return list2 (xd_dbus_type_to_symbol (dtype), + (val == FALSE) ? Qnil : Qt); } case DBUS_TYPE_INT16: @@ -834,7 +849,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_UINT16: @@ -844,7 +859,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_INT32: @@ -854,7 +869,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_UINT32: @@ -867,7 +882,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %u", dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_INT64: @@ -876,7 +891,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); intmax_t pval = val; XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_UINT64: @@ -885,7 +900,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); uintmax_t pval = val; XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_DOUBLE: @@ -893,7 +908,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) double val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %f", dtype, val); - return make_float (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_float (val)); } case DBUS_TYPE_STRING: @@ -903,7 +918,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) char *val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %s", dtype, val); - return build_string (val); + return list2 (xd_dbus_type_to_symbol (dtype), build_string (val)); } case DBUS_TYPE_ARRAY: @@ -923,7 +938,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_next (&subiter); } XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result)); - return Fnreverse (result); + return Fcons (xd_dbus_type_to_symbol (dtype), Fnreverse (result)); } default: @@ -1544,7 +1559,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) path = dbus_message_get_path (dmessage); interface = dbus_message_get_interface (dmessage); member = dbus_message_get_member (dmessage); - error_name =dbus_message_get_error_name (dmessage); + error_name = dbus_message_get_error_name (dmessage); XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s", XD_MESSAGE_TYPE_TO_STRING (mtype), @@ -1572,9 +1587,10 @@ 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 (list2 (QCstring, build_string (error_name)), args) : args); } else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ @@ -1828,7 +1844,7 @@ wildcard then. OBJECT is either the handler to be called when a D-Bus message, which matches the key criteria, arrives (TYPE `:method' and `:signal'), or a -list (ACCESS EMITS-SIGNAL SIGNATURE VALUE) for TYPE `:property'. +list (ACCESS EMITS-SIGNAL VALUE) for TYPE `:property'. For entries of type `:signal', there is also a fifth element RULE, which keeps the match string the signal is registered with.