[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs/lisp/net dbus.el
From: |
Michael Albinus |
Subject: |
[Emacs-diffs] emacs/lisp/net dbus.el |
Date: |
Fri, 13 Nov 2009 16:05:00 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Michael Albinus <albinus> 09/11/13 16:04:59
Modified files:
lisp/net : dbus.el
Log message:
* net/dbus.el (dbus-registered-objects-table): Renamed from
`dbus-registered-functions-table', because it contains also
properties.
(dbus-unregister-object): Unregister also properties.
(dbus-get-property, dbus-set-property, dbus-get-all-properties):
Use a timeout of 500 msec, in order to not block.
(dbus-register-property, dbus-property-handler): New defuns.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/net/dbus.el?cvsroot=emacs&r1=1.37&r2=1.38
Patches:
Index: dbus.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/net/dbus.el,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -b -r1.37 -r1.38
--- dbus.el 9 Nov 2009 22:15:41 -0000 1.37
+++ dbus.el 13 Nov 2009 16:04:59 -0000 1.38
@@ -39,7 +39,7 @@
(declare-function dbus-method-error-internal "dbusbind.c")
(declare-function dbus-register-signal "dbusbind.c")
(defvar dbus-debug)
-(defvar dbus-registered-functions-table)
+(defvar dbus-registered-objects-table)
;; Pacify byte compiler.
(eval-when-compile
@@ -108,7 +108,7 @@
;; We create it here. So we have a simple test in dbusbind.c, whether
;; the Lisp code has been loaded.
-(setq dbus-registered-functions-table (make-hash-table :test 'equal))
+(setq dbus-registered-objects-table (make-hash-table :test 'equal))
(defvar dbus-return-values-table (make-hash-table :test 'equal)
"Hash table for temporary storing arguments of reply messages.
@@ -120,55 +120,62 @@
(defun dbus-list-hash-table ()
"Returns all registered member registrations to D-Bus.
The return value is a list, with elements of kind (KEY . VALUE).
-See `dbus-registered-functions-table' for a description of the
+See `dbus-registered-objects-table' for a description of the
hash table."
(let (result)
(maphash
'(lambda (key value) (add-to-list 'result (cons key value) 'append))
- dbus-registered-functions-table)
+ dbus-registered-objects-table)
result))
(defun dbus-unregister-object (object)
"Unregister OBJECT from D-Bus.
-OBJECT must be the result of a preceding `dbus-register-method'
-or `dbus-register-signal' call. It returns `t' if OBJECT has
-been unregistered, `nil' otherwise."
+OBJECT must be the result of a preceding `dbus-register-method',
+`dbus-register-property' or `dbus-register-signal' call. It
+returns `t' if OBJECT has been unregistered, `nil' otherwise.
+
+When OBJECT identifies the last method or property, which is
+registered for the respective service, Emacs releases its
+association to the service from D-Bus."
;; Check parameter.
(unless (and (consp object) (not (null (car object))) (consp (cdr object)))
(signal 'wrong-type-argument (list 'D-Bus object)))
;; Find the corresponding entry in the hash table.
(let* ((key (car object))
- (value (gethash key dbus-registered-functions-table))
- (bus (car key))
+ (value (cdr object))
+ (entry (gethash key dbus-registered-objects-table))
ret)
+ ;; entry has the structure ((UNAME SERVICE PATH MEMBER) ...).
+ ;; value has the structure ((SERVICE PATH [HANDLER]) ...).
+ ;; MEMBER is either a string (the handler), or a cons cell (a
+ ;; property value). UNAME and property values are not taken into
+ ;; account for comparision.
+
;; Loop over the registered functions.
- (dolist (val value)
- ;; val has the structure (UNAME SERVICE PATH HANDLER).
- ;; (cdr object) has the structure ((SERVICE PATH HANDLER) ...).
- (when (equal (cdr val) (car (cdr object)))
- ;; Compute new hash value. If it is empty, remove it from
+ (dolist (elt entry)
+ (when (equal
+ (car value)
+ (butlast (cdr elt) (- (length (cdr elt)) (length (car value)))))
+ ;; Compute new hash value. If it is empty, remove it from the
;; hash table.
- (unless
- (puthash
- key
- (delete val (gethash key dbus-registered-functions-table))
- dbus-registered-functions-table)
- (remhash key dbus-registered-functions-table))
+ (unless (puthash key (delete elt entry) dbus-registered-objects-table)
+ (remhash key dbus-registered-objects-table))
(setq ret t)))
- ;; Check, whether there is still a registered function for the
- ;; given service. If not, unregister the service from the bus.
- (dolist (val value)
- (let ((service (cadr val))
+ ;; Check, whether there is still a registered function or property
+ ;; for the given service. If not, unregister the service from the
+ ;; bus.
+ (dolist (elt entry)
+ (let ((service (cadr elt))
+ (bus (car key))
found)
(maphash
(lambda (k v)
- (dolist (val v)
+ (dolist (e v)
(ignore-errors
- (when (and (equal bus (car k))
- (string-equal service (cadr val)))
+ (when (and (equal bus (car k)) (string-equal service (cadr e)))
(setq found t)))))
- dbus-registered-functions-table)
+ dbus-registered-objects-table)
(unless found
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
@@ -178,7 +185,7 @@
(defun dbus-call-method-non-blocking-handler (&rest args)
"Handler for reply messages of asynchronous D-Bus message calls.
-It calls the function stored in `dbus-registered-functions-table'.
+It calls the function stored in `dbus-registered-objects-table'.
The result will be made available in `dbus-return-values-table'."
(puthash (list (dbus-event-bus-name last-input-event)
(dbus-event-serial-number last-input-event))
@@ -248,7 +255,7 @@
(nth 0 key) (nth 1 elt) (nth 2 elt)
;; INTERFACE MEMBER HANDLER
(nth 1 key) (nth 2 key) (nth 3 elt)))))
- (copy-hash-table dbus-registered-functions-table))))
+ (copy-hash-table dbus-registered-objects-table))))
;; The error is reported only in debug mode.
(when dbus-debug
(signal
@@ -805,18 +812,11 @@
It will be checked at BUS, SERVICE, PATH. The result can be any
valid D-Bus value, or `nil' if there is no PROPERTY."
(dbus-ignore-errors
- ;; We must check, whether the "org.freedesktop.DBus.Properties"
- ;; interface is supported; otherwise the call blocks.
- (when
- (member
- "Get"
- (dbus-introspect-get-method-names
- bus service path "org.freedesktop.DBus.Properties"))
- ;; "Get" returns a variant, so we must use the car.
+ ;; "Get" returns a variant, so we must use the `car'.
(car
- (dbus-call-method
+ (dbus-call-method-non-blocking
bus service path dbus-interface-properties
- "Get" interface property)))))
+ "Get" :timeout 500 interface property))))
(defun dbus-set-property (bus service path interface property value)
"Set value of PROPERTY of INTERFACE to VALUE.
@@ -824,45 +824,132 @@
been set successful, the result is VALUE. Otherwise, `nil' is
returned."
(dbus-ignore-errors
- (when
- (and
- ;; We must check, whether the
- ;; "org.freedesktop.DBus.Properties" interface is supported;
- ;; otherwise the call blocks.
- (member
- "Set"
- (dbus-introspect-get-method-names
- bus service path "org.freedesktop.DBus.Properties"))
- ;; PROPERTY must be writable.
- (string-equal
- "readwrite"
- (dbus-introspect-get-attribute
- (dbus-introspect-get-property bus service path interface property)
- "access")))
;; "Set" requires a variant.
- (dbus-call-method
+ (dbus-call-method-non-blocking
bus service path dbus-interface-properties
- "Set" interface property (list :variant value))
+ "Set" :timeout 500 interface property (list :variant value))
;; Return VALUE.
- (dbus-get-property bus service path interface property))))
+ (dbus-get-property bus service path interface property)))
(defun dbus-get-all-properties (bus service path interface)
"Return all properties of INTERFACE at BUS, SERVICE, PATH.
The result is a list of entries. Every entry is a cons of the
name of the property, and its value. If there are no properties,
`nil' is returned."
- ;; "org.freedesktop.DBus.Properties.GetAll" is not supported at
- ;; all interfaces. Therefore, we do it ourselves.
(dbus-ignore-errors
+ ;; "GetAll" returns "a{sv}".
(let (result)
- (dolist (property
- (dbus-introspect-get-property-names
- bus service path interface)
+ (dolist (dict
+ (dbus-call-method-non-blocking
+ bus service path dbus-interface-properties
+ "GetAll" :timeout 500 interface)
result)
+ (add-to-list 'result (cons (car dict) (caadr dict)) 'append)))))
+
+(defun dbus-register-property
+ (bus service path interface property access value)
+ "Register property PROPERTY on the D-Bus BUS.
+
+BUS is either the symbol `:system' or the symbol `:session'.
+
+SERVICE is the D-Bus service name of the D-Bus. It must be a
+known name.
+
+PATH is the D-Bus object path SERVICE is registered. INTERFACE
+is the name of the interface used at PATH, PROPERTY is the name
+of the property of INTERFACE. ACCESS indicates, whether the
+property can be changed by other services via D-Bus. It must be
+either the symbol `:read' or `:readwrite'. VALUE is the initial
+value of the property, it can be of any valid type (see
+`dbus-call-method' for details).
+
+If PROPERTY already exists on PATH, it will be overwritten. For
+properties with access type `:read' this is the only way to
+change their values. Properties with access type `:readwrite'
+can be changed by `dbus-set-property'.
+
+The interface \"org.freedesktop.DBus.Properties\" is added to
+PATH, including a default handler for the \"Get\", \"GetAll\" and
+\"Set\" methods of this interface."
+ (unless (member access '(:read :readwrite))
+ (signal 'dbus-error (list "Access type invalid" access)))
+
+ ;; Register SERVICE.
+ (unless (member service (dbus-list-names bus))
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "RequestName" service 0))
+
+ ;; Add the handler. We use `dbus-service-emacs' as service name, in
+ ;; order to let unregister SERVICE despite of this default handler.
+ (dbus-register-method
+ bus dbus-service-emacs path dbus-interface-properties
+ "Get" 'dbus-property-handler)
+ (dbus-register-method
+ bus dbus-service-emacs path dbus-interface-properties
+ "GetAll" 'dbus-property-handler)
+ (dbus-register-method
+ bus dbus-service-emacs path dbus-interface-properties
+ "Set" 'dbus-property-handler)
+
+ ;; Create a hash table entry. We use nil for the unique name,
+ ;; because the property might be accessed from anybody.
+ (let ((key (list bus interface property))
+ (val (list (list nil service path (cons access value)))))
+ (puthash key val dbus-registered-objects-table)
+
+ ;; Return the object.
+ (list key (list service path))))
+
+(defun dbus-property-handler (&rest args)
+ "Handler for reply messages of asynchronous D-Bus message calls.
+It calls the function stored in `dbus-registered-objects-table'.
+The result will be made available in `dbus-return-values-table'."
+ (let ((bus (dbus-event-bus-name last-input-event))
+ (path (dbus-event-path-name last-input-event))
+ (method (dbus-event-member-name last-input-event))
+ (interface (car args))
+ (property (cadr args)))
+ (cond
+ ;; "Get" returns a variant.
+ ((string-equal method "Get")
+ (let ((val (gethash (list bus interface property)
+ dbus-registered-objects-table)))
+ (when (string-equal path (nth 2 (car val)))
+ (list (list :variant (cdar (last (car val))))))))
+
+ ;; "Set" expects a variant.
+ ((string-equal method "Set")
+ (let ((val (gethash (list bus interface property)
+ dbus-registered-objects-table)))
+ (unless (consp (car (last (car val))))
+ (signal 'dbus-error
+ (list "Property not registered at path" property path)))
+ (unless (equal (caar (last (car val))) :readwrite)
+ (signal 'dbus-error
+ (list "Property not writable at path" property path)))
+ (puthash (list bus interface property)
+ (list (append (butlast (car val))
+ (list (cons :readwrite (caar (cddr args))))))
+ dbus-registered-objects-table)
+ :ignore))
+
+ ;; "GetAll" returns "a{sv}".
+ ((string-equal method "GetAll")
+ (let (result)
+ (maphash
+ (lambda (key val)
+ (when (and (equal (butlast key) (list bus interface))
+ (string-equal path (nth 2 (car val)))
+ (consp (car (last (car val)))))
(add-to-list
'result
- (cons property (dbus-get-property bus service path interface property))
- 'append)))))
+ (list :dict-entry
+ (car (last key))
+ (list :variant (cdar (last (car val))))))))
+ dbus-registered-objects-table)
+ (list result))))))
+
;; Initialize :system and :session buses. This adds their file
;; descriptors to input_wait_mask, in order to detect incoming