bug#43252: 27.1; DBus properties lack type hints or overrides

[Hugh Daschbach <hugh@ccss.com>]

[-- Attachment #1: Type: text/plain, Size: 332 bytes --]


Hugh Daschbach writes:

> Michael Albinus writes:
>
>> Hugh Daschbach <hugh@ccss.com> writes:
>>
>> Hi Hugh,
>>
>> Thanks for this. AFAICS, there's nothing left open for 
>> bug#43252; I'd
>> like to close it. Is this OK for you?
>
> Yes.  I was about to suggest this.  The issue is resoled.

Sigh.  Forgot to attach new patches.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Property tests. --]
[-- Type: text/x-patch, Size: 15528 bytes --]

From be45a75b315e56649fa9e39d199fe5e2b50bf69d Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Tue, 22 Sep 2020 19:36:20 -0700
Subject: [PATCH 1/2] Add D-Bus property tests.

* test/lisp/net/dbus-tests.el: Add property tests.
(dbus--test-run-property-test) (dbus--test-property)
(dbus-test06-property-types): Test property registration, set, get.
---
 test/lisp/net/dbus-tests.el | 431 ++++++++++++++++++++++++++++++++++++
 1 file changed, 431 insertions(+)

diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 62ed3f2bfb4..543b7c8a95b 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -1004,6 +1004,437 @@ dbus-test06-register-property-emits-signal
     ;; 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-not
+         (equal
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "StringArray")
+          '("seven" "eight" "nine")))
+
+        (should                             ; Verify property has registered value
+         (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
+         (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.
+
+
+    (message "cleanup")
+    (dbus-unregister-service :session dbus--test-service)))
+
 (defun dbus-test-all (&optional interactive)
   "Run all tests for \\[dbus]."
   (interactive "p")
-- 
2.28.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Introspection tests. --]
[-- Type: text/x-patch, Size: 15848 bytes --]

From 3efb1b38d75572b14ac0526dbd79769d6fa89d10 Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Mon, 21 Sep 2020 17:12:49 -0700
Subject: [PATCH 2/2] Add D-Bus Introspection tests.

* lisp/net/dbus.el (new defconst): D-Bus deprecation name.

* test/lisp/net/dbus-tests.el  (dbus--tests-dir)
(dbus--test-introspect) (dbus--test-examine-interface)
(dbus--test-validate-annotations) (dbus--test-validate-property)
(dbus--test-validate-m-or-s) (dbus--test-validate-signal)
(dbus--test-validate-method) (dbus-test07-introspection): new tests.

* test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml: new test data.
---
 lisp/net/dbus.el                              |   4 +
 test/lisp/net/dbus-tests.el                   | 324 ++++++++++++++++++
 .../net/dbus-tests/org.gnu.Emacs.TestDBus.xml |  49 +++
 3 files changed, 377 insertions(+)
 create mode 100644 test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 86db7cbf18a..8da3245800b 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -153,6 +153,10 @@ dbus-interface-local
 ;;   </signal>
 ;; </interface>
 
+(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated")
+  "An annotation value indicating a deprecated interface, method, signal, or property.")
+
+
 \f
 ;;; Default D-Bus errors.
 
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 543b7c8a95b..15d80f79a22 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -44,6 +44,13 @@ dbus--test-path
 (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
   "Test interface.")
 
+(defvar dbus--tests-dir
+  (file-truename
+   (expand-file-name "dbus-tests"
+                     (file-name-directory (or load-file-name
+                                              buffer-file-name))))
+  "Directory containing test data files.")
+
 (defun dbus--test-availability (bus)
   "Test availability of D-Bus BUS."
   (should (dbus-list-names bus))
@@ -1435,6 +1442,323 @@ dbus-test06-property-types
     (message "cleanup")
     (dbus-unregister-service :session dbus--test-service)))
 
+(defun dbus--test-introspect ()
+  "Return test introspection string."
+  (with-temp-buffer
+    (insert-file (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir))
+    (buffer-string)))
+
+(defsubst dbus--test-validate-interface
+  (iface-name expected-properties expected-methods expected-signals
+              expected-annotations)
+  "Validate an interface definition for `dbus-test-07-test-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, respecively."
+
+  (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-test-07-test-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 represent the names of the property's properties.
+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-test-07-test-introspection'.
+The argument TREE is an sexp returned from either `dbus-introspect-get-method'
+or `dbus-introspect-get-signal'
+The arguments EXPECTED-ANNOTATIONS is an sexp matching the annotations 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)
+            (let ((name (dbus-introspect-get-attribute elem "name")))
+              (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-test-07-test-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 represent the names of the signal's properties.
+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-test-07-test-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 represent the names of the method's properties.
+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 ()
+  :tags '(:expensive-test)
+  "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 introspections response
+  (dbus-register-method
+   :session dbus--test-service
+   dbus--test-path
+   dbus-interface-introspectable
+   "Introspect"
+   'dbus--test-introspect)
+
+  (unwind-protect
+      (progn
+        ;; 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"))))
+
+    (dbus-unregister-service :session dbus--test-service)))
+
 (defun dbus-test-all (&optional interactive)
   "Run all tests for \\[dbus]."
   (interactive "p")
diff --git a/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml
new file mode 100644
index 00000000000..620f10510f2
--- /dev/null
+++ b/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml
@@ -0,0 +1,49 @@
+<?xml version="1.0"?>
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node>
+  <interface name="org.freedesktop.DBus.Introspectable">
+    <method name="Introspect">
+      <arg name="xml" type="s" direction="out"/>
+    </method>
+  </interface>
+  <interface name="org.freedesktop.DBus.Properties">
+    <method name="Get">
+      <arg name="interface" type="s" direction="in"/>
+      <arg name="name" type="s" direction="in"/>
+      <arg name="value" type="v" direction="out"/>
+    </method>
+    <method name="Set">
+      <arg name="interface" type="s" direction="in"/>
+      <arg name="name" type="s" direction="in"/>
+      <arg name="value" type="v" direction="in"/>
+    </method>
+    <method name="GetAll">
+      <arg name="interface" type="s" direction="in"/>
+      <arg name="properties" type="a{sv}" direction="out"/>
+    </method>
+    <signal name="PropertiesChanged">
+      <arg name="interface" type="s"/>
+      <arg name="changed_properties" type="a{sv}"/>
+      <arg name="invalidated_properties" type="as"/>
+    </signal>
+  </interface>
+  <interface name="org.gnu.Emacs.TestDBus.Interface">
+    <method name="Connect">
+      <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"/>
+    </method>
+    <method name="DeprecatedMethod0">
+      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+    </method>
+    <method name="DeprecatedMethod1">
+      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+    </method>
+    <property name="Connected" type="b" access="read"/>
+    <property name="Player" type="o" access="read"/>
+    <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+  </interface>
+  <node name="node0"/>
+  <node name="node1"/>
+</node>
-- 
2.28.0


[-- Attachment #4: Type: text/plain, Size: 15 bytes --]


Cheers,
Hugh