bug#43252: 27.1; DBus properties lack type hints or overrides

[Hugh Daschbach <hugh@ccss.com>]

[-- Attachment #1: Type: text/plain, Size: 1518 bytes --]


Hugh Daschbach writes:

> Michael Albinus writes:
>
>> Hugh Daschbach <hugh@ccss.com> writes:
>>
>> Hi Hugh,
>>
> I need more testing and a cleanup pass.  I'll pass along a 
> better 
> version when
> I think it's ready for review.
>
> I've started a few "should fail" tests.

I've made a bit of progress.  I have a few tests that fail.  There
doesn't seem to be any type checking on property set.  But have a 
look
and see if you concur that these are real errors.  I've attached a
patch.

In addition, I see a failure in dbus-test04-register-method:

> F dbus-test04-register-method
>     Check method registration for an own service.
>     (ert-test-failed
>      ((should
>        (equal
> 	(should-error
> 	 (dbus-call-method :session dbus--test-service 
> dbus--test-path dbus--test-interface method1 :timeout 10 "foo"))
> 	`(dbus-error ... "The name is not activatable")))
>       :form
>       (equal
>        (dbus-error "org.freedesktop.DBus.Error.ServiceUnknown" 
>        "The name org.gnu.Emacs.TestDBus was not provided by any 
>        .service files")
>        (dbus-error "org.freedesktop.DBus.Error.ServiceUnknown" 
>        "The name is not activatable"))
>       :value nil :explanation
>       (list-elt 2
> 		(arrays-of-different-length 70 27 "The name 
> org.gnu.Emacs.TestDBus was not provided by any .service files" 
> "The name is not activatable" first-mismatch-at 9))))
>

Your mileage may vary.

I'm starting to run out of ideas for additional tests. 
Suggestions
welcome.

Cheers,
Hugh


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Additional property tests. --]
[-- Type: text/x-patch, Size: 12548 bytes --]

From 722852e9e1d402742508233051951d21b02bc3c9 Mon Sep 17 00:00:00 2001
From: Hugh Daschbach <hdasch@fastmail.com>
Date: Thu, 17 Sep 2020 23:19:32 -0700
Subject: [PATCH] Property tests (ERT).

Add DBus tests to validate property handling.  Includes cycling
register, get, set, get, GetAll, and GetManagedObjects over
several property types.

Add tests that should fail, like setting a property with a type
different from it's type at registration time.
---
 test/lisp/net/dbus-tests.el | 319 ++++++++++++++++++++++++++++++++++++
 1 file changed, 319 insertions(+)

diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index 18c2a2ad6d2..682aaa8325a 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -755,6 +755,325 @@ dbus-test06-register-property-emits-signal
     ;; Cleanup.
     (dbus-unregister-service :session dbus--test-service)))
 
+(defun dbus-test06-make-property-test (selector name value expected)
+  "Generate a property test: register, set, get, getall sequence.
+This is a helper function for the macro
+`dbus-test06-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."
+
+;; Since we don't expect this helper function and it's caller
+;; `dbus-test06-make-property' to be used outside this file, we don't
+;; bother with `eval-and-compile.'  It would be appropriate to wrap
+;; this with `eval-and-compile' if that expectation is misguided.
+
+  `(progn
+     ,(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))))  )
+
+
+(defmacro dbus-test06-test-property (name value-list)
+  "Generate a DBus property test.
+The argument NAME is a property name for the test.
+
+The argument VALUES is a list 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 (gensym))
+        (value (gensym))
+        (expected (gensym))
+        (pair (gensym))
+        (first (gensym)))
+    (let ((values value-list))
+      (append
+       `(progn)
+       (list
+        (dbus-test06-make-property-test
+          'register
+          name
+          `',(caar values)
+          `',(cdar values)))
+        (mapcar (lambda (pair)
+                  (dbus-test06-make-property-test
+                    'set
+                    name
+                    `',(car pair)
+                    `',(cdr pair)
+                    ))
+                (cdr values))))))
+
+(defmacro with-dbus-monitor (buffer &rest body)
+  "Run BODY in an environment that captures `dbus-monitor' output in BUFFER."
+  (declare (indent defun))
+  `(let ((process
+          (start-process "dbus-monitor" ,buffer
+           "dbus-monitor"
+           "--session"
+           (concat  "sender=" dbus--test-service)
+           (concat "destination=" dbus--test-service))))
+    (unwind-protect
+        (progn ,@body)
+      (sit-for 0.5)
+      (delete-process process))))
+
+(ert-deftest dbus-test06-test-property-types ()
+  "Check property type preservation 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
+      (with-dbus-monitor "*dbus-monitor*"
+        (progn
+          (dbus-test06-test-property
+           "ByteArray"
+           (((:array :byte 1 :byte 2 :byte 3) . (1 2 3))
+            ((:array :byte 4 :byte 5 :byte 6) . (4 5 6))))
+
+          (dbus-test06-test-property
+           "StringArray"
+           (((:array "one" "two" :string "three") . ("one" "two" "three"))
+            ((:array :string "four" :string "five" "six") . ("four" "five" "six"))))
+
+          (dbus-test06-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-test06-test-property
+           "Dictionary"
+           (((:array
+              :dict-entry (:string "four" (:variant :string "value of four"))
+              :dict-entry ("five" (:variant :object-path "/nodex"))
+              :dict-entry ("six"  (:variant (:array :byte 4 :byte 5 :byte 6)))) .
+              (("four"
+                ("value of four"))
+               ("five"
+                ("/nodex"))
+               ("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-test06-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-test06-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 "/org/gnu/Emacs/TestDBus"))))
+
+          (should                             ; Should this error instead?
+           (equal
+            (dbus-set-property
+             :session dbus--test-service dbus--test-path
+             dbus--test-interface "StringArray"
+             '(:array "seven" "eight" :string "nine"))
+            nil))
+
+          (should-not                         ; Not update by dbus-set-property
+           (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                         ; Oddly enough, register works, but get fails
+         (equal
+          (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"))
+          `((:property :session ,dbus--test-interface "MixedArray")
+	    (,dbus--test-service "/org/gnu/Emacs/TestDBus"))))
+
+        (should-error
+         (equal
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "MixedArray")
+          '("/node00" "/node01" "/node0/node02")))
+
+        ;; Test integer overflow
+
+        (should
+         (equal
+          (dbus-register-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue" :readwrite
+           :byte 128)
+          `((:property :session ,dbus--test-interface "ByteValue")
+	    (,dbus--test-service "/org/gnu/Emacs/TestDBus"))))
+
+        (should
+         (=
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue")
+          128))
+
+        (should                             ; This should error or the next get should fail
+         (equal
+          (dbus-set-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue" 1024)
+          1024))
+
+
+        (should-not                         ; This should fail or the preceeding set should error
+         (=
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue")
+          1024))
+
+        (should
+         (=
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue")
+          128))
+
+        ;; Test set with invalid type
+
+        (should                         ; No error, but the invalid type throws an error on get
+         (equal
+          (dbus-set-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue" :boolean t) nil))
+
+        (should-not
+         (eq
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue")
+          t))
+
+        (should
+         (=
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "ByteValue")
+          128))
+
+        ;; Test invalid type specification
+
+        (should
+         (equal
+          (dbus-register-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "InvalidType" :readwrite
+           :keyword 128)
+          `((:property :session ,dbus--test-interface "InvalidType")
+	    (,dbus--test-service "/org/gnu/Emacs/TestDBus"))))
+
+        (should-error
+         (=
+          (dbus-get-property
+           :session dbus--test-service dbus--test-path
+           dbus--test-interface "InvalidType")
+          128)))
+
+
+    ;; 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