;;; dbus-tests.el --- Tests of D-Bus integration into Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;; Code: (require 'ert) (require 'ert-x) (require 'dbus) (defvar dbus-debug nil) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) (defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :session))) "Check, whether we are registered at the session bus.") (defconst dbus--test-enabled-system-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :system))) "Check, whether we are registered at the system bus.") (defconst dbus--test-service "org.gnu.Emacs.TestDBus" "Test service.") (defconst dbus--test-path "/org/gnu/Emacs/TestDBus" "Test object path.") (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) (should (dbus-list-activatable-names bus)) (should (dbus-list-known-names bus)) (should (dbus-get-unique-name bus))) (ert-deftest dbus-test00-availability-session () "Test availability of D-Bus `:session'." :expected-result (if dbus--test-enabled-session-bus :passed :failed) (dbus--test-availability :session)) (ert-deftest dbus-test00-availability-system () "Test availability of D-Bus `:system'." :expected-result (if dbus--test-enabled-system-bus :passed :failed) (dbus--test-availability :system)) (ert-deftest dbus-test01-type-conversion () "Check type conversion functions." (skip-unless dbus--test-enabled-session-bus) (let ((ustr "0123abc_xyz\x01\xff") (mstr "Grüß Göttin")) (should (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array "")) "")) (should (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array ustr)) ustr)) (should (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array mstr) 'multibyte) mstr)) ;; Should not work for multibyte strings. (should-not (string-equal (dbus-byte-array-to-string (dbus-string-to-byte-array mstr)) mstr)) (should (string-equal (dbus-unescape-from-identifier (dbus-escape-as-identifier "")) "")) (should (string-equal (dbus-unescape-from-identifier (dbus-escape-as-identifier ustr)) ustr)) ;; Should not work for multibyte strings. (should-not (string-equal (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) (ert-deftest dbus-test01-basic-types () "Check basic D-Bus type arguments." (skip-unless dbus--test-enabled-session-bus) ;; No argument or unknown keyword. (should-error (dbus-check-arguments :session dbus--test-service) :type 'wrong-number-of-arguments) (should-error (dbus-check-arguments :session dbus--test-service :keyword) :type 'wrong-type-argument) ;; `:string'. (should (dbus-check-arguments :session dbus--test-service "string")) (should (dbus-check-arguments :session dbus--test-service :string "string")) (should-error (dbus-check-arguments :session dbus--test-service :string) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :string 0.5) :type 'wrong-type-argument) ;; `:object-path'. (should (dbus-check-arguments :session dbus--test-service :object-path "/object/path")) (should-error (dbus-check-arguments :session dbus--test-service :object-path) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :object-path "string") :type 'dbus-error) (should-error (dbus-check-arguments :session dbus--test-service :object-path 0.5) :type 'wrong-type-argument) ;; `:signature'. (should (dbus-check-arguments :session dbus--test-service :signature "as")) (should-error (dbus-check-arguments :session dbus--test-service :signature) :type 'wrong-type-argument) ;; Raises an error on stderr. (should-error (dbus-check-arguments :session dbus--test-service :signature "string") :type 'dbus-error) (should-error (dbus-check-arguments :session dbus--test-service :signature 0.5) :type 'wrong-type-argument) ;; `:boolean'. (should (dbus-check-arguments :session dbus--test-service nil)) (should (dbus-check-arguments :session dbus--test-service t)) (should (dbus-check-arguments :session dbus--test-service :boolean nil)) (should (dbus-check-arguments :session dbus--test-service :boolean t)) (should (dbus-check-arguments :session dbus--test-service :boolean 'whatever)) (should-error (dbus-check-arguments :session dbus--test-service :boolean) :type 'wrong-type-argument) ;; `:byte'. (should (dbus-check-arguments :session dbus--test-service :byte 0)) ;; Only the least significant byte is taken into account. (should (dbus-check-arguments :session dbus--test-service :byte most-positive-fixnum)) (should-error (dbus-check-arguments :session dbus--test-service :byte) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :byte -1) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :byte 0.5) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :byte "string") :type 'wrong-type-argument) ;; `:int16'. (should (dbus-check-arguments :session dbus--test-service :int16 0)) (should (dbus-check-arguments :session dbus--test-service :int16 #x7fff)) (should (dbus-check-arguments :session dbus--test-service :int16 #x-8000)) (should-error (dbus-check-arguments :session dbus--test-service :int16) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :int16 #x8000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int16 #x-8001) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int16 0.5) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :int16 "string") :type 'wrong-type-argument) ;; `:uint16'. (should (dbus-check-arguments :session dbus--test-service :uint16 0)) (should (dbus-check-arguments :session dbus--test-service :uint16 #xffff)) (should-error (dbus-check-arguments :session dbus--test-service :uint16) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :uint16 #x10000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint16 -1) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :uint16 0.5) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :uint16 "string") :type 'wrong-type-argument) ;; `:int32'. (should (dbus-check-arguments :session dbus--test-service :int32 0)) (should (dbus-check-arguments :session dbus--test-service :int32 #x7fffffff)) (should (dbus-check-arguments :session dbus--test-service :int32 #x-80000000)) (should-error (dbus-check-arguments :session dbus--test-service :int32) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :int32 #x80000000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int32 #x-80000001) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int32 0.5) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int32 "string") :type 'wrong-type-argument) ;; `:uint32'. (should (dbus-check-arguments :session dbus--test-service 0)) (should (dbus-check-arguments :session dbus--test-service :uint32 0)) (should (dbus-check-arguments :session dbus--test-service :uint32 #xffffffff)) (should-error (dbus-check-arguments :session dbus--test-service :uint32) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :uint32 #x100000000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint32 -1) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint32 0.5) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint32 "string") :type 'wrong-type-argument) ;; `:int64'. (should (dbus-check-arguments :session dbus--test-service :int64 0)) (should (dbus-check-arguments :session dbus--test-service :int64 #x7fffffffffffffff)) (should (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000000)) (should-error (dbus-check-arguments :session dbus--test-service :int64) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :int64 #x8000000000000000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000001) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int64 0.5) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :int64 "string") :type 'wrong-type-argument) ;; `:uint64'. (should (dbus-check-arguments :session dbus--test-service :uint64 0)) (should (dbus-check-arguments :session dbus--test-service :uint64 #xffffffffffffffff)) (should-error (dbus-check-arguments :session dbus--test-service :uint64) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :uint64 #x10000000000000000) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint64 -1) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint64 0.5) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :uint64 "string") :type 'wrong-type-argument) ;; `:double'. (should (dbus-check-arguments :session dbus--test-service :double 0)) (should (dbus-check-arguments :session dbus--test-service :double 0.5)) (should (dbus-check-arguments :session dbus--test-service :double -0.5)) (should (dbus-check-arguments :session dbus--test-service :double -1)) ;; Shall both be supported? (should (dbus-check-arguments :session dbus--test-service :double 1.0e+INF)) (should (dbus-check-arguments :session dbus--test-service :double 0.0e+NaN)) (should-error (dbus-check-arguments :session dbus--test-service :double) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :double "string") :type 'wrong-type-argument) ;; `:unix-fd'. UNIX file descriptors are transferred out-of-band. ;; We do not support this, and so we cannot do much testing here for ;; `:unix-fd' being an argument (which is an index to the file ;; descriptor in the array of file descriptors that accompany the ;; D-Bus message). Mainly testing, that values out of `:uint32' ;; type range fail. (should (dbus-check-arguments :session dbus--test-service :unix-fd 0)) (should-error (dbus-check-arguments :session dbus--test-service :unix-fd) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service :unix-fd -1) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :unix-fd 0.5) :type 'args-out-of-range) (should-error (dbus-check-arguments :session dbus--test-service :unix-fd "string") :type 'wrong-type-argument)) (ert-deftest dbus-test01-compound-types () "Check basic D-Bus type arguments." (skip-unless dbus--test-enabled-session-bus) ;; `:array'. It contains several elements of the same type. (should (dbus-check-arguments :session dbus--test-service '("string"))) (should (dbus-check-arguments :session dbus--test-service '(:array "string"))) (should (dbus-check-arguments :session dbus--test-service '(:array :string "string"))) (should (dbus-check-arguments :session dbus--test-service '(:array :string "string1" "string2"))) (should (dbus-check-arguments :session dbus--test-service '(:array :signature "s" :signature "ao"))) ;; Empty array (of strings). (should (dbus-check-arguments :session dbus--test-service '(:array))) ;; Empty array (of object paths). (should (dbus-check-arguments :session dbus--test-service '(:array :signature "o"))) ;; Different element types. (should-error (dbus-check-arguments :session dbus--test-service '(:array :string "string" :object-path "/object/path")) :type 'wrong-type-argument) ;; Different variant types in array don't matter. (should (dbus-check-arguments :session dbus--test-service '(:array (:variant :string "string1") (:variant (:struct :string "string2" :object-path "/object/path"))))) ;; `:variant'. It contains exactly one element. (should (dbus-check-arguments :session dbus--test-service '(:variant :string "string"))) (should (dbus-check-arguments :session dbus--test-service '(:variant (:array "string")))) ;; Empty variant. (should-error (dbus-check-arguments :session dbus--test-service '(:variant)) :type 'wrong-type-argument) ;; More than one element. (should-error (dbus-check-arguments :session dbus--test-service '(:variant :string "string" :object-path "/object/path")) :type 'wrong-type-argument) ;; `:dict-entry'. It must contain two elements; the first one must ;; be of a basic type. It must be an element of an array. (should (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry :string "string" :boolean nil)))) ;; This is an alternative syntax. (should (dbus-check-arguments :session dbus--test-service '(:array :dict-entry (:string "string" :boolean t)))) ;; Empty dict-entry. (should-error (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry))) :type 'wrong-type-argument) ;; One element. (should-error (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry :string "string"))) :type 'wrong-type-argument) (should-error (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry :string "string" :boolean t :boolean t))) :type 'wrong-type-argument) ;; The first element ist not of a basic type. (should-error (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry (:array :string "string") :boolean t))) :type 'wrong-type-argument) ;; It is not an element of an array. (should-error (dbus-check-arguments :session dbus--test-service '(:dict-entry :string "string" :boolean t)) :type 'wrong-type-argument) ;; Different dict entry types in array. (should-error (dbus-check-arguments :session dbus--test-service '(:array (:dict-entry :string "string1" :boolean t) (:dict-entry :string "string2" :object-path "/object/path"))) :type 'wrong-type-argument) ;; `:struct'. There is no restriction what could be an element of a struct. (should (dbus-check-arguments :session dbus--test-service '(:struct :string "string" :object-path "/object/path" (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4))))) ;; Empty struct. (should-error (dbus-check-arguments :session dbus--test-service '(:struct)) :type 'wrong-type-argument) ;; Different struct types in array. (should-error (dbus-check-arguments :session dbus--test-service '(:array (:struct :string "string1" :boolean t) (:struct :object-path "/object/path"))) :type 'wrong-type-argument)) (defun dbus--test-register-service (bus) "Check service registration at BUS." ;; Cleanup. (dbus-ignore-errors (dbus-unregister-service bus dbus--test-service)) ;; Register an own service. (should (eq (dbus-register-service bus dbus--test-service) :primary-owner)) (should (member dbus--test-service (dbus-list-known-names bus))) (should (eq (dbus-register-service bus dbus--test-service) :already-owner)) (should (member dbus--test-service (dbus-list-known-names bus))) ;; Unregister the service. (should (eq (dbus-unregister-service bus dbus--test-service) :released)) (should-not (member dbus--test-service (dbus-list-known-names bus))) (should (eq (dbus-unregister-service bus dbus--test-service) :non-existent)) (should-not (member dbus--test-service (dbus-list-known-names bus))) ;; A service name is a string, constructed of at least two words ;; separated by ".". (should (equal (butlast (should-error (dbus-register-service bus "s"))) `(dbus-error ,dbus-error-invalid-args))) ;; `dbus-service-dbus' is reserved for the BUS itself. (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." (skip-unless (and dbus--test-enabled-session-bus (dbus-register-service :session dbus--test-service))) (dbus--test-register-service :session) (let ((service "org.freedesktop.Notifications")) (when (member service (dbus-list-known-names :session)) ;; Cleanup. (dbus-ignore-errors (dbus-unregister-service :session service)) (should (eq (dbus-register-service :session service) :in-queue)) (should (eq (dbus-unregister-service :session service) :released)) (should (eq (dbus-register-service :session service :do-not-queue) :exists)) (should (eq (dbus-unregister-service :session service) :not-owner))))) (ert-deftest dbus-test02-register-service-system () "Check service registration at `:system' bus." (skip-unless (and dbus--test-enabled-system-bus (dbus-register-service :system dbus--test-service))) (dbus--test-register-service :system)) (ert-deftest dbus-test02-register-service-own-bus () "Check service registration with an own bus. This includes initialization and closing the bus." ;; Start bus. (let ((output (ignore-errors (shell-command-to-string "env DISPLAY= dbus-launch --sh-syntax"))) bus pid) (skip-unless (stringp output)) (when (string-match "DBUS_SESSION_BUS_ADDRESS='\\(.+\\)';" output) (setq bus (match-string 1 output))) (when (string-match "DBUS_SESSION_BUS_PID=\\([[:digit:]]+\\);" output) (setq pid (match-string 1 output))) (unwind-protect (progn (skip-unless (dbus-ignore-errors (and bus pid (featurep 'dbusbind) (dbus-init-bus bus) (dbus-get-unique-name bus) (dbus-register-service bus dbus--test-service)))) ;; Run the test. (dbus--test-register-service bus)) ;; Save exit. (when pid (call-process "kill" nil nil nil pid))))) (ert-deftest dbus-test03-peer-interface () "Check `dbus-interface-peer' methods." (skip-unless (and dbus--test-enabled-session-bus (dbus-register-service :session dbus--test-service) ;; "GetMachineId" is not implemented (yet). When it returns a ;; value, another D-Bus client like dbus-monitor is reacting ;; on `dbus-interface-peer'. We cannot test then. (not (dbus-ignore-errors (dbus-call-method :session dbus--test-service dbus-path-dbus dbus-interface-peer "GetMachineId" :timeout 100))))) (should (dbus-ping :session dbus--test-service 100)) (dbus-unregister-service :session dbus--test-service) (should-not (dbus-ping :session dbus--test-service 100))) (defun dbus--test-method-handler (&rest args) "Method handler for `dbus-test04-register-method'." (cond ;; No argument. ((null args) :ignore) ;; One argument. ((= 1 (length args)) (car args)) ;; Two arguments. ((= 2 (length args)) `(:error ,dbus-error-invalid-args ,(format-message "Wrong arguments %s" args))) ;; More than two arguments. (t (signal 'dbus-error (cons "D-Bus signal" args))))) (ert-deftest dbus-test04-register-method () "Check method registration for an own service." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((method1 "Method1") (method2 "Method2") (handler #'dbus--test-method-handler) registered) ;; The service is not registered yet. (should (equal (butlast (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 :timeout 10 "foo"))) `(dbus-error ,dbus-error-service-unknown))) ;; Register. (should (equal (setq registered (dbus-register-method :session dbus--test-service dbus--test-path dbus--test-interface method1 handler)) `((:method :session ,dbus--test-interface ,method1) (,dbus--test-service ,dbus--test-path ,handler)))) (should (equal (dbus-register-method :session dbus--test-service dbus--test-path dbus--test-interface method2 handler) `((:method :session ,dbus--test-interface ,method2) (,dbus--test-service ,dbus--test-path ,handler)))) ;; No argument, returns nil. (should-not (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1)) ;; One argument, returns the argument. (should (string-equal (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo") "foo")) ;; Two arguments, D-Bus error activated as `(:error ...)' list. (should (equal (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar")) `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) ;; Three arguments, D-Bus error activated by `dbus-error' signal. (should (equal (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar" "baz")) `(dbus-error ,dbus-error-failed "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))) ;; Unregister method. (should (dbus-unregister-object registered)) (should-not (dbus-unregister-object registered)) (should (equal (butlast (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 :timeout 10 "foo"))) `(dbus-error ,dbus-error-no-reply)))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (defun dbus--test-method-reentry-handler (&rest _args) "Method handler for `dbus-test04-method-reentry'." (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path) 42) (ert-deftest dbus-test04-method-reentry () "Check receiving method call while awaiting response. Ensure that incoming method calls are handled when call to `dbus-call-method' is in progress." :tags '(:expensive-test) ;; Simulate application registration. (Bug#43251) (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((method "Reentry")) (should (equal (dbus-register-method :session dbus--test-service dbus--test-path dbus--test-interface method #'dbus--test-method-reentry-handler) `((:method :session ,dbus--test-interface ,method) (,dbus--test-service ,dbus--test-path dbus--test-method-reentry-handler)))) (should (= (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method) 42))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test04-call-method-timeout () "Verify `dbus-call-method' request timeout." :tags '(:expensive-test) (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (dbus-register-service :session dbus--test-service) (unwind-protect (let ((start (current-time))) ;; Test timeout override for method call. (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus-interface-introspectable "Introspect" :timeout 2500) :type 'dbus-error) (should (< 2.4 (float-time (time-since start)) 2.7))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (defvar dbus--test-signal-received nil "Received signal value in `dbus--test-signal-handler'.") (defun dbus--test-signal-handler (&rest args) "Signal handler for `dbus-test*-signal' and `dbus-test08-register-monitor'." (setq dbus--test-signal-received args)) (defun dbus--test-timeout-handler (&rest _ignore) "Timeout handler, reporting a failed test." (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) (ert-deftest dbus-test05-register-signal () "Check signal registration for an own service." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((member "Member") (handler #'dbus--test-signal-handler) registered) ;; Register signal handler. (should (equal (setq registered (dbus-register-signal :session dbus--test-service dbus--test-path dbus--test-interface member handler)) `((:signal :session ,dbus--test-interface ,member) (,dbus--test-service ,dbus--test-path ,handler)))) ;; Send one argument, basic type. (setq dbus--test-signal-received nil) (dbus-send-signal :session dbus--test-service dbus--test-path dbus--test-interface member "foo") (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) (should (equal dbus--test-signal-received '("foo"))) ;; Send two arguments, compound types. (setq dbus--test-signal-received nil) (dbus-send-signal :session dbus--test-service dbus--test-path dbus--test-interface member '(:array :byte 1 :byte 2 :byte 3) '(:variant :string "bar")) (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) (should (equal dbus--test-signal-received '((1 2 3) ("bar")))) ;; Unregister signal. (should (dbus-unregister-object registered)) (should-not (dbus-unregister-object registered))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test06-register-property () "Check property registration for an own service." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((property1 "Property1") (property2 "Property2") (property3 "Property3") (property4 "Property4") registered) ;; `:read' property. (should (equal (setq registered (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property1 :read "foo")) `((:property :session ,dbus--test-interface ,property1) (,dbus--test-service ,dbus--test-path)))) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property1) "foo")) ;; Due to `:read' access type, we don't get a proper reply ;; from `dbus-set-property'. (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 :session dbus--test-service dbus--test-path dbus--test-interface property1) "foo")) ;; `:write' property. (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property2 :write "bar") `((:property :session ,dbus--test-interface ,property2) (,dbus--test-service ,dbus--test-path)))) ;; Due to `:write' access type, we don't get a proper reply ;; from `dbus-get-property'. (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")) ;; 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 (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property3 :readwrite :object-path "/baz") `((:property :session ,dbus--test-interface ,property3) (,dbus--test-service ,dbus--test-path)))) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property3) "/baz")) (should (string-equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface property3 :object-path "/baz/baz") "/baz/baz")) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property3) "/baz/baz")) ;; Not registered 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. (let ((result (dbus-get-all-properties :session dbus--test-service dbus--test-path dbus--test-interface))) (should (string-equal (cdr (assoc property1 result)) "foo")) (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) (should-not (assoc property2 result))) ;; `dbus-get-all-managed-objects'. We cannot retrieve a value for ;; the property with `:write' access type. (let ((result (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path))) (should (setq result (cadr (assoc dbus--test-path result)))) (should (setq result (cadr (assoc dbus--test-interface result)))) (should (string-equal (cdr (assoc property1 result)) "foo")) (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) (should-not (assoc property2 result))) ;; Unregister property. (should (dbus-unregister-object registered)) (should-not (dbus-unregister-object registered)) (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))) ;; The following test is inspired by Bug#43146. (ert-deftest dbus-test06-register-property-several-paths () "Check property registration for an own service at several paths." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((property1 "Property1") (property2 "Property2") (property3 "Property3")) ;; First path. (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property1 :readwrite "foo") `((:property :session ,dbus--test-interface ,property1) (,dbus--test-service ,dbus--test-path)))) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property2 :readwrite "bar") `((:property :session ,dbus--test-interface ,property2) (,dbus--test-service ,dbus--test-path)))) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property1) "foo")) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property2) "bar")) (should (string-equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface property1 "foofoo") "foofoo")) (should (string-equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface property2 "barbar") "barbar")) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property1) "foofoo")) (should (string-equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property2) "barbar")) ;; Second path. (should (equal (dbus-register-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property2 :readwrite "foo") `((:property :session ,dbus--test-interface ,property2) (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) (should (equal (dbus-register-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property3 :readwrite "bar") `((:property :session ,dbus--test-interface ,property3) (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) (should (string-equal (dbus-get-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property2) "foo")) (should (string-equal (dbus-get-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property3) "bar")) (should (string-equal (dbus-set-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property2 "foofoo") "foofoo")) (should (string-equal (dbus-set-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property3 "barbar") "barbar")) (should (string-equal (dbus-get-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property2) "foofoo")) (should (string-equal (dbus-get-property :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface property3) "barbar")) ;; Everything is still fine, tested with `dbus-get-all-properties'. (let ((result (dbus-get-all-properties :session dbus--test-service dbus--test-path dbus--test-interface))) (should (string-equal (cdr (assoc property1 result)) "foofoo")) (should (string-equal (cdr (assoc property2 result)) "barbar")) (should-not (assoc property3 result))) (let ((result (dbus-get-all-properties :session dbus--test-service (concat dbus--test-path dbus--test-path) dbus--test-interface))) (should (string-equal (cdr (assoc property2 result)) "foofoo")) (should (string-equal (cdr (assoc property3 result)) "barbar")) (should-not (assoc property1 result))) ;; Final check with `dbus-get-all-managed-objects'. (let ((result (dbus-get-all-managed-objects :session dbus--test-service "/")) result1) (should (setq result1 (cadr (assoc dbus--test-path result)))) (should (setq result1 (cadr (assoc dbus--test-interface result1)))) (should (string-equal (cdr (assoc property1 result1)) "foofoo")) (should (string-equal (cdr (assoc property2 result1)) "barbar")) (should-not (assoc property3 result1)) (should (setq result1 (cadr (assoc (concat dbus--test-path dbus--test-path) result)))) (should (setq result1 (cadr (assoc dbus--test-interface result1)))) (should (string-equal (cdr (assoc property2 result1)) "foofoo")) (should (string-equal (cdr (assoc property3 result1)) "barbar")) (should-not (assoc property1 result1)))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test06-register-property-emits-signal () "Check property registration for an own service, including signalling." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (unwind-protect (let ((property "Property") (handler #'dbus--test-signal-handler)) ;; Register signal handler. (should (equal (dbus-register-signal :session dbus--test-service dbus--test-path dbus-interface-properties "PropertiesChanged" handler) `((:signal :session ,dbus-interface-properties "PropertiesChanged") (,dbus--test-service ,dbus--test-path ,handler)))) ;; Register property. (setq dbus--test-signal-received nil) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface property :readwrite "foo" 'emits-signal) `((:property :session ,dbus--test-interface ,property) (,dbus--test-service ,dbus--test-path)))) (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) ;; It returns three arguments, "interface" (a string), ;; "changed_properties" (an array of dict entries) and ;; "invalidated_properties" (an array of strings). (should (equal dbus--test-signal-received `(,dbus--test-interface ((,property ("foo"))) ()))) (should (equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property) "foo")) ;; Set property. The new value shall be signalled. (setq dbus--test-signal-received nil) (should (equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface property '(:array :byte 1 :byte 2 :byte 3)) '(1 2 3))) (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) (should (equal dbus--test-signal-received `(,dbus--test-interface ((,property ((1 2 3)))) ()))) (should (equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface property) '(1 2 3)))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (defsubst dbus--test-run-property-test (selector name value expected) "Generate a property test: register, set, get, getall sequence. This is a helper function for the macro `dbus--test-property'. The argument SELECTOR indicates whether the test should expand to `dbus-register-property' (if SELECTOR is `register') or `dbus-set-property' (if SELECTOR is `set'). The argument NAME is the property name. The argument VALUE is the value to register or set. The argument EXPECTED is a transformed VALUE representing the form `dbus-get-property' should return." (cond ((eq selector 'register) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface name :readwrite value) `((:property :session ,dbus--test-interface ,name) (,dbus--test-service ,dbus--test-path))))) ((eq selector 'set) (should (equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface name value) expected))) (t (signal 'wrong-type-argument "Selector should be 'register or 'set."))) (should (equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface name) expected)) (let ((result (dbus-get-all-properties :session dbus--test-service dbus--test-path dbus--test-interface))) (should (equal (cdr (assoc name result)) expected))) (let ((result (dbus-get-all-managed-objects :session dbus--test-service "/")) result1) (should (setq result1 (cadr (assoc dbus--test-path result)))) (should (setq result1 (cadr (assoc dbus--test-interface result1)))) (should (equal (cdr (assoc name result1)) expected)))) (defsubst dbus--test-property (name &rest value-list) "Test a D-Bus property named by string argument NAME. The argument VALUE-LIST is a sequence of pairs, where each pair represents a value form and an expected returned value form. The first pair in VALUES is used for `dbus-register-property'. Subsequent pairs of the list are tested with `dbus-set-property'." (let ((values (car value-list))) (dbus--test-run-property-test 'register name (car values) (cdr values))) (dolist (values (cdr value-list)) (dbus--test-run-property-test 'set name (car values) (cdr values)))) (ert-deftest dbus-test06-property-types () "Check property access and mutation for an own service." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (dbus-register-service :session dbus--test-service) (unwind-protect (progn (dbus--test-property "ByteArray" '((:array :byte 1 :byte 2 :byte 3) . (1 2 3)) '((:array :byte 4 :byte 5 :byte 6) . (4 5 6))) (dbus--test-property "StringArray" '((:array "one" "two" :string "three") . ("one" "two" "three")) '((:array :string "four" :string "five" "six") . ("four" "five" "six"))) (dbus--test-property "ObjectArray" '((:array :object-path "/node00" :object-path "/node01" :object-path "/node0/node02") . ("/node00" "/node01" "/node0/node02")) '((:array :object-path "/node10" :object-path "/node11" :object-path "/node0/node12") . ("/node10" "/node11" "/node0/node12"))) (dbus--test-property "Dictionary" '((:array :dict-entry (:string "four" (:variant :string "value of four")) :dict-entry ("five" (:variant :object-path "/node0")) :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6)))) . (("four" ("value of four")) ("five" ("/node0")) ("six" ((4 5 6))))) '((:array :dict-entry (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) :dict-entry ("key1" (:variant :string "value")) :dict-entry ("key2" (:variant :object-path "/node0/node1"))) . (("key0" ((7 8 9))) ("key1" ("value")) ("key2" ("/node0/node1"))))) (dbus--test-property ; Syntax emphasizing :dict compound type. "Dictionary" '((:array (:dict-entry :string "seven" (:variant :string "value of seven")) (:dict-entry "eight" (:variant :object-path "/node8")) (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81)))) . (("seven" ("value of seven")) ("eight" ("/node8")) ("nine" ((9 27 81))))) '((:array (:dict-entry :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) (:dict-entry "key5" (:variant :string "obsolete")) (:dict-entry "key6" (:variant :object-path "/node6/node7"))) . (("key4" ((7 49 125))) ("key5" ("obsolete")) ("key6" ("/node6/node7"))))) (dbus--test-property "ByteDictionary" '((:array (:dict-entry :byte 8 (:variant :string "byte-eight")) (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) . (( 8 ("byte-eight")) (16 ("/byte/sixteen")) (48 ((8 9 10)))))) (dbus--test-property "Variant" '((:variant "Variant string") . ("Variant string")) '((:variant :byte 42) . (42)) '((:variant :uint32 1000000) . (1000000)) '((:variant :object-path "/variant/path") . ("/variant/path")) '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) '((:variant (:struct 42 "string" (:object-path "/structure/path") (:variant "last"))) . ((42 "string" ("/structure/path") ("last"))))) ;; Test that :read prevents writes. (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "StringArray" :read '(:array "one" "two" :string "three")) `((:property :session ,dbus--test-interface "StringArray") (,dbus--test-service ,dbus--test-path)))) (should-error ; Cannot set property with :read access. (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface "StringArray" '(:array "seven" "eight" :string "nine")) :type 'dbus-error) (should ; Property value preserved on error. (equal (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "StringArray") '("one" "two" "three"))) ;; Test mismatched types in array. (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "MixedArray" :readwrite '(:array :object-path "/node00" :string "/node01" :object-path "/node0/node02")) :type 'wrong-type-argument) ;; Test in-range integer values. (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue" :readwrite :byte 255) `((:property :session ,dbus--test-interface "ByteValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue") 255)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "ShortValue" :readwrite :int16 32767) `((:property :session ,dbus--test-interface "ShortValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ShortValue") 32767)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "UShortValue" :readwrite :uint16 65535) `((:property :session ,dbus--test-interface "UShortValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "UShortValue") 65535)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "IntValue" :readwrite :int32 2147483647) `((:property :session ,dbus--test-interface "IntValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "IntValue") 2147483647)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "UIntValue" :readwrite :uint32 4294967295) `((:property :session ,dbus--test-interface "UIntValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "UIntValue") 4294967295)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "LongValue" :readwrite :int64 9223372036854775807) `((:property :session ,dbus--test-interface "LongValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "LongValue") 9223372036854775807)) (should (equal (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "ULongValue" :readwrite :uint64 18446744073709551615) `((:property :session ,dbus--test-interface "ULongValue") (,dbus--test-service ,dbus--test-path)))) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ULongValue") 18446744073709551615)) ;; Test integer overflow. (should (= (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue" :byte 520) 8)) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue") 8)) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "ShortValue" :readwrite :int16 32800) :type 'args-out-of-range) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "UShortValue" :readwrite :uint16 65600) :type 'args-out-of-range) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "IntValue" :readwrite :int32 2147483700) :type 'args-out-of-range) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "UIntValue" :readwrite :uint32 4294967300) :type 'args-out-of-range) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "LongValue" :readwrite :int64 9223372036854775900) :type 'args-out-of-range) (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "ULongValue" :readwrite :uint64 18446744073709551700) :type 'args-out-of-range) ;; dbus-set-property may change property type. (should (= (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue" 1024) 1024)) (should (= (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue") 1024)) (should ; Another change property type test. (equal (dbus-set-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue" :boolean t) t)) (should (eq (dbus-get-property :session dbus--test-service dbus--test-path dbus--test-interface "ByteValue") t)) ;; Test invalid type specification. (should-error (dbus-register-property :session dbus--test-service dbus--test-path dbus--test-interface "InvalidType" :readwrite :keyword 128) :type 'wrong-type-argument)) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (defun dbus--test-introspect () "Return test introspection string." (when (string-equal dbus--test-path (dbus-event-path-name last-input-event)) (with-temp-buffer (insert-file-contents-literally (ert-resource-file "org.gnu.Emacs.TestDBus.xml")) (buffer-string)))) (defsubst dbus--test-validate-interface (iface-name expected-properties expected-methods expected-signals expected-annotations) "Validate an interface definition for `dbus-test07-introspection'. The argument IFACE-NAME is a string naming the interface to validate. The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and EXPECTED-ANNOTATIONS represent the names of the interface's properties, methods, signals, and annotations, respectively." (let ((interface (dbus-introspect-get-interface :session dbus--test-service dbus--test-path iface-name))) (pcase-let ((`(interface ((name . ,name)) . ,rest) interface)) (should (string-equal name iface-name)) (should (string-equal name (dbus-introspect-get-attribute interface "name"))) (let (properties methods signals annotations) (mapc (lambda (x) (let ((name (dbus-introspect-get-attribute x "name"))) (cond ((eq 'property (car x)) (push name properties)) ((eq 'method (car x)) (push name methods)) ((eq 'signal (car x)) (push name signals)) ((eq 'annotation (car x)) (push name annotations))))) rest) (should (equal (nreverse properties) expected-properties)) (should (equal (nreverse methods) expected-methods)) (should (equal (nreverse signals) expected-signals)) (should (equal (nreverse annotations) expected-annotations)))))) (defsubst dbus--test-validate-annotations (annotations expected-annotations) "Validate a list of D-Bus ANNOTATIONS. Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. And ensure each ANNOTATIONS has a value attribute marked \"true\"." (mapc (lambda (annotation) (let ((name (dbus-introspect-get-attribute annotation "name")) (value (dbus-introspect-get-attribute annotation "value"))) (should (member name expected-annotations)) (should (equal value "true")))) annotations)) (defsubst dbus--test-validate-property (interface property-name _expected-annotations &rest expected-args) "Validate a property definition for `dbus-test07-introspection'. The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. The argument PROPERTY-NAME is a string naming the property to validate. The arguments EXPECTED-ANNOTATIONS is a list of strings matching the annotation names defined for the method or signal. The argument EXPECTED-ARGS is a list of expected arguments for the property." (let* ((property (dbus-introspect-get-property :session dbus--test-service dbus--test-path interface property-name)) (name (dbus-introspect-get-attribute property "name")) (type (dbus-introspect-get-attribute property "type")) (access (dbus-introspect-get-attribute property "access")) (expected (assoc-string name expected-args))) (should expected) (should (string-equal name property-name)) (should (string-equal (nth 0 expected) name)) (should (string-equal (nth 1 expected) type)) (should (string-equal (nth 2 expected) access)))) (defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args) "Validate a method or signal definition for `dbus-test07-introspection'. The argument TREE is an sexp returned from either `dbus-introspect-get-method' or `dbus-introspect-get-signal' The arguments EXPECTED-ANNOTATIONS is a list of strings matching the annotation names defined for the method or signal. The argument EXPECTED-ARGS is a list of expected arguments for the method or signal." (let (args annotations) (mapc (lambda (elem) (cond ((eq 'arg (car elem)) (push elem args)) ((eq 'annotation (car elem)) (push elem annotations)))) tree) (should (equal (nreverse args) expected-args)) (dbus--test-validate-annotations annotations expected-annotations))) (defsubst dbus--test-validate-signal (interface signal-name expected-annotations &rest expected-args) "Validate a signal definition for `dbus-test07-introspection'. The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. The argument SIGNAL-NAME is a string naming the signal to validate. The arguments EXPECTED-ANNOTATIONS is a list of strings matching the annotation names defined for the signal. The argument EXPECTED-ARGS is a list of expected arguments for the signal." (let ((signal (dbus-introspect-get-signal :session dbus--test-service dbus--test-path interface signal-name))) (pcase-let ((`(signal ((name . ,name)) . ,rest) signal)) (should (string-equal name signal-name)) (should (string-equal name (dbus-introspect-get-attribute signal "name"))) (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) (defsubst dbus--test-validate-method (interface method-name expected-annotations &rest expected-args) "Validate a method definition for `dbus-test07-introspection'. The argument INTERFACE is a string naming the interface owning METHOD-NAME. The argument METHOD-NAME is a string naming the method to validate. The arguments EXPECTED-ANNOTATIONS is a list of strings matching the annotation names defined for the method. The argument EXPECTED-ARGS is a list of expected arguments for the method." (let ((method (dbus-introspect-get-method :session dbus--test-service dbus--test-path interface method-name))) (pcase-let ((`(method ((name . ,name)) . ,rest) method)) (should (string-equal name method-name)) (should (string-equal name (dbus-introspect-get-attribute method "name"))) (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) (ert-deftest dbus-test07-introspection () "Register an Introspection interface then query it." (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (dbus-register-service :session dbus--test-service) ;; Prepare introspection response. (dbus-register-method :session dbus--test-service dbus--test-path dbus-interface-introspectable "Introspect" 'dbus--test-introspect) (dbus-register-method :session dbus--test-service (concat dbus--test-path "/node0") dbus-interface-introspectable "Introspect" 'dbus--test-introspect) (dbus-register-method :session dbus--test-service (concat dbus--test-path "/node1") dbus-interface-introspectable "Introspect" 'dbus--test-introspect) (unwind-protect (let ((start (current-time))) ;; dbus-introspect-get-node-names (should (equal (dbus-introspect-get-node-names :session dbus--test-service dbus--test-path) '("node0" "node1"))) ;; dbus-introspect-get-all-nodes (should (equal (dbus-introspect-get-all-nodes :session dbus--test-service dbus--test-path) (list dbus--test-path (concat dbus--test-path "/node0") (concat dbus--test-path "/node1")))) ;; dbus-introspect-get-interface-names (let ((interfaces (dbus-introspect-get-interface-names :session dbus--test-service dbus--test-path))) (should (equal interfaces `(,dbus-interface-introspectable ,dbus-interface-properties ,dbus--test-interface))) (dbus--test-validate-interface dbus-interface-introspectable nil '("Introspect") nil nil) ;; dbus-introspect-get-interface via `dbus--test-validate-interface'. (dbus--test-validate-interface dbus-interface-properties nil '("Get" "Set" "GetAll") '("PropertiesChanged") nil) (dbus--test-validate-interface dbus--test-interface '("Connected" "Player") '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil `(,dbus-annotation-deprecated))) ;; dbus-introspect-get-method-names (let ((methods (dbus-introspect-get-method-names :session dbus--test-service dbus--test-path dbus--test-interface))) (should (equal methods '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) ;; dbus-introspect-get-method via `dbus--test-validate-method'. (dbus--test-validate-method dbus--test-interface "Connect" nil '(arg ((name . "uuid") (type . "s") (direction . "in"))) '(arg ((name . "mode") (type . "y") (direction . "in"))) '(arg ((name . "options") (type . "a{sv}") (direction . "in"))) '(arg ((name . "interface") (type . "s") (direction . "out")))) (dbus--test-validate-method dbus--test-interface "DeprecatedMethod0" `(,dbus-annotation-deprecated)) (dbus--test-validate-method dbus--test-interface "DeprecatedMethod1" `(,dbus-annotation-deprecated))) ;; dbus-introspect-get-signal-names (let ((signals (dbus-introspect-get-signal-names :session dbus--test-service dbus--test-path dbus-interface-properties))) (should (equal signals '("PropertiesChanged"))) ;; dbus-introspect-get-signal via `dbus--test-validate-signal'. (dbus--test-validate-signal dbus-interface-properties "PropertiesChanged" nil '(arg ((name . "interface") (type . "s"))) '(arg ((name . "changed_properties") (type . "a{sv}"))) '(arg ((name . "invalidated_properties") (type . "as"))))) ;; dbus-intropct-get-property-names (let ((properties (dbus-introspect-get-property-names :session dbus--test-service dbus--test-path dbus--test-interface))) (should (equal properties '("Connected" "Player"))) ;; dbus-introspect-get-property via `dbus--test-validate-property'. (dbus--test-validate-property dbus--test-interface "Connected" nil '("Connected" "b" "read") '("Player" "o" "read"))) ;; Elapsed time over a second suggests timeouts. (should (< 0.0 (float-time (time-since start)) 1.0))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test07-introspection-timeout () "Verify introspection request timeouts." :tags '(:expensive-test) (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (dbus-register-service :session dbus--test-service) (unwind-protect (let ((start (current-time))) (dbus-introspect-xml :session dbus--test-service dbus--test-path) ;; Introspection internal timeout is one second. (should (< 1.0 (float-time (time-since start))))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test08-register-monitor () "Check monitor registration." :tags '(:expensive-test) (skip-unless dbus--test-enabled-session-bus) (unwind-protect (let (registered) (should (equal (setq registered (dbus-register-monitor :session #'dbus--test-signal-handler)) '((:monitor :session-private) (nil nil dbus--test-signal-handler)))) ;; Send a signal, shall be traced. (setq dbus--test-signal-received nil) (dbus-send-signal :session dbus--test-service dbus--test-path dbus--test-interface "Foo" "foo") (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) ;; Unregister monitor. (should (dbus-unregister-object registered)) (should-not (dbus-unregister-object registered)) ;; Send a signal, shall not be traced. (setq dbus--test-signal-received nil) (dbus-send-signal :session dbus--test-service dbus--test-path dbus--test-interface "Foo" "foo") (with-timeout (1 (ignore)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) (should-not dbus--test-signal-received)) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (ert-deftest dbus-test09-get-managed-objects () "Check `dbus-get-all-managed-objects'." :tags '(:expensive-test) (skip-unless dbus--test-enabled-session-bus) (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) (dbus-register-service :session dbus--test-service) (unwind-protect (let ((interfaces `((,(concat dbus--test-interface ".I0") ((,(concat dbus--test-path "/obj1") (("I0Property1" . "Zero one one") ("I0Property2" . "Zero one two") ("I0Property3" . "Zero one three"))) (,(concat dbus--test-path "/obj0/obj2") (("I0Property1" . "Zero two one") ("I0Property2" . "Zero two two") ("I0Property3" . "Zero two three"))) (,(concat dbus--test-path "/obj0/obj3") (("I0Property1" . "Zero three one") ("I0Property2" . "Zero three two") ("I0Property3" . "Zero three three"))))) (,(concat dbus--test-interface ".I1") ((,(concat dbus--test-path "/obj0/obj2") (("I1Property1" . "One one one") ("I1Property2" . "One one two"))) (,(concat dbus--test-path "/obj0/obj3") (("I1Property1" . "One two one") ("I1Property2" . "One two two")))))))) (should-not (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path)) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) (dolist (obj objs) (pcase-let ((`(,path ,props) obj)) (dolist (prop props) (should (equal (dbus-register-property :session dbus--test-service path iname (car prop) :readwrite (cdr prop)) `((:property :session ,iname ,(car prop)) (,dbus--test-service ,path))))))))) (let ((result (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path))) (should (= 3 (length result))) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) (dolist (obj objs) (pcase-let ((`(,path ,props) obj)) (let* ((object (cadr (assoc-string path result))) (iface (cadr (assoc-string iname object)))) (should object) (should iface) (dolist (prop props) (should (equal (cdr (assoc-string (car prop) iface)) (cdr prop)))))))))) (let ((result (dbus-get-all-managed-objects :session dbus--test-service (concat dbus--test-path "/obj0")))) (should (= 2 (length result))) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) (dolist (obj objs) (pcase-let ((`(,path ,props) obj)) (when (string-prefix-p (concat dbus--test-path "/obj0/") path) (let* ((object (cadr (assoc-string path result))) (iface (cadr (assoc-string iname object)))) (should object) (should iface) (dolist (prop props) (should (equal (cdr (assoc-string (car prop) iface)) (cdr prop))))))))))) (let ((result (dbus-get-all-managed-objects :session dbus--test-service (concat dbus--test-path "/obj0/obj2")))) (should (= 1 (length result))) (dolist (interface interfaces) (pcase-let ((`(,iname ,objs) interface)) (dolist (obj objs) (pcase-let ((`(,path ,props) obj)) (when (string-prefix-p (concat dbus--test-path "/obj0/obj2") path) (let* ((object (cadr (assoc-string path result))) (iface (cadr (assoc-string iname object)))) (should object) (should iface) (dolist (prop props) (should (equal (cdr (assoc-string (car prop) iface)) (cdr prop)))))))))))) ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) "^dbus")) (provide 'dbus-tests) ;;; dbus-tests.el ends here