master 7e45ed3: More strict D-Bus type checking

[Michael Albinus]

branch: master
commit 7e45ed3a9674e9f436c337bed647ce9f60939ee0
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    More strict D-Bus type checking
    
    * lisp/net/dbus.el (dbus-register-monitor): Register proper key.
    (dbus-monitor-handler): Adapt docstring.  Use grave text-quoting-style.
    
    * src/dbusbind.c (xd_signature, xd_append_arg): More strict tests.
    (syms_of_dbusbind): Adapt docstring.
    
    * test/lisp/net/dbus-tests.el (dbus-test01-basic-types): Extend test.
---
 lisp/net/dbus.el            | 10 +++++--
 src/dbusbind.c              | 22 +++++++++-----
 test/lisp/net/dbus-tests.el | 73 ++++++++++++++++++++++++++++++++++++++-------
 3 files changed, 84 insertions(+), 21 deletions(-)

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index fec9d3c..23ba191 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -2026,7 +2026,7 @@ either a method name, a signal name, or an error name."
 
     ;; Create a hash table entry.
     (setq key (list :monitor bus-private)
-         key1 (list nil nil nil handler)
+         key1 (list nil nil nil handler rule)
          value (gethash key dbus-registered-objects-table))
     (unless  (member key1 value)
       (puthash key (cons key1 value) dbus-registered-objects-table))
@@ -2060,8 +2060,11 @@ either a method name, a signal name, or an error name."
 
 (defun dbus-monitor-handler (&rest _args)
   "Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\" 
interface.
-It will be applied for all objects created by
-`dbus-register-monitor' which don't declare an own handler.."
+It will be applied for all objects created by `dbus-register-monitor'
+which don't declare an own handler.  The printed timestamps do
+not reflect the time the D-Bus message has passed the D-Bus
+daemon, it is rather the timestamp the corresponding D-Bus event
+has been handled by this function."
   (with-current-buffer (get-buffer-create "*D-Bus Monitor*")
     (special-mode)
     ;; Move forward and backward between messages.
@@ -2071,6 +2074,7 @@ It will be applied for all objects created by
     (local-set-key  (kbd "RET") #'dbus-monitor-goto-serial)
     (local-set-key  [mouse-2] #'dbus-monitor-goto-serial)
     (let* ((inhibit-read-only t)
+           (text-quoting-style 'grave)
            (point (point))
            (eobp (eobp))
            (event last-input-event)
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 09f0317..b06077d 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -380,8 +380,9 @@ xd_signature (char *signature, int dtype, int parent_type, 
Lisp_Object object)
       break;
 
     case DBUS_TYPE_BOOLEAN:
-      /* Any non-nil object will be regarded as `t', so we don't apply
-        further type check.  */
+      /* There must be an argument.  */
+      if (EQ (QCboolean, object))
+       wrong_type_argument (intern ("booleanp"), object);
       sprintf (signature, "%c", dtype);
       break;
 
@@ -405,6 +406,8 @@ xd_signature (char *signature, int dtype, int parent_type, 
Lisp_Object object)
     case DBUS_TYPE_STRING:
     case DBUS_TYPE_OBJECT_PATH:
     case DBUS_TYPE_SIGNATURE:
+      /* We dont check the syntax of object path and signature.  This
+        will be done by libdbus.  */
       CHECK_STRING (object);
       sprintf (signature, "%c", dtype);
       break;
@@ -615,6 +618,9 @@ xd_append_arg (int dtype, Lisp_Object object, 
DBusMessageIter *iter)
        }
 
       case DBUS_TYPE_BOOLEAN:
+       /* There must be an argument.  */
+       if (EQ (QCboolean, object))
+         wrong_type_argument (intern ("booleanp"), object);
        {
          dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
          XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
@@ -713,6 +719,8 @@ xd_append_arg (int dtype, Lisp_Object object, 
DBusMessageIter *iter)
       case DBUS_TYPE_STRING:
       case DBUS_TYPE_OBJECT_PATH:
       case DBUS_TYPE_SIGNATURE:
+       /* We dont check the syntax of object path and signature.
+          This will be done by libdbus.  */
        CHECK_STRING (object);
        {
          /* We need to send a valid UTF-8 string.  We could encode `object'
@@ -1927,11 +1935,11 @@ and for calling handlers in case of non-blocking method 
call returns.
 
 In the first case, the key in the hash table is the list (TYPE BUS
 INTERFACE MEMBER).  TYPE is one of the Lisp symbols `:method',
-`:signal' or `:property'.  BUS is either a Lisp symbol, `:system' or
-`:session', or a string denoting the bus address.  INTERFACE is a
-string which denotes a D-Bus interface, and MEMBER, also a string, is
-either a method, a signal or a property INTERFACE is offering.  All
-arguments but BUS must not be nil.
+`:signal', `:property' or `:monitor'.  BUS is either a Lisp symbol,
+`:system', `:session', `:system-private' or `:session-private', or a
+string denoting the bus address.  INTERFACE is a string which denotes
+a D-Bus interface, and MEMBER, also a string, is either a method, a
+signal or a property INTERFACE is offering.  All arguments can be nil.
 
 The value in the hash table is a list of quadruple lists ((UNAME
 SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the service name as
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index b853542..74c0ddd 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -99,7 +99,10 @@
   "Check basic D-Bus type arguments."
   (skip-unless dbus--test-enabled-session-bus)
 
-  ;; Unknown keyword.
+  ;; No argument or unknown keyword.
+  (should-error
+   (dbus-check-arguments :session dbus--test-service)
+   :type 'wrong-number-of-arguments)
   (should-error
    (dbus-check-arguments :session dbus--test-service :keyword)
    :type 'wrong-type-argument)
@@ -108,6 +111,9 @@
   (should (dbus-check-arguments :session dbus--test-service "string"))
   (should (dbus-check-arguments :session dbus--test-service :string "string"))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :string)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :string 0.5)
    :type 'wrong-type-argument)
 
@@ -116,6 +122,10 @@
    (dbus-check-arguments
     :session dbus--test-service :object-path "/object/path"))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :object-path)
+   :type 'wrong-type-argument)
+  ;; Raises an error on stdin.
+  (should-error
    (dbus-check-arguments :session dbus--test-service :object-path "string")
    :type 'dbus-error)
   (should-error
@@ -125,6 +135,10 @@
   ;; `:signature'.
   (should (dbus-check-arguments :session dbus--test-service :signature "as"))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :signature)
+   :type 'wrong-type-argument)
+  ;; Raises an error on stdin.
+  (should-error
    (dbus-check-arguments :session dbus--test-service :signature "string")
    :type 'dbus-error)
   (should-error
@@ -136,10 +150,10 @@
   (should (dbus-check-arguments :session dbus--test-service t))
   (should (dbus-check-arguments :session dbus--test-service :boolean nil))
   (should (dbus-check-arguments :session dbus--test-service :boolean t))
-  ;; Will be handled as `nil'.
-  (should (dbus-check-arguments :session dbus--test-service :boolean))
-  ;; Will be handled as `t'.
   (should (dbus-check-arguments :session dbus--test-service :boolean 
'whatever))
+  (should-error
+   (dbus-check-arguments :session dbus--test-service :boolean)
+   :type 'wrong-type-argument)
 
   ;; `:byte'.
   (should (dbus-check-arguments :session dbus--test-service :byte 0))
@@ -147,6 +161,9 @@
   (should
    (dbus-check-arguments :session dbus--test-service :byte 
most-positive-fixnum))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :byte)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :byte -1)
    :type 'wrong-type-argument)
   (should-error
@@ -161,6 +178,9 @@
   (should (dbus-check-arguments :session dbus--test-service :int16 #x7fff))
   (should (dbus-check-arguments :session dbus--test-service :int16 #x-8000))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :int16)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :int16 #x8000)
    :type 'args-out-of-range)
   (should-error
@@ -177,6 +197,9 @@
   (should (dbus-check-arguments :session dbus--test-service :uint16 0))
   (should (dbus-check-arguments :session dbus--test-service :uint16 #xffff))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :uint16)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :uint16 #x10000)
    :type 'args-out-of-range)
   (should-error
@@ -194,6 +217,9 @@
   (should (dbus-check-arguments :session dbus--test-service :int32 #x7fffffff))
   (should (dbus-check-arguments :session dbus--test-service :int32 
#x-80000000))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :int32)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :int32 #x80000000)
    :type 'args-out-of-range)
   (should-error
@@ -211,6 +237,9 @@
   (should (dbus-check-arguments :session dbus--test-service :uint32 0))
   (should (dbus-check-arguments :session dbus--test-service :uint32 
#xffffffff))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :uint32)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :uint32 #x100000000)
    :type 'args-out-of-range)
   (should-error
@@ -230,6 +259,9 @@
   (should
    (dbus-check-arguments :session dbus--test-service :int64 
#x-8000000000000000))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :int64)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :int64 #x8000000000000000)
    :type 'args-out-of-range)
   (should-error
@@ -247,6 +279,9 @@
   (should
    (dbus-check-arguments :session dbus--test-service :uint64 
#xffffffffffffffff))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :uint64)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :uint64 
#x10000000000000000)
    :type 'args-out-of-range)
   (should-error
@@ -268,6 +303,9 @@
   (should (dbus-check-arguments :session dbus--test-service :double 1.0e+INF))
   (should (dbus-check-arguments :session dbus--test-service :double 0.0e+NaN))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :double)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :double "string")
    :type 'wrong-type-argument)
 
@@ -279,6 +317,9 @@
   ;; type range fail.
   (should (dbus-check-arguments :session dbus--test-service :unix-fd 0))
   (should-error
+   (dbus-check-arguments :session dbus--test-service :unix-fd)
+   :type 'wrong-type-argument)
+  (should-error
    (dbus-check-arguments :session dbus--test-service :unix-fd -1)
    :type 'args-out-of-range)
   (should-error
@@ -300,7 +341,7 @@
   (should
    (dbus-check-arguments
     :session dbus--test-service '(:array :string "string1" "string2")))
-  ;; Empty array.
+  ;; Empty array (of strings).
   (should (dbus-check-arguments :session dbus--test-service '(:array)))
   (should
    (dbus-check-arguments :session dbus--test-service '(:array :signature "o")))
@@ -318,7 +359,11 @@
   (should
    (dbus-check-arguments
     :session dbus--test-service '(:variant (:array "string"))))
-  ;; More than one element.
+  ;; No or more than one element.
+  ;; FIXME.
+  ;; (should-error
+  ;;  (dbus-check-arguments :session dbus--test-service '(:variant))
+  ;;  :type 'wrong-type-argument)
   (should-error
    (dbus-check-arguments
     :session dbus--test-service
@@ -336,10 +381,13 @@
    (dbus-check-arguments
     :session dbus--test-service
     '(:array :dict-entry (:string "string" :boolean t))))
-  ;; The second element is `nil' (implicitly).  FIXME: Is this right?
-  (should
-   (dbus-check-arguments
-    :session dbus--test-service '(:array (:dict-entry :string "string"))))
+  ;; FIXME: Must be errors.
+  ;; (should
+  ;;  (dbus-check-arguments
+  ;;   :session dbus--test-service '(:array (:dict-entry))))
+  ;; (should
+  ;;  (dbus-check-arguments
+  ;;   :session dbus--test-service '(:array (:dict-entry :string "string"))))
   ;; Not two elements.
   (should-error
    (dbus-check-arguments
@@ -357,7 +405,8 @@
    (dbus-check-arguments
     :session dbus--test-service '(:dict-entry :string "string" :boolean t))
    :type 'wrong-type-argument)
-  ;; Different dict entry types can be part of an array.
+  ;; FIXME:! This doesn't look right.
+  ;; Different dict entry types can be part of an array ???
   (should
    (dbus-check-arguments
     :session dbus--test-service
@@ -366,6 +415,8 @@
       (:dict-entry :string "string2" :object-path "/object/path"))))
 
   ;; `:struct'.  There is no restriction what could be an element of a struct.
+  ;; Empty struct.  FIXME: Is this right?
+  ;; (should (dbus-check-arguments :session dbus--test-service '(:struct)))
   (should
    (dbus-check-arguments
     :session dbus--test-service