From: Michael Albinus Date: Fri, 11 Sep 2020 13:34:33 +0000 (+0200) Subject: D-Bus: Implement other compound types of properties X-Git-Tag: emacs-28.0.90~6124 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=dbd8994e0daafc12153765315acefc3269b55b97;p=emacs.git D-Bus: Implement other compound types of properties * doc/misc/dbus.texi (Errors and Events): * etc/NEWS: Mention dbus-show-dbus-errors. * lisp/net/dbus.el (dbus-compound-types): New defconst. (dbus): New defgroup. (dbus-show-dbus-errors): New defcustom. (dbus-ignore-errors): Use it. (dbus-set-property): Simplify. (dbus-property-handler): Implement other compound types of properties. * test/lisp/net/dbus-tests.el (dbus--test-register-service) (dbus-test05-register-property): Extend tests. --- diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 2880b7f7430..dcee55de45e 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -2031,10 +2031,11 @@ 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 -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 @code{t}. They can also be -handled by a hook function. +@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. @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 9d266202951..73d3b7ffadb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -959,14 +959,14 @@ window after starting). This variable defaults to nil. ** Miscellaneous +++ -*** New command 'submit-emacs-patch' +*** New command 'submit-emacs-patch'. This works along the lines of 'report-emacs-bug', but is more geared towards sending a patch to the Emacs issue tracker. +++ *** New minor mode 'button-mode'. This minor mode does nothing else than install 'button-buffer-map' as -a minor mode map (which binds the TAB/S-TAB key bindings to navigate +a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate to buttons), and can be used in any view-mode-like buffer that has buttons in it. @@ -1112,9 +1112,11 @@ type symbols. +++ *** In case of problems, handlers can emit proper D-Bus error messages now. ---- ++++ *** D-Bus errors, which have been converted from incoming D-Bus error -messages, contain the error name of that message now. +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. * New Modes and Packages in Emacs 28.1 diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index b0151200ff9..fddd6df963b 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -55,6 +55,9 @@ ;;; D-Bus constants. +(defconst dbus-compound-types '(:array :variant :struct :dict-entry) + "D-Bus compound types, represented as list.") + (defconst dbus-service-dbus "org.freedesktop.DBus" "The bus name used to talk to the bus itself.") @@ -151,6 +154,17 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter ;;; Default D-Bus errors. +(defgroup dbus nil + "Elisp bindings for D-Bus." + :group 'comm + :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.") @@ -183,6 +197,7 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.") ;;; Emacs defaults. + (defconst dbus-service-emacs "org.gnu.Emacs" "The well known service name of Emacs.") @@ -199,11 +214,17 @@ shall be subdirectories of this path.") (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. -Otherwise, return result of last form in BODY, or all other errors." +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." (declare (indent 0) (debug t)) `(condition-case err (progn ,@body) - (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) + (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)))))) (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. @@ -1454,8 +1475,9 @@ valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read." (defun dbus-set-property (bus service path interface property &rest args) "Set value of PROPERTY of INTERFACE to VALUE. It will be checked at BUS, SERVICE, PATH. VALUE can be preceded -by a TYPE symbol. When the value is successfully set return -VALUE. Otherwise, return nil. +by a TYPE symbol. When the value is successfully set, and the +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 @@ -1463,11 +1485,9 @@ VALUE. Otherwise, return nil. (dbus-call-method bus service path dbus-interface-properties "Set" :timeout 500 interface property (list :variant args)) - ;; Return VALUE. The property could have the `:write' access type, - ;; so we ignore errors in `dbus-get-property'. - (dbus-ignore-errors - (or (dbus-get-property bus service path interface property) - (if (symbolp (car args)) (cadr args) (car args)))))) + ;; Return VALUE. + (or (dbus-get-property bus service path interface property) + (if (symbolp (car args)) (cadr args) (car args))))) (defun dbus-get-all-properties (bus service path interface) "Return all properties of INTERFACE at BUS, SERVICE, PATH. @@ -1635,11 +1655,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 (eq :array (car (nth 3 object))) + (t (list (if (memq (car (nth 3 object)) dbus-compound-types) (list :variant (nth 3 object)) (cons :variant (nth 3 object)))))))) - ;; "Set" expects the same type as registered. + ;; "Set" expects the same type as registered. FIXME: Implement! ((string-equal method "Set") (let* ((value (caar (nth 2 args))) (entry (dbus-get-this-registered-property @@ -1694,7 +1714,7 @@ It will be registered for all objects created by `dbus-register-property'." (push (list :dict-entry (car (last key)) - (if (eq :array (car (nth 3 object))) + (if (memq (car (nth 3 object)) dbus-compound-types) (list :variant (nth 3 object)) (cons :variant (nth 3 object)))) result)))))) @@ -1909,8 +1929,8 @@ this connection to those buses." ;;; TODO: -;; Support other compound properties but array. - +;; * Check property type in org.freedesktop.DBus.Properties.Set. +;; ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and ;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. ;; diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index a8e052efbef..73401a8c921 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -25,6 +25,8 @@ (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))) @@ -109,8 +111,16 @@ (should-not (member dbus--test-service (dbus-list-known-names bus))) ;; `dbus-service-dbus' is reserved for the BUS itself. - (should-error (dbus-register-service bus dbus-service-dbus)) - (should-error (dbus-unregister-service bus dbus-service-dbus))) + (should + (equal + (butlast + (should-error (dbus-register-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args))) + (should + (equal + (butlast + (should-error (dbus-unregister-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args)))) (ert-deftest dbus-test02-register-service-session () "Check service registration at `:session' bus." @@ -258,13 +268,8 @@ This includes initialization and closing the bus." (unwind-protect (let ((property1 "Property1") (property2 "Property2") - (property3 "Property3")) - - ;; Not registered property. - (should-not - (dbus-get-property - :session dbus--test-service dbus--test-path - dbus--test-interface property1)) + (property3 "Property3") + (property4 "Property4")) ;; `:read' property. (should @@ -280,10 +285,22 @@ This includes initialization and closing the bus." :session dbus--test-service dbus--test-path dbus--test-interface property1) "foo")) - (should-not ;; Due to `:read' access type. + ;; 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 + ;; We don't care the error message text. + (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 @@ -299,10 +316,22 @@ This includes initialization and closing the bus." dbus--test-interface property2 :write "bar") `((:property :session ,dbus--test-interface ,property2) (,dbus--test-service ,dbus--test-path)))) - (should-not ;; Due to `:write' access type. + ;; 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 + ;; We don't care the error message text. + (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 @@ -341,6 +370,36 @@ This includes initialization and closing the bus." dbus--test-interface property3) "/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 + ;; We don't care the error message text. + (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 + ;; We don't care the error message text. + (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. (let ((result