>From 41ad18f0094740220d5df62c656dc09cf4c18c97 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] Draft introspection tests.

Define an Introspection interface.  Then use dbus-introspect-*
methods to examine and verify the elements of the interface.
---
 test/lisp/net/dbus-tests.el | 362 ++++++++++++++++++++++++++++++++++++
 1 file changed, 362 insertions(+)

diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 993a2e3848a..e047dcc5fae 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -1275,6 +1275,368 @@ dbus-test06-test-property-types
     (message "cleanup")
     (dbus-unregister-service :session dbus--test-service)))
 
+(defun dbus--test-introspect ()
+  "Return test introspection string."
+  "<?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>
+")
+
+(defsubst dbus--test-examine-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)))))
+  ;; should we examine method and signal arguments here as well?
+  ;; or is it sufficient to test arguments from dbus-introspect-get-(method|signal)?
+  )
+
+(defsubst dbus--test-validate-annotations (annotations expected-annotations)
+  "Validate a list of DBus 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-examine-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-not (equal expected nil))
+
+    (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-examine-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-examine-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-test-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 introspections response
+  (dbus-register-method :session dbus--test-service
+                        dbus--test-path
+                        dbus-interface-introspectable
+                        "Introspect"
+                        'dbus--test-introspect)
+
+  (unwind-protect
+      ;; 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-examine-interface
+       dbus-interface-introspectable
+       nil
+       '("Introspect")
+       nil
+       nil)
+
+      ;; dbus-introspect-get-interface via `dbus--test-examine-interface'
+      (dbus--test-examine-interface
+       dbus-interface-properties
+       nil '("Get" "Set" "GetAll") '("PropertiesChanged") nil)
+
+      (dbus--test-examine-interface
+       dbus--test-interface
+       '("Connected" "Player")
+       '("Connect" "DeprecatedMethod0" "DeprecatedMethod1")
+       nil
+       '("org.freedesktop.DBus.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-examine-method
+      (dbus--test-examine-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-examine-method
+       dbus--test-interface
+       "DeprecatedMethod0"
+       '("org.freedesktop.DBus.Deprecated"))
+
+      (dbus--test-examine-method
+       dbus--test-interface
+       "DeprecatedMethod1"
+       '("org.freedesktop.DBus.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-examine-signal
+      (dbus--test-examine-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-examine-property
+      (dbus--test-examine-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")
-- 
2.28.0