procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

More strict D-Bus type checking

Browse source 
* 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.
This commit is contained in:
Michael Albinus 2020-09-29 19:43:02 +02:00
parent 7f2c35d028
commit 7e45ed3a96
3 changed files with 84 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lisp/net/dbus.el
View file

@ -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)

22
src/dbusbind.c
View file

@ -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

73
test/lisp/net/dbus-tests.el
View file

@ -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