;;; dbus.el --- Elisp bindings for D-Bus.
-;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
;; Declare used subroutines and variables.
(declare-function dbus-message-internal "dbusbind.c")
-(declare-function dbus-init-bus-1 "dbusbind.c")
+(declare-function dbus--init-bus "dbusbind.c")
(defvar dbus-message-type-invalid)
(defvar dbus-message-type-method-call)
(defvar dbus-message-type-method-return)
(defconst dbus-path-dbus "/org/freedesktop/DBus"
"The object path used to talk to the bus itself.")
+(defconst dbus-path-local (concat dbus-path-dbus "/Local")
+ "The object path used in local/in-process-generated messages.")
+
;; Default D-Bus interfaces.
(defconst dbus-interface-dbus "org.freedesktop.DBus"
;; </signal>
;; </interface>
+(defconst dbus-interface-local (concat dbus-interface-dbus ".Local")
+ "An interface whose methods can only be invoked by the local implementation.")
+
+;; <interface name="org.freedesktop.DBus.Local">
+;; <signal name="Disconnected">
+;; <arg name="object_path" type="o"/>
+;; </signal>
+;; </interface>
+
;; Emacs defaults.
(defconst dbus-service-emacs "org.gnu.Emacs"
"The well known service name of Emacs.")
A key in this hash table is a list (:serial BUS SERIAL), like in
`dbus-registered-objects-table'. BUS is either a Lisp symbol,
`:system' or `:session', or a string denoting the bus address.
-SERIAL is the serial number of the reply message.")
+SERIAL is the serial number of the reply message.
+
+The value of an entry is a cons (STATE . RESULT). STATE can be
+either `:pending' (we are still waiting for the result),
+`:complete' (the result is available) or `:error' (the reply
+message was an error message).")
(defun dbus-call-method-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* ((key (list :serial
- (dbus-event-bus-name last-input-event)
- (dbus-event-serial-number last-input-event)))
+ (let* ((key (list :serial
+ (dbus-event-bus-name last-input-event)
+ (dbus-event-serial-number last-input-event)))
(result (gethash key dbus-return-values-table)))
(when (consp result)
(setcar result :complete)
(defun dbus-notice-synchronous-call-errors (ev er)
"Detect errors resulting from pending synchronous calls."
- (let* ((key (list :serial
- (dbus-event-bus-name ev)
- (dbus-event-serial-number ev)))
+ (let* ((key (list :serial
+ (dbus-event-bus-name ev)
+ (dbus-event-serial-number ev)))
(result (gethash key dbus-return-values-table)))
(when (consp result)
(setcar result :error)
=> \"i686\""
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(while (eq (car result) :pending)
(let ((event (let ((inhibit-redisplay t) unread-command-events)
(read-event nil nil check-interval))))
- (when event
- (setf unread-command-events
- (nconc unread-command-events
- (cons event nil))))
+ (when event
+ (if (ignore-errors (dbus-check-event event))
+ (setf result (gethash key dbus-return-values-table))
+ (setf unread-command-events
+ (nconc unread-command-events
+ (cons event nil)))))
(when (< check-interval 1)
(setf check-interval (* check-interval 1.05))))))
(when (eq (car result) :error)
-| i686"
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
:session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\"
\"FileModified\" \"/home/albinus/.emacs\")"
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (null service) (stringp service)
"Return for message SERIAL on the D-Bus BUS.
This is an internal function, it shall not be used outside dbus.el."
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
"Return error message for message SERIAL on the D-Bus BUS.
This is an internal function, it shall not be used outside dbus.el."
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
`:already-owner': Service is already the primary owner."
+ ;; Add Peer handler.
+ (dbus-register-method
+ bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register)
+
;; Add ObjectManager handler.
(dbus-register-method
bus service nil dbus-interface-objectmanager "GetManagedObjects"
bus service dbus-path-dbus dbus-interface-peer "Ping")))
(dbus-error nil)))
+(defun dbus-peer-handler ()
+ "Default handler for the \"org.freedesktop.DBus.Peer\" interface.
+It will be registered for all objects created by `dbus-register-service'."
+ (let* ((last-input-event last-input-event)
+ (method (dbus-event-member-name last-input-event)))
+ (cond
+ ;; "Ping" does not return an output parameter.
+ ((string-equal method "Ping")
+ :ignore)
+ ;; "GetMachineId" returns "s".
+ ((string-equal method "GetMachineId")
+ (signal
+ 'dbus-error
+ (list
+ (format "%s.GetMachineId not implemented" dbus-interface-peer)))))))
+
\f
;;; D-Bus introspection.
(defun dbus-managed-objects-handler ()
"Default handler for the \"org.freedesktop.DBus.ObjectManager\" interface.
-It will be registered for all objects created by `dbus-register-method'."
+It will be registered for all objects created by `dbus-register-service'."
(let* ((last-input-event last-input-event)
(bus (dbus-event-bus-name last-input-event))
(path (dbus-event-path-name last-input-event)))
nil
nil
value)
- '(dbus-error "Bus disconnected"))
+ (list 'dbus-error "Bus disconnected" bus))
(push key keys-to-remove)))
dbus-registered-objects-table)
(dolist (key keys-to-remove)
connection used in the same Emacs process, like the one established by
GTK+. It should be used with care for at least the `:system' and
`:session' buses, because other Emacs Lisp packages might already use
-this connection to those buses.
-"
- (dbus-init-bus-1 bus private)
- (dbus-register-signal bus nil
- "/org/freedesktop/DBus/Local"
- "org.freedesktop.DBus.Local"
- "Disconnected"
- #'dbus-handle-bus-disconnect))
+this connection to those buses."
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
+ (dbus--init-bus bus private)
+ (dbus-register-signal
+ bus nil dbus-path-local dbus-interface-local
+ "Disconnected" #'dbus-handle-bus-disconnect))
\f
;; Initialize `:system' and `:session' buses. This adds their file