From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Hugh Daschbach Newsgroups: gmane.emacs.bugs Subject: bug#43252: 27.1; DBus properties lack type hints or overrides Date: Tue, 29 Sep 2020 14:51:04 -0700 Message-ID: <87a6x88d6f.fsf@ccss.com> References: <87v9gqquct.fsf@ccss.com> <87een19x9n.fsf@ccss.com> <87a6xor25b.fsf@gmx.de> <87bli49rem.fsf@ccss.com> <87h7rva0ku.fsf@gmx.de> <875z8aa1bm.fsf@ccss.com> <87ft7c8p4k.fsf@gmx.de> <87imc7jqms.fsf@gmx.de> <87zh5i8o9h.fsf@ccss.com> <87eemt67eg.fsf@gmx.de> <87wo0l8908.fsf@ccss.com> <87wo0kielj.fsf@gmx.de> <87r1qr98sf.fsf@ccss.com> <87r1qrimqf.fsf@gmx.de> <87o8lu8p9p.fsf@ccss.com> <87lfgx8gz9.fsf@ccss.com> <87lfgw987l.fsf@gmx.de> <87imby8v26.fsf@ccss.com> <87zh5arrfn.fsf@gmx.de> <87ft718p9a.fsf@ccss.com> <87k0wchix3.fsf@gmx.de> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="14696"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: mu4e 1.5.5; emacs 27.1 Cc: 43252@debbugs.gnu.org To: Michael Albinus Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Tue Sep 29 23:54:10 2020 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1kNNZY-0003gC-KL for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 29 Sep 2020 23:54:09 +0200 Original-Received: from localhost ([::1]:56772 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kNNZX-0004wy-MG for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 29 Sep 2020 17:54:07 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:49754) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kNNXW-0004M6-J4 for bug-gnu-emacs@gnu.org; Tue, 29 Sep 2020 17:52:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:45858) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kNNXW-0006aj-9e for bug-gnu-emacs@gnu.org; Tue, 29 Sep 2020 17:52:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kNNXW-0001Wi-4C for bug-gnu-emacs@gnu.org; Tue, 29 Sep 2020 17:52:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Hugh Daschbach Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 29 Sep 2020 21:52:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 43252 X-GNU-PR-Package: emacs Original-Received: via spool by 43252-submit@debbugs.gnu.org id=B43252.16014162865822 (code B ref 43252); Tue, 29 Sep 2020 21:52:02 +0000 Original-Received: (at 43252) by debbugs.gnu.org; 29 Sep 2020 21:51:26 +0000 Original-Received: from localhost ([127.0.0.1]:57404 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kNNWv-0001Vp-9q for submit@debbugs.gnu.org; Tue, 29 Sep 2020 17:51:26 -0400 Original-Received: from mail1.ccss.com ([159.203.255.73]:47914) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kNNWr-0001VX-88 for 43252@debbugs.gnu.org; Tue, 29 Sep 2020 17:51:24 -0400 Original-Received: by mail1.ccss.com (Postfix, from userid 114) id 6F3EABF8A3; Tue, 29 Sep 2020 14:51:15 -0700 (PDT) Original-Received: from ccss.com (unknown [192.168.76.11]) by mail1.ccss.com (Postfix) with ESMTP id E3FA0BF89B; Tue, 29 Sep 2020 14:51:12 -0700 (PDT) Original-Received: from localhost (localhost [127.0.0.1]) by ccss.com (Postfix) with ESMTP id B923917606DC; Tue, 29 Sep 2020 14:51:12 -0700 (PDT) Original-Received: from ccss.com ([127.0.0.1]) by localhost (ccss.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id QcoAMxlnrEX4; Tue, 29 Sep 2020 14:51:04 -0700 (PDT) Original-Received: from klaatu (klaatu.lan [192.168.42.3]) (Authenticated sender: hugh) by ccss.com (Postfix) with ESMTPSA id 7FB7B1760445; Tue, 29 Sep 2020 14:51:04 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=ccss.com; s=mail; t=1601416264; bh=pjiv7bR9Mf8BKtoZKz2lf8Mski+f0ppGgMrqvrmbmWE=; h=References:From:To:Cc:Subject:In-reply-to:Date:From; b=VNu/ZuUnNfZTh7P1PBE6q2NMCEZqQFsm2YXWI2W6eZw1ky8RouhSd8cJhSQBjMbq0 dEu6bOWASYDhurzYy4mgNg4Yy6VFW6R6weije3810TtMN2cLX54nFkFacYuXDIBial 8QO1Nbe9VTj8QkbmQwuH94w2RssoM4O4tnGkw7UxcmPOVVChipISnCl/AY4VThHaoj 0NjwoW903Aks9YlP82NW03XE4Gilb+TFeZ19zEjX4NfBsnZLyFxNALecl8DEdVDAXt Bcq+4s1IzkaBfOdGH3KrFe48WjzbY0/aJs9MMd/8soioUFAlRYzBNyk8NHXOmCoybL O6J1hpO//lXRQ== In-reply-to: <87k0wchix3.fsf@gmx.de> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:189296 Archived-At: --=-=-= Content-Type: text/plain Michael Albinus writes: > Hugh Daschbach 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Add-D-Bus-property-tests.patch Content-Description: Property tests. >From dab1113aa7ae964d888d0e3b00466d55292f035d Mon Sep 17 00:00:00 2001 From: Hugh Daschbach 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-Add-D-Bus-Introspection-tests.patch Content-Description: Introspection tests. >From 1c250268d4e72ec5ff26f29e99ce138e9d22aaf3 Mon Sep 17 00:00:00 2001 From: Hugh Daschbach 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 ;; ;; +(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 00000000000..620f10510f2 --- /dev/null +++ b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0003-Add-D-Bus-timeout-tests.patch Content-Description: Timeout Tests. >From 454a9f4505bde8068675dfdf58658f752f561729 Mon Sep 17 00:00:00 2001 From: Hugh Daschbach 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0004-Add-D-Bus-method-call-reentry-test.patch Content-Description: Call method reentry test. >From 3dc9e44e2f10530ef2b20cc9f8c3851606905d5e Mon Sep 17 00:00:00 2001 From: Hugh Daschbach 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 --=-=-=--