From: Hugh Daschbach <hugh@ccss.com>
To: Michael Albinus <michael.albinus@gmx.de>
Cc: 43252@debbugs.gnu.org
Subject: bug#43252: 27.1; DBus properties lack type hints or overrides
Date: Tue, 29 Sep 2020 14:51:04 -0700 [thread overview]
Message-ID: <87a6x88d6f.fsf@ccss.com> (raw)
In-Reply-To: <87k0wchix3.fsf@gmx.de>
[-- Attachment #1: Type: text/plain, Size: 342 bytes --]
Michael Albinus writes:
> Hugh Daschbach <hugh@ccss.com> writes:
>
> Hi Hugh,
>
> Thanks. LGTM.
Thanks. I received the FSF signed copyright document. So we should be
clear for submission.
I've attached the four patches that we've been discussing: three for
bug#43252 and on for bug#43251.
Thanks for your patience and guidance.
Hugh
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Property tests. --]
[-- Type: text/x-patch, Size: 15325 bytes --]
From dab1113aa7ae964d888d0e3b00466d55292f035d 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/4] Add D-Bus property tests.
* test/lisp/net/dbus-tests.el: Add property tests.
(dbus--test-run-property-test, dbus--test-property): New defuns.
(dbus-test06-property-types): New test for property registration, set, get.
---
test/lisp/net/dbus-tests.el | 396 ++++++++++++++++++++++++++++++++++++
1 file changed, 396 insertions(+)
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index b853542a1f0..fcbb378b44f 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -1018,6 +1018,402 @@ 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 ; Property value preserved on error.
+ (equal
+ (dbus-get-property
+ :session dbus--test-service dbus--test-path dbus--test-interface
+ "StringArray")
+ '("one" "two" "three")))
+
+ (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 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-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: 16061 bytes --]
From 1c250268d4e72ec5ff26f29e99ce138e9d22aaf3 Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Tue, 22 Sep 2020 19:36:20 -0700
Subject: [PATCH 2/4] 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 +
.../dbus-resources/org.gnu.Emacs.TestDBus.xml | 49 +++
test/lisp/net/dbus-tests.el | 295 ++++++++++++++++++
3 files changed, 347 insertions(+)
create mode 100644 test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index fec9d3c7ab8..09ccc001bdb 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -165,6 +165,9 @@ dbus-interface-local
;; </signal>
;; </interface>
+(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated")
+ "An annotation indicating a deprecated interface, method, signal, or property.")
+
\f
;;; 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 00000000000..620f10510f2
--- /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 fcbb378b44f..28dcdd95c00 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -46,6 +46,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-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))
@@ -1414,6 +1421,294 @@ dbus-test06-property-types
;; 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")
--
2.28.0
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Timeout Tests. --]
[-- Type: text/x-patch, Size: 2473 bytes --]
From 454a9f4505bde8068675dfdf58658f752f561729 Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Mon, 28 Sep 2020 12:44:34 -0700
Subject: [PATCH 3/4] Add D-Bus timeout tests.
* test/lisp/net/dbus-tests.el: Add timeout tests.
(dbus-test04-call-method-timeout, dbus-test07-introspection-timeout):
New tests.
---
test/lisp/net/dbus-tests.el | 38 +++++++++++++++++++++++++++++++++++++
1 file changed, 38 insertions(+)
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 28dcdd95c00..308f22eb6cc 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -581,6 +581,28 @@ dbus-test04-register-method
;; 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)))
+
+ (dbus-unregister-service :session dbus--test-service)))
+
+
(defvar dbus--test-signal-received nil
"Received signal value in `dbus--test-signal-handler'.")
@@ -1709,6 +1731,22 @@ dbus-test07-introspection
(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)))))
+
+ (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 #5: Call method reentry test. --]
[-- Type: text/x-patch, Size: 2127 bytes --]
From 3dc9e44e2f10530ef2b20cc9f8c3851606905d5e Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Mon, 28 Sep 2020 14:34:54 -0700
Subject: [PATCH 4/4] Add D-Bus method call reentry test.
* test/lisp/net/dbus-tests.el (dbus--tests-method-reentry-handler): New defun.
(dbus-test04-method-reentry): New test.
---
test/lisp/net/dbus-tests.el | 34 ++++++++++++++++++++++++++++++++++
1 file changed, 34 insertions(+)
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 308f22eb6cc..339eaa7405d 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -581,6 +581,40 @@ dbus-test04-register-method
;; 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."
+ ;; 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 "Rentry"))
+ (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)
--
2.28.0
next prev parent reply other threads:[~2020-09-29 21:51 UTC|newest]
Thread overview: 52+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-09-07 0:54 bug#43252: 27.1; DBus properties lack type hints or overrides Hugh Daschbach
2020-09-07 7:48 ` Michael Albinus
2020-09-07 17:35 ` Hugh Daschbach
2020-09-07 18:00 ` Michael Albinus
2020-09-07 19:18 ` Hugh Daschbach
2020-09-08 14:36 ` Michael Albinus
2020-09-09 4:10 ` Hugh Daschbach
2020-09-09 4:25 ` Hugh Daschbach
2020-09-09 13:25 ` Michael Albinus
2020-09-09 16:12 ` Hugh Daschbach
2020-09-09 17:43 ` Michael Albinus
[not found] ` <874ko6979w.fsf@gmx.de>
[not found] ` <87v9gm9x9i.fsf@ccss.com>
2020-09-10 14:59 ` Michael Albinus
2020-09-10 16:57 ` Michael Albinus
2020-09-10 19:09 ` Hugh Daschbach
2020-09-11 8:46 ` Michael Albinus
2020-09-10 22:53 ` Hugh Daschbach
2020-09-11 9:57 ` Michael Albinus
2020-09-11 14:19 ` Michael Albinus
2020-09-15 4:05 ` Hugh Daschbach
2020-09-16 12:47 ` Michael Albinus
2020-09-16 22:23 ` Hugh Daschbach
2020-09-17 12:58 ` Michael Albinus
2020-09-17 18:42 ` Hugh Daschbach
2020-09-18 6:28 ` Hugh Daschbach
2020-09-18 9:55 ` Michael Albinus
2020-09-18 13:42 ` Michael Albinus
2020-09-18 15:50 ` Michael Albinus
2020-09-18 9:36 ` Michael Albinus
2020-09-19 3:32 ` Hugh Daschbach
2020-09-20 15:05 ` Michael Albinus
2020-09-21 11:50 ` Michael Albinus
2020-09-22 3:48 ` Hugh Daschbach
2020-09-22 16:09 ` Michael Albinus
2020-09-22 17:36 ` Michael Albinus
2020-09-23 3:30 ` Hugh Daschbach
2020-09-23 3:34 ` Hugh Daschbach
2020-09-23 7:44 ` Michael Albinus
2020-09-23 17:32 ` Michael Albinus
2020-09-24 3:02 ` Hugh Daschbach
2020-09-24 8:48 ` Michael Albinus
2020-09-25 4:16 ` Hugh Daschbach
2020-09-26 1:27 ` Hugh Daschbach
2020-09-26 9:51 ` Michael Albinus
2020-09-28 3:00 ` Hugh Daschbach
2020-09-28 12:55 ` Michael Albinus
2020-09-28 23:17 ` Hugh Daschbach
2020-09-29 12:22 ` Michael Albinus
2020-09-29 21:51 ` Hugh Daschbach [this message]
2020-09-30 9:34 ` Michael Albinus
2020-09-30 10:42 ` Michael Albinus
2020-09-30 16:39 ` Hugh Daschbach
2020-09-10 8:00 ` bug#43252: Fwd: " Michael Albinus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87a6x88d6f.fsf@ccss.com \
--to=hugh@ccss.com \
--cc=43252@debbugs.gnu.org \
--cc=michael.albinus@gmx.de \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).