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, 22 Sep 2020 20:34:44 -0700 Message-ID: <87tuvp88tn.fsf@ccss.com> References: <87v9gqquct.fsf@ccss.com> <878sdj84kn.fsf@gmx.de> <871rjbaq05.fsf@ccss.com> <874ko6979w.fsf@gmx.de> <87v9gm9x9i.fsf@ccss.com> <871rj9k78r.fsf@gmx.de> <87imclwow5.fsf@gmx.de> <87pn6t9rbq.fsf@ccss.com> <87y2lggzvd.fsf@gmx.de> <87h7rzadlo.fsf@ccss.com> <87k0wtrir2.fsf@gmx.de> <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> 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="12588"; 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 Wed Sep 23 05:35:29 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 1kKvZ3-00036s-1a for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 23 Sep 2020 05:35:29 +0200 Original-Received: from localhost ([::1]:36452 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kKvZ1-0001yD-NW for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 22 Sep 2020 23:35:28 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:36734) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kKvYc-0001y1-O6 for bug-gnu-emacs@gnu.org; Tue, 22 Sep 2020 23:35:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:50844) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kKvYc-0001xO-Ee for bug-gnu-emacs@gnu.org; Tue, 22 Sep 2020 23:35:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kKvYc-0005X3-Bt for bug-gnu-emacs@gnu.org; Tue, 22 Sep 2020 23:35: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: Wed, 23 Sep 2020 03:35: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.160083209921249 (code B ref 43252); Wed, 23 Sep 2020 03:35:02 +0000 Original-Received: (at 43252) by debbugs.gnu.org; 23 Sep 2020 03:34:59 +0000 Original-Received: from localhost ([127.0.0.1]:34157 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kKvYX-0005We-M3 for submit@debbugs.gnu.org; Tue, 22 Sep 2020 23:34:58 -0400 Original-Received: from mail1.ccss.com ([159.203.255.73]:60828) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kKvYV-0005WM-Er for 43252@debbugs.gnu.org; Tue, 22 Sep 2020 23:34:56 -0400 Original-Received: by mail1.ccss.com (Postfix, from userid 114) id 1B437BF8A6; Tue, 22 Sep 2020 20:34:50 -0700 (PDT) Original-Received: from ccss.com (unknown [192.168.76.11]) by mail1.ccss.com (Postfix) with ESMTP id 2A1CFBF4A3; Tue, 22 Sep 2020 20:34:48 -0700 (PDT) Original-Received: from localhost (localhost [127.0.0.1]) by ccss.com (Postfix) with ESMTP id F41B2176063A; Tue, 22 Sep 2020 20:34:47 -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 hj6Nk5aW-e_q; Tue, 22 Sep 2020 20:34:44 -0700 (PDT) Original-Received: from klaatu (klaatu.lan [192.168.42.3]) (Authenticated sender: hugh) by ccss.com (Postfix) with ESMTPSA id ADB0317605C0; Tue, 22 Sep 2020 20:34:44 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=ccss.com; s=mail; t=1600832084; bh=G046B8eNtcvqIT002HqNKJz/VksxfNUsMrqUVuM4KQ4=; h=References:From:To:Cc:Subject:In-reply-to:Date:From; b=NHYK9iqa4aR4fFLkE4HcIwqhQO53VJlb7jvMsMcQacOm1LcT+9K/1ux+ZHT1ealHD +pfC+L3EsH1Bd+PgOW+uctZDF1W4YnIBD42HBe6ehj76o2Gwa6wEHUdiv7mx9uSFq6 nv83DVnOi9DW1V4lkSAH1GVZ0BCkIYu9NKHvKPUqevMlLBul7q/pAgG5DIMu2biKuP m3gc22ZjRBsY7oBamrnHeBW7cJpRWpYfFVCFQsJM0JNK0u+Mes3XljIC4LxbOVtixz cX+ix3NfUPwSg0DhjAtf5Oqgdm56GCvxk+HBtDCDX8GbcG2AG7V3hiTNFH1WaxbpAT kaKHk5hje55dA== In-reply-to: <87wo0l8908.fsf@ccss.com> 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:188757 Archived-At: --=-=-= Content-Type: text/plain; format=flowed Hugh Daschbach writes: > Michael Albinus writes: > >> Hugh Daschbach writes: >> >> Hi Hugh, >> >> Thanks for this. AFAICS, there's nothing left open for >> bug#43252; I'd >> like to close it. Is this OK for you? > > Yes. I was about to suggest this. The issue is resoled. Sigh. Forgot to attach new patches. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Add-D-Bus-property-tests.patch Content-Description: Property tests. >From be45a75b315e56649fa9e39d199fe5e2b50bf69d Mon Sep 17 00:00:00 2001 From: Hugh Daschbach Date: Tue, 22 Sep 2020 19:36:20 -0700 Subject: [PATCH 1/2] Add D-Bus property tests. * test/lisp/net/dbus-tests.el: Add property tests. (dbus--test-run-property-test) (dbus--test-property) (dbus-test06-property-types): Test property registration, set, get. --- test/lisp/net/dbus-tests.el | 431 ++++++++++++++++++++++++++++++++++++ 1 file changed, 431 insertions(+) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 62ed3f2bfb4..543b7c8a95b 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1004,6 +1004,437 @@ dbus-test06-register-property-emits-signal ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(defsubst dbus--test-run-property-test (selector name value expected) + "Generate a property test: register, set, get, getall sequence. +This is a helper function for the macro `dbus--test-property'. +The argument SELECTOR indicates whether the test should expand to +'dbus-register-property' (if SELECTOR is `register') or +`dbus-set-property' (if SELECTOR is `set'). +The argument NAME is the property name. +The argument VALUE is the value to register or set. +The argument EXPECTED is a transformed VALUE representing the +form `dbus-get-property' should return." + (cond + ((eq selector 'register) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface name :readwrite value) + `((:property :session ,dbus--test-interface ,name) + (,dbus--test-service ,dbus--test-path))))) + + ((eq selector 'set) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface name value) + expected))) + + (t (signal 'wrong-type-argument "Selector should be 'register or 'set."))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface name) + expected)) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (equal (cdr (assoc name result)) expected))) + + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (equal (cdr (assoc name result1)) expected)))) + + +(defsubst dbus--test-property (name &rest value-list) + "Test a D-Bus property named by string argument NAME. + +The argument VALUE-LIST is a sequence of pairs, where each pair +represents a value form and an expected returned value form. The +first pair in VALUES is used for `dbus-register-property'. +Subsequent pairs of the list are tested with +`dbus-set-property'." + (let ((values (car value-list))) + (dbus--test-run-property-test + 'register + name + (car values) + (cdr values))) + (dolist (values (cdr value-list)) + (dbus--test-run-property-test + 'set + name + (car values) + (cdr values)))) + +(ert-deftest dbus-test06-property-types () + "Check property access and mutation for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (progn + (dbus--test-property + "ByteArray" + '((:array :byte 1 :byte 2 :byte 3) . (1 2 3)) + '((:array :byte 4 :byte 5 :byte 6) . (4 5 6))) + + (dbus--test-property + "StringArray" + '((:array "one" "two" :string "three") . ("one" "two" "three")) + '((:array :string "four" :string "five" "six") . ("four" "five" "six"))) + + (dbus--test-property + "ObjectArray" + '((:array + :object-path "/node00" + :object-path "/node01" + :object-path "/node0/node02") . + ("/node00" "/node01" "/node0/node02")) + '((:array + :object-path "/node10" + :object-path "/node11" + :object-path "/node0/node12") . + ("/node10" "/node11" "/node0/node12"))) + + (dbus--test-property + "Dictionary" + '((:array + :dict-entry (:string "four" (:variant :string "value of four")) + :dict-entry ("five" (:variant :object-path "/node0")) + :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6)))) . + (("four" + ("value of four")) + ("five" + ("/node0")) + ("six" + ((4 5 6))))) + '((:array + :dict-entry (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) + :dict-entry ("key1" (:variant :string "value")) + :dict-entry ("key2" (:variant :object-path "/node0/node1"))) . + (("key0" + ((7 8 9))) + ("key1" + ("value")) + ("key2" + ("/node0/node1"))))) + + (dbus--test-property ; Syntax emphasizing :dict compound type + "Dictionary" + '((:array + (:dict-entry :string "seven" (:variant :string "value of seven")) + (:dict-entry "eight" (:variant :object-path "/node8")) + (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81)))) . + (("seven" + ("value of seven")) + ("eight" + ("/node8")) + ("nine" + ((9 27 81))))) + '((:array + (:dict-entry :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) + (:dict-entry "key5" (:variant :string "obsolete")) + (:dict-entry "key6" (:variant :object-path "/node6/node7"))) . + (("key4" + ((7 49 125))) + ("key5" + ("obsolete")) + ("key6" + ("/node6/node7"))))) + + (dbus--test-property + "ByteDictionary" + '((:array + (:dict-entry :byte 8 (:variant :string "byte-eight")) + (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) + (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) . + ((8 ("byte-eight")) + (16 ("/byte/sixteen")) + (48 ((8 9 10)))))) + + (dbus--test-property + "Variant" + '((:variant "Variant string") . ("Variant string")) + '((:variant :byte 42) . (42)) + '((:variant :uint32 1000000) . (1000000)) + '((:variant :object-path "/variant/path") . ("/variant/path")) + '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) + '((:variant (:struct 42 "string" (:object-path "/structure/path") (:variant "last"))) . + ((42 "string" ("/structure/path") ("last"))))) + + ;; Test that :read prevents writes + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "StringArray" :read + '(:array "one" "two" :string "three")) + `((:property :session ,dbus--test-interface "StringArray") + (,dbus--test-service ,dbus--test-path)))) + + (should-error ; Cannot set property with :read access + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface "StringArray" + '(:array "seven" "eight" :string "nine")) + :type 'dbus-error) + + (should-not + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "StringArray") + '("seven" "eight" "nine"))) + + (should ; Verify property has registered value + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "StringArray") + '("one" "two" "three"))) + + ;; Test mismatched types in array + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "MixedArray" :readwrite + '(:array + :object-path "/node00" + :string "/node01" + :object-path "/node0/node02")) + :type 'wrong-type-argument) + + ;; Test in-range integer values + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue" :readwrite + :byte 255) + `((:property :session ,dbus--test-interface "ByteValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue") + 255)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ShortValue" :readwrite + :int16 32767) + `((:property :session ,dbus--test-interface "ShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ShortValue") + 32767)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UShortValue" :readwrite + :uint16 65535) + `((:property :session ,dbus--test-interface "UShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UShortValue") + 65535)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue" :readwrite + :int32 2147483647) + `((:property :session ,dbus--test-interface "IntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue") + 2147483647)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UIntValue" :readwrite + :uint32 4294967295) + `((:property :session ,dbus--test-interface "UIntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UIntValue") + 4294967295)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "LongValue" :readwrite + :int64 9223372036854775807) + `((:property :session ,dbus--test-interface "LongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "LongValue") + 9223372036854775807)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ULongValue" :readwrite + :uint64 18446744073709551615) + `((:property :session ,dbus--test-interface "ULongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ULongValue") + 18446744073709551615)) + + ;; Test integer overflow + + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue" :byte 520) + 8)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue") + 8)) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ShortValue" :readwrite + :int16 32800) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UShortValue" :readwrite + :uint16 65600) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue" :readwrite + :int32 2147483700) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "UIntValue" :readwrite + :uint32 4294967300) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "LongValue" :readwrite + :int64 9223372036854775900) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ULongValue" :readwrite + :uint64 18446744073709551700) + :type 'args-out-of-range) + + ;; dbus-set-property may change property type + + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue" 1024) + 1024)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue") + 1024)) + + + (should ; Another change property type + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue" :boolean t) + t)) + + (should + (eq + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "ByteValue") + t)) + + ;; Test invalid type specification + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface "InvalidType" :readwrite + :keyword 128) + :type 'wrong-type-argument)) + + ;; Cleanup. + + + (message "cleanup") + (dbus-unregister-service :session dbus--test-service))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") -- 2.28.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-Add-D-Bus-Introspection-tests.patch Content-Description: Introspection tests. >From 3efb1b38d75572b14ac0526dbd79769d6fa89d10 Mon Sep 17 00:00:00 2001 From: Hugh Daschbach Date: Mon, 21 Sep 2020 17:12:49 -0700 Subject: [PATCH 2/2] Add D-Bus Introspection tests. * lisp/net/dbus.el (new defconst): D-Bus deprecation name. * test/lisp/net/dbus-tests.el (dbus--tests-dir) (dbus--test-introspect) (dbus--test-examine-interface) (dbus--test-validate-annotations) (dbus--test-validate-property) (dbus--test-validate-m-or-s) (dbus--test-validate-signal) (dbus--test-validate-method) (dbus-test07-introspection): new tests. * test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml: new test data. --- lisp/net/dbus.el | 4 + test/lisp/net/dbus-tests.el | 324 ++++++++++++++++++ .../net/dbus-tests/org.gnu.Emacs.TestDBus.xml | 49 +++ 3 files changed, 377 insertions(+) create mode 100644 test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 86db7cbf18a..8da3245800b 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -153,6 +153,10 @@ dbus-interface-local ;; ;; +(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated") + "An annotation value indicating a deprecated interface, method, signal, or property.") + + ;;; Default D-Bus errors. diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 543b7c8a95b..15d80f79a22 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -44,6 +44,13 @@ dbus--test-path (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") +(defvar dbus--tests-dir + (file-truename + (expand-file-name "dbus-tests" + (file-name-directory (or load-file-name + buffer-file-name)))) + "Directory containing test data files.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -1435,6 +1442,323 @@ dbus-test06-property-types (message "cleanup") (dbus-unregister-service :session dbus--test-service))) +(defun dbus--test-introspect () + "Return test introspection string." + (with-temp-buffer + (insert-file (expand-file-name "org.gnu.Emacs.TestDBus.xml" dbus--tests-dir)) + (buffer-string))) + +(defsubst dbus--test-validate-interface + (iface-name expected-properties expected-methods expected-signals + expected-annotations) + "Validate an interface definition for `dbus-test-07-test-introspection'. +The argument IFACE-NAME is a string naming the interface to validate. +The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and +EXPECTED-ANNOTATIONS represent the names of the interface's properties, +methods, signals, and annotations, respecively." + + (let ((interface + (dbus-introspect-get-interface + :session + dbus--test-service + dbus--test-path + iface-name))) + (pcase-let ((`(interface ((name . ,name)) . ,rest) interface)) + (should + (string-equal name iface-name)) + (should + (string-equal name (dbus-introspect-get-attribute interface "name"))) + + (let (properties methods signals annotations) + (mapc (lambda (x) + (let ((name (dbus-introspect-get-attribute x "name"))) + (cond + ((eq 'property (car x)) (push name properties)) + ((eq 'method (car x)) (push name methods)) + ((eq 'signal (car x)) (push name signals)) + ((eq 'annotation (car x)) (push name annotations))))) + rest) + + (should + (equal + (nreverse properties) + expected-properties)) + (should + (equal + (nreverse methods) + expected-methods)) + (should + (equal + (nreverse signals) + expected-signals)) + (should + (equal + (nreverse annotations) + expected-annotations)))))) + +(defsubst dbus--test-validate-annotations (annotations expected-annotations) + "Validate a list of D-Bus ANNOTATIONS. +Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. +And ensure each ANNOTATIONS has a value attribute marked \"true\"." + (mapc + (lambda (annotation) + (let ((name (dbus-introspect-get-attribute annotation "name")) + (value (dbus-introspect-get-attribute annotation "value"))) + (should + (member name expected-annotations)) + (should + (equal value "true")))) + annotations)) + +(defsubst dbus--test-validate-property + (interface property-name expected-annotations &rest expected-args) + "Validate a property definition for `dbus-test-07-test-introspection'. + +The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. +The argument PROPERTY-NAME is a string naming the property to validate. +The arguments EXPECTED-ANNOTATIONS represent the names of the property's properties. +The argument EXPECTED-ARGS is a list of expected arguments for the property." + (let* ((property + (dbus-introspect-get-property + :session + dbus--test-service + dbus--test-path interface + property-name)) + (name (dbus-introspect-get-attribute property "name")) + (type (dbus-introspect-get-attribute property "type")) + (access (dbus-introspect-get-attribute property "access")) + (expected (assoc-string name expected-args))) + (should expected) + + (should + (string-equal name property-name)) + + (should + (string-equal + (nth 0 expected) + name)) + + (should + (string-equal + (nth 1 expected) + type)) + + (should + (string-equal + (nth 2 expected) + access)))) + +(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args) + "Validate a method or signal definition for `dbus-test-07-test-introspection'. +The argument TREE is an sexp returned from either `dbus-introspect-get-method' +or `dbus-introspect-get-signal' +The arguments EXPECTED-ANNOTATIONS is an sexp matching the annotations defined +for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for +the method or signal." + (let (args annotations) + (mapc (lambda (elem) + (let ((name (dbus-introspect-get-attribute elem "name"))) + (cond + ((eq 'arg (car elem)) (push elem args)) + ((eq 'annotation (car elem)) (push elem annotations))))) + tree) + (should + (equal + (nreverse args) + expected-args)) + (dbus--test-validate-annotations annotations expected-annotations))) + +(defsubst dbus--test-validate-signal + (interface signal-name expected-annotations &rest expected-args) + "Validate a signal definition for `dbus-test-07-test-introspection'. + +The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. +The argument SIGNAL-NAME is a string naming the signal to validate. +The arguments EXPECTED-ANNOTATIONS represent the names of the signal's properties. +The argument EXPECTED-ARGS is a list of expected arguments for the signal." + (let ((signal + (dbus-introspect-get-signal + :session + dbus--test-service + dbus--test-path + interface + signal-name))) + (pcase-let ((`(signal ((name . ,name)) . ,rest) signal)) + (should + (string-equal name signal-name)) + (should + (string-equal name (dbus-introspect-get-attribute signal "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + + +(defsubst dbus--test-validate-method + (interface method-name expected-annotations &rest expected-args) + "Validate a method definition for `dbus-test-07-test-introspection'. + +The argument INTERFACE is a string naming the interface owning METHOD-NAME. +The argument METHOD-NAME is a string naming the method to validate. +The arguments EXPECTED-ANNOTATIONS represent the names of the method's properties. +The argument EXPECTED-ARGS is a list of expected arguments for the method." + (let ((method + (dbus-introspect-get-method + :session + dbus--test-service + dbus--test-path + interface + method-name))) + (pcase-let ((`(method ((name . ,name)) . ,rest) method)) + (should + (string-equal name method-name)) + (should + (string-equal name (dbus-introspect-get-attribute method "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(ert-deftest dbus-test07-introspection () + :tags '(:expensive-test) + "Register an Introspection interface then query it." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + ;; Prepare introspections response + (dbus-register-method + :session dbus--test-service + dbus--test-path + dbus-interface-introspectable + "Introspect" + 'dbus--test-introspect) + + (unwind-protect + (progn + ;; dbus-introspect-get-node-names + (should + (equal + (dbus-introspect-get-node-names :session dbus--test-service dbus--test-path) + '("node0" "node1"))) + + ;; dbus-introspect-get-all-nodes + + (should + (equal + (dbus-introspect-get-all-nodes :session dbus--test-service dbus--test-path) + (list dbus--test-path + (concat dbus--test-path "/node0") + (concat dbus--test-path "/node1")))) + + ;; dbus-introspect-get-interface-names + + (let ((interfaces + (dbus-introspect-get-interface-names + :session + dbus--test-service + dbus--test-path))) + + (should + (equal + interfaces + `(,dbus-interface-introspectable + ,dbus-interface-properties + ,dbus--test-interface))) + + (dbus--test-validate-interface + dbus-interface-introspectable + nil + '("Introspect") + nil + nil) + + ;; dbus-introspect-get-interface via `dbus--test-validate-interface' + (dbus--test-validate-interface + dbus-interface-properties + nil '("Get" "Set" "GetAll") '("PropertiesChanged") nil) + + (dbus--test-validate-interface + dbus--test-interface + '("Connected" "Player") + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") + nil + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-method-names + + (let ((methods + (dbus-introspect-get-method-names + :session + dbus--test-service + dbus--test-path + dbus--test-interface))) + (should + (equal + methods + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) + + ;; dbus-introspect-get-method via 'dbus--test-validate-method + + (dbus--test-validate-method + dbus--test-interface + "Connect" + nil + '(arg ((name . "uuid") (type . "s") (direction . "in"))) + '(arg ((name . "mode") (type . "y") (direction . "in"))) + '(arg ((name . "options") (type . "a{sv}") (direction . "in"))) + '(arg ((name . "interface") (type . "s") (direction . "out")))) + + (dbus--test-validate-method + dbus--test-interface + "DeprecatedMethod0" + `(,dbus-annotation-deprecated)) + + (dbus--test-validate-method + dbus--test-interface + "DeprecatedMethod1" + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-signal-names + + (let ((signals + (dbus-introspect-get-signal-names + :session + dbus--test-service + dbus--test-path + dbus-interface-properties))) + (should + (equal + signals + '("PropertiesChanged"))) + + ;; dbus-introspect-get-signal via 'dbus--test-validate-signal + (dbus--test-validate-signal + dbus-interface-properties + "PropertiesChanged" + nil + '(arg ((name . "interface") (type . "s"))) + '(arg ((name . "changed_properties") (type . "a{sv}"))) + '(arg ((name . "invalidated_properties") (type . "as"))))) + + ;; dbus-intropct-get-property-names + + (let ((properties + (dbus-introspect-get-property-names + :session + dbus--test-service + dbus--test-path + dbus--test-interface))) + (should + (equal + properties + '("Connected" "Player"))) + + ;; dbus-introspect-get-property via 'dbus--test-validate-property + (dbus--test-validate-property + dbus--test-interface + "Connected" + nil + '("Connected" "b" "read") + '("Player" "o" "read")))) + + (dbus-unregister-service :session dbus--test-service))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") diff --git a/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml new file mode 100644 index 00000000000..620f10510f2 --- /dev/null +++ b/test/lisp/net/dbus-tests/org.gnu.Emacs.TestDBus.xml @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -- 2.28.0 --=-=-= Content-Type: text/plain; format=flowed Cheers, Hugh --=-=-=--