;;; dbus.el --- Elisp bindings for D-Bus.
-;; Copyright (C) 2007-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
(defvar dbus-registered-objects-table)
;; Pacify byte compiler.
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'xml)
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
-(defvar dbus-event-error-hooks nil
+(define-obsolete-variable-alias 'dbus-event-error-hooks
+ 'dbus-event-error-functions "24.3")
+(defvar dbus-event-error-functions nil
"Functions to be called when a D-Bus error happens in the event handler.
Every function must accept two arguments, the event and the error variable
caught in `condition-case' by `dbus-error'.")
(apply
'dbus-message-internal dbus-message-type-method-call
bus service path interface method 'dbus-call-method-handler args)))
+
;; Wait until `dbus-call-method-handler' has put the result into
;; `dbus-return-values-table'. If no timeout is given, use the
- ;; default 25".
+ ;; default 25". Events which are not from D-Bus must be restored.
+ ;; `read-event' performs a redisplay. This must be suppressed; it
+ ;; hurts when reading D-Bus events asynchronously.
(with-timeout ((if timeout (/ timeout 1000.0) 25))
(while (eq (gethash key dbus-return-values-table :ignore) :ignore)
- (read-event nil nil 0.1)))
+ (let ((event (let ((inhibit-redisplay t) unread-command-events)
+ (read-event nil nil 0.1))))
+ (when (and event (not (ignore-errors (dbus-check-event event))))
+ (setq unread-command-events
+ (append unread-command-events (list event)))))))
;; Cleanup `dbus-return-values-table'. Return the result.
(prog1
;; `dbus-call-method' works non-blocking now.
(defalias 'dbus-call-method-non-blocking 'dbus-call-method)
-(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.2")
+(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3")
(defun dbus-call-method-asynchronously
(bus service path interface method handler &rest args)
(dolist (flag flags)
(setq arg
(+ arg
- (case flag
+ (pcase flag
(:allow-replacement 1)
(:replace-existing 2)
(:do-not-queue 4)
- (t (signal 'wrong-type-argument (list flag)))))))
+ (_ (signal 'wrong-type-argument (list flag)))))))
(setq reply (dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"RequestName" service arg))
- (case reply
+ (pcase reply
(1 :primary-owner)
(2 :in-queue)
(3 :exists)
(4 :already-owner)
- (t (signal 'dbus-error (list "Could not register service" service))))))
+ (_ (signal 'dbus-error (list "Could not register service" service))))))
(defun dbus-unregister-service (bus service)
"Unregister all objects related to SERVICE from D-Bus BUS.
The function returns a keyword, indicating the result of the
operation. One of the following keywords is returned:
-`:released': Service has become the primary owner of the name.
+`:released': We successfully released the service.
`:non-existent': Service name does not exist on this bus.
(maphash
(lambda (key value)
- (dolist (elt value)
- (ignore-errors
- (when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
- (unless
- (puthash key (delete elt value) dbus-registered-objects-table)
- (remhash key dbus-registered-objects-table))))))
+ (unless (equal :serial (car key))
+ (dolist (elt value)
+ (ignore-errors
+ (when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
+ (unless
+ (puthash key (delete elt value) dbus-registered-objects-table)
+ (remhash key dbus-registered-objects-table)))))))
dbus-registered-objects-table)
(let ((reply (dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"ReleaseName" service)))
- (case reply
+ (pcase reply
(1 :released)
(2 :non-existent)
(3 :not-owner)
- (t (signal 'dbus-error (list "Could not unregister service" service))))))
+ (_ (signal 'dbus-error (list "Could not unregister service" service))))))
(defun dbus-register-signal
(bus service path interface signal handler &rest args)
;; Service.
(string-equal service (cadr e))
;; Non-empty object path.
- (caddr e)
+ (cl-caddr e)
(throw :found t)))))
dbus-registered-objects-table)
nil))))
(dolist (elt (string-to-list string) (append '(:array) result))
(setq result (append result (list :byte elt)))))))
-(defun dbus-byte-array-to-string (byte-array)
+(defun dbus-byte-array-to-string (byte-array &optional multibyte)
"Transforms BYTE-ARRAY into UTF8 coded string.
-BYTE-ARRAY must be a list of structure (c1 c2 ...)."
- (apply 'string byte-array))
+BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte
+array as produced by `dbus-string-to-byte-array'. The resulting
+string is unibyte encoded, unless MULTIBYTE is non-nil."
+ (apply
+ (if multibyte 'string 'unibyte-string)
+ (if (equal byte-array '(:array :signature "y"))
+ nil
+ (let (result)
+ (dolist (elt byte-array result)
+ (when (characterp elt) (setq result (append result `(,elt)))))))))
(defun dbus-escape-as-identifier (string)
"Escape an arbitrary STRING so it follows the rules for a C identifier.
\"_\".
Returns the escaped string. Algorithm taken from
-telepathy-glib's `tp-escape-as-identifier'."
+telepathy-glib's `tp_escape_as_identifier'."
(if (zerop (length string))
"_"
(replace-regexp-in-string
string)))
(defun dbus-unescape-from-identifier (string)
- "Retrieve the original string from the encoded STRING.
-STRING must have been coded with `dbus-escape-as-identifier'"
+ "Retrieve the original string from the encoded STRING as unibyte string.
+STRING must have been encoded with `dbus-escape-as-identifier'."
(if (string-equal string "_")
""
(replace-regexp-in-string
"_.."
- (lambda (x) (format "%c" (string-to-number (substring x 1) 16)))
+ (lambda (x) (byte-to-string (string-to-number (substring x 1) 16)))
string)))
\f
(dbus-method-error-internal
(nth 1 event) (nth 4 event) (nth 3 event) (cadr err))))
;; Propagate D-Bus error messages.
- (run-hook-with-args 'dbus-event-error-hooks event err)
+ (run-hook-with-args 'dbus-event-error-functions event err)
(when (or dbus-debug (= dbus-message-type-error (nth 2 event)))
(signal (car err) (cdr err))))))
and PATH must be a valid object path. The last two parameters
are strings. The result, the introspection data, is a string in
XML format."
- ;; We don't want to raise errors. `dbus-call-method-non-blocking'
- ;; is used, because the handler can be registered in our Emacs
- ;; instance; caller and callee would block each other.
+ ;; We don't want to raise errors.
(dbus-ignore-errors
(dbus-call-method
bus service path dbus-interface-introspectable "Introspect"
bus service path dbus-interface-properties
"GetAll" :timeout 500 interface)
result)
- (add-to-list 'result (cons (car dict) (caadr dict)) 'append)))))
+ (add-to-list 'result (cons (car dict) (cl-caadr dict)) 'append)))))
(defun dbus-register-property
(bus service path interface property access value
existing path name, and the list of available interface objects.
An interface object is another cons, which car is the interface
name, and the cdr is the list of properties as returned by
-`dbus-get-all-properties' for that path and interface. Example:
+`dbus-get-all-properties' for that path and interface. Example:
\(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\")
(if (cadr entry2)
;; "sv".
(dolist (entry3 (cadr entry2))
- (setcdr entry3 (caadr entry3)))
+ (setcdr entry3 (cl-caadr entry3)))
(setcdr entry2 nil)))))
;; Fallback: collect the information. Slooow!
It will be registered for all objects created by `dbus-register-method'."
(let* ((last-input-event last-input-event)
(bus (dbus-event-bus-name last-input-event))
- (service (dbus-event-service-name last-input-event))
(path (dbus-event-path-name last-input-event)))
;; "GetManagedObjects" returns "a{oa{sa{sv}}}".
(let (interfaces result)
;; Check all registered object paths.
(maphash
(lambda (key val)
- (let ((object (or (nth 2 (car-safe val)) ""))
- (interface (nth 2 key)))
+ (let ((object (or (nth 2 (car-safe val)) "")))
(when (and (equal (butlast key 2) (list :method bus))
(string-prefix-p path object))
(dolist (interface (cons (nth 2 key) interfaces))
HCoop / bpt / emacs.git / blobdiff