master 0bc19c1 2/4: Add D-Bus introspection tests

[Michael Albinus]

branch: master
commit 0bc19c17fd003655c28656cffe73fa5b2a36d11f
Author: Hugh Daschbach <hdasch@fastmail.com>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Add D-Bus introspection tests
    
    * lisp/net/dbus.el (dbus-annotation-deprecated): New defconst.
    
    * test/lisp/net/dbus-tests.el  (dbus--tests-dir): New defvar.
    (dbus--test-introspect, dbus--test-validate-interface)
    (dbus--test-validate-annotations, dbus--test-validate-property)
    (dbus--test-validate-m-or-s, dbus--test-validate-signal)
    (dbus--test-validate-method): New defuns.
    (dbus-test07-introspection): New test.
    
    * test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml:
    New test data.
---
 lisp/net/dbus.el                                   |   3 +
 .../net/dbus-resources/org.gnu.Emacs.TestDBus.xml  |  49 ++++
 test/lisp/net/dbus-tests.el                        | 295 +++++++++++++++++++++
 3 files changed, 347 insertions(+)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 23ba191..48712a9 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -165,6 +165,9 @@ See URL 
`https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-b
 ;;   </signal>
 ;; </interface>
 
+(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated")
+  "An annotation indicating a deprecated interface, method, signal, or 
property.")
+
 
 ;;; Default D-Bus errors.
 
diff --git a/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml 
b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml
new file mode 100644
index 0000000..620f105
--- /dev/null
+++ b/test/lisp/net/dbus-resources/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>
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index b88b257..bb153f0 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -46,6 +46,13 @@
 (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface"
   "Test interface.")
 
+(defvar dbus--tests-dir
+  (file-truename
+   (expand-file-name "dbus-resources"
+                     (file-name-directory (or load-file-name
+                                              buffer-file-name))))
+  "Directory containing introspection test data file.")
+
 (defun dbus--test-availability (bus)
   "Test availability of D-Bus BUS."
   (should (dbus-list-names bus))
@@ -1465,6 +1472,294 @@ Subsequent pairs of the list are tested with 
`dbus-set-property'."
     ;; 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 (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-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)
+            (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-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)))
+
+    (dbus-unregister-service :session dbus--test-service)))
+
 (defun dbus-test-all (&optional interactive)
   "Run all tests for \\[dbus]."
   (interactive "p")