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.

diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index fec9d3c7ab8416d2b13b87f603110e0a10e15c58..23ba191e3cf38caeaef0418d20a3c794e1029eac 100644 (file)
--- 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 09f0317be916367cb7b6f945d8cd71985319e283..b06077d3b58b3f0ed88aaf9a605f83fec7425599 100644 (file)
--- 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 b853542a1f0270deef1ff85d923cca7886df2653..74c0dddcf52f2438ff0787af7822c7225735dc24 100644 (file)
--- 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)
@@ -107,6 +110,9 @@
   ;; `:string'.
   (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)
@@ -115,6 +121,10 @@
   (should
    (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)
@@ -124,6 +134,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)
@@ -136,16 +150,19 @@
   (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))
   ;; Only the least significant byte is taken into account.
   (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)
@@ -160,6 +177,9 @@
   (should (dbus-check-arguments :session dbus--test-service :int16 0))
   (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)
@@ -176,6 +196,9 @@
   ;; `:uint16'.
   (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)
@@ -193,6 +216,9 @@
   (should (dbus-check-arguments :session dbus--test-service :int32 0))
   (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)
@@ -210,6 +236,9 @@
   (should (dbus-check-arguments :session dbus--test-service 0))
   (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)
@@ -229,6 +258,9 @@
    (dbus-check-arguments :session dbus--test-service :int64 #x7fffffffffffffff))
   (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)
@@ -246,6 +278,9 @@
   (should (dbus-check-arguments :session dbus--test-service :uint64 0))
   (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)
@@ -267,6 +302,9 @@
   ;; Shall both be supported?
   (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)
@@ -278,6 +316,9 @@
   ;; D-Bus message).  Mainly testing, that values out of `:uint32'
   ;; 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)
@@ -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