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: Wed, 23 Sep 2020 20:02:24 -0700 Message-ID: <87r1qr98sf.fsf@ccss.com> References: <87v9gqquct.fsf@ccss.com> <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> <87wo0kielj.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="23576"; 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 Thu Sep 24 05:03:11 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 1kLHXK-00061O-TN for geb-bug-gnu-emacs@m.gmane-mx.org; Thu, 24 Sep 2020 05:03:11 +0200 Original-Received: from localhost ([::1]:59222 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kLHXJ-00079z-Qc for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 23 Sep 2020 23:03:09 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:59000) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kLHXC-00079r-Nh for bug-gnu-emacs@gnu.org; Wed, 23 Sep 2020 23:03:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:54992) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kLHXC-0004zN-Em for bug-gnu-emacs@gnu.org; Wed, 23 Sep 2020 23:03:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kLHXC-0003Vh-B3 for bug-gnu-emacs@gnu.org; Wed, 23 Sep 2020 23:03: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: Thu, 24 Sep 2020 03:03: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.160091656813470 (code B ref 43252); Thu, 24 Sep 2020 03:03:02 +0000 Original-Received: (at 43252) by debbugs.gnu.org; 24 Sep 2020 03:02:48 +0000 Original-Received: from localhost ([127.0.0.1]:38305 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kLHWo-0003V4-W4 for submit@debbugs.gnu.org; Wed, 23 Sep 2020 23:02:48 -0400 Original-Received: from mail1.ccss.com ([159.203.255.73]:34330) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kLHWm-0003Ul-PU for 43252@debbugs.gnu.org; Wed, 23 Sep 2020 23:02:38 -0400 Original-Received: by mail1.ccss.com (Postfix, from userid 114) id CD2D3BF8EB; Wed, 23 Sep 2020 20:02:30 -0700 (PDT) Original-Received: from ccss.com (unknown [192.168.76.11]) by mail1.ccss.com (Postfix) with ESMTP id E836BBF8E7; Wed, 23 Sep 2020 20:02:28 -0700 (PDT) Original-Received: from localhost (localhost [127.0.0.1]) by ccss.com (Postfix) with ESMTP id B2D04176073A; Wed, 23 Sep 2020 20:02:28 -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 NORN4TYQaJDS; Wed, 23 Sep 2020 20:02:25 -0700 (PDT) Original-Received: from klaatu (klaatu.lan [192.168.42.3]) (Authenticated sender: hugh) by ccss.com (Postfix) with ESMTPSA id 344431760652; Wed, 23 Sep 2020 20:02:25 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=ccss.com; s=mail; t=1600916545; bh=r+2UVaDaehjPJHO1BUqwRPCUVOKFxwYRg8SOdkOy2aw=; h=References:From:To:Cc:Subject:In-reply-to:Date:From; b=L6k0CGVij5IklPshGz0VKSadstxc2nQ+LTPDNcq4D5dDjgCHOZNJDOUTuo8W4kCOO kENMNXRRuacX33QxReqJIi6wjgJyvMfOs7qTiOIp143b1Mp5TfY3+2iJq9nllyreo8 Sb0bXtQMeLAxwdRoHWuypZOz9dV5XEDyDm2htWK6fLDSwG0DBL4wnEDyOTJ9go2jhv xtu5TxNNytAL6xuT6vG3APdu8W/dBzioFDcfpUCIMdr+0jhb04N0YiKRKvKAFPTmXZ ZC/SejWajIPVtfax1hHCh0cfOdc/cxRgtON0QU+lsa4EisZdhuKs0GBfWdpKBq9tp1 yAkIbOAJP4g6g== In-reply-to: <87wo0kielj.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:188841 Archived-At: --=-=-= Content-Type: text/plain; format=flowed Michael Albinus writes: > Hugh Daschbach writes: > > Hi Hugh, > > Oops, I'm mistaken here. The directory shall be called > dbus-resources, > see .../test/file-organization.org. Sorry. No worries. Done. > I'd vote for the latter, with the first argument :session > preceding > the other arguments in the same line. Like > > (let* ((property > (dbus-introspect-get-property > :session dbus--test-service > dbus--test-path interface property-name))) > ...) I think I've addressed this. I reformatted a few tests that were similarly indented. > If you have one comment for several functions, use only one > parenthesis > per line like > > (dbus--test-run-property-test, dbus--test-property) > (dbus-test06-property-types): Test property registration, set, > get. Done. I think. > `dbus-register-property' (if SELECTOR is `register') or Done. Apologies for not picking up the quoting issue the first time you mentioned it. > I bet the dot "." has the font-lock-warning-face (red foreground > color) > in your buffer. Admittedly, it doesn't look prominent :-( > > Move the cursor over the misplaced dot; there shall be a help > message about. Done. > I don't believe we need this message. We see that we're done :-) Gone. >> * 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. I think I understand the ChangeLog format. Additional corrections welcome. > The docstring line does not fit 80 chars. What about > > "An annotation indicating a deprecated interface, method, > signal, or property." Done. >> +(ert-deftest dbus-test07-introspection () >> + :tags '(:expensive-test) >> + "Register an Introspection interface then query it." > > :tags must be after the docstring. Corrected. >> Cheers, >> Hugh > > Best regards, Michael. I think I've addressed all the issues you pointed out. Let me know if there's something that still doesn't look right. Thanks Hugh --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Add-D-Bus-property-tests.patch Content-Description: Property tests. >From 64dcf1a657a7610709072676905f0157178511eb 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): New defuns. (dbus-test06-property-types): New test for property registration, set, get. --- test/lisp/net/dbus-tests.el | 398 ++++++++++++++++++++++++++++++++++++ 1 file changed, 398 insertions(+) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 2f20fcc1e67..2e0c061a556 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1005,6 +1005,404 @@ 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 + (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 86f5834893efb1bc5fe907ce22d4b81260a2c553 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 (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-tests/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 | 285 +++++++++++++++++- 3 files changed, 336 insertions(+), 1 deletion(-) 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 86db7cbf18a..7d45c859f12 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -153,6 +153,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 2e0c061a556..b764e8dc8db 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-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)) @@ -1056,7 +1063,6 @@ dbus--test-run-property-test (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'. @@ -1403,6 +1409,283 @@ dbus-test06-property-types ;; 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-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." + :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) + + ;; Prepare introspection 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") -- 2.28.0 --=-=-=--