X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/40f185ca85f2129ec33446791be2999d714f35ff..874a927a022d6445a98b4e4faf165a66b10b4a13:/lisp/net/dbus.el diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 9221c52a08..5b108a909f 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1,17 +1,16 @@ -;;; -*- no-byte-compile: t; -*- ;;; dbus.el --- Elisp bindings for D-Bus. -;; Copyright (C) 2007 Free Software Foundation, Inc. +;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm, hardware ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,8 +18,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, see -;; . +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -32,6 +30,17 @@ ;;; Code: +;; D-Bus support in the Emacs core can be disabled with configuration +;; option "--without-dbus". Declare used subroutines and variables. +(declare-function dbus-call-method "dbusbind.c") +(declare-function dbus-register-signal "dbusbind.c") +(defvar dbus-debug) +(defvar dbus-registered-functions-table) + +;; Pacify byte compiler. +(eval-when-compile + (require 'cl)) + (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -43,38 +52,124 @@ (defconst dbus-interface-dbus "org.freedesktop.DBus" "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") -(defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable" +(defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer") + "The interface for peer objects.") + +(defconst dbus-interface-introspectable + (concat dbus-interface-dbus ".Introspectable") "The interface supported by introspectable objects.") +(defmacro dbus-ignore-errors (&rest body) + "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. +Otherwise, return result of last form in BODY, or all other errors." + `(condition-case err + (progn ,@body) + (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) + +(put 'dbus-ignore-errors 'lisp-indent-function 0) +(put 'dbus-ignore-errors 'edebug-form-spec '(form symbolp body)) +(font-lock-add-keywords 'emacs-lisp-mode '("\\")) + ;;; Hash table of registered functions. -(defun dbus-hash-table= (x y) - "Compares keys X and Y in the hash table of registered functions for D-Bus. -See `dbus-registered-functions-table' for a description of the hash table." - (and - (listp x) (listp y) - ;; Bus symbol, either :system or :session. - (symbolp (car x)) (symbolp (car y)) (equal (car x) (car y)) - ;; Interface. - (or - (null (cadr x)) (null (cadr y)) ; wildcard - (and - (stringp (cadr x)) (stringp (cadr y)) (string-equal (cadr x) (cadr y)))) - ;; Member. - (or - (null (caddr x)) (null (caddr y)) ; wildcard - (and - (stringp (caddr x)) (stringp (caddr y)) - (string-equal (caddr x) (caddr y)))))) - -(define-hash-table-test 'dbus-hash-table-test 'dbus-hash-table= 'sxhash) - -;; When we assume that interface and and member are always strings in -;; the key, we could use `equal' as test function. But we want to -;; have also `nil' there, being a wildcard. -(setq dbus-registered-functions-table - (make-hash-table :test 'dbus-hash-table-test)) +;; 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)) + +(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 +hash table." + (let (result) + (maphash + '(lambda (key value) (add-to-list 'result (cons key value) 'append)) + dbus-registered-functions-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." + ;; 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))) + ;; Loop over the registered functions. + (while (consp value) + ;; (car value) has the structure (UNAME SERVICE PATH HANDLER). + ;; (cdr object) has the structure ((SERVICE PATH HANDLER) ...). + (if (not (equal (cdr (car value)) (car (cdr object)))) + (setq value (cdr value)) + ;; Compute new hash value. If it is empty, remove it from + ;; hash table. + (unless + (puthash + key + (delete (car value) (gethash key dbus-registered-functions-table)) + dbus-registered-functions-table) + (remhash key dbus-registered-functions-table)) + (setq value t))) + value)) + +(defun dbus-name-owner-changed-handler (&rest args) + "Reapplies all member registrations to D-Bus. +This handler is applied when a \"NameOwnerChanged\" signal has +arrived. SERVICE is the object name for which the name owner has +been changed. OLD-OWNER is the previous owner of SERVICE, or the +empty string if SERVICE was not owned yet. NEW-OWNER is the new +owner of SERVICE, or the empty string if SERVICE looses any name owner. + +usage: (dbus-name-owner-changed-handler service old-owner new-owner)" + (save-match-data + ;; Check the arguments. We should silently ignore it when they + ;; are wrong. + (if (and (= (length args) 3) + (stringp (car args)) + (stringp (cadr args)) + (stringp (caddr args))) + (let ((service (car args)) + (old-owner (cadr args)) + (new-owner (caddr args))) + ;; Check whether SERVICE is a known name. + (when (not (string-match "^:" service)) + (maphash + '(lambda (key value) + (dolist (elt value) + ;; key has the structure (BUS INTERFACE MEMBER). + ;; elt has the structure (UNAME SERVICE PATH HANDLER). + (when (string-equal old-owner (car elt)) + ;; Remove old key, and add new entry with changed name. + (dbus-unregister-object (list key (cdr elt))) + ;; Maybe we could arrange the lists a little bit better + ;; that we don't need to extract every single element? + (dbus-register-signal + ;; BUS SERVICE PATH + (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)))) + ;; The error is reported only in debug mode. + (when dbus-debug + (signal + 'dbus-error + (cons + (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus) + args)))))) + +;; Register the handler. +(ignore-errors + (dbus-register-signal + :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "NameOwnerChanged" 'dbus-name-owner-changed-handler) + (dbus-register-signal + :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "NameOwnerChanged" 'dbus-name-owner-changed-handler)) ;;; D-Bus events. @@ -83,25 +178,27 @@ See `dbus-registered-functions-table' for a description of the hash table." "Checks whether EVENT is a well formed D-Bus event. EVENT is a list which starts with symbol `dbus-event': - (dbus-event HANDLER BUS SERVICE PATH INTERFACE MEMBER &rest ARGS) + (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) -HANDLER is the function which has been registered for this -signal. BUS identifies the D-Bus the signal is coming from. It -is either the symbol `:system' or the symbol `:session'. SERVICE -and PATH are the name and the object path of the D-Bus object -emitting the signal. INTERFACE and MEMBER denote the signal -which has been sent. ARGS are the arguments passed to HANDLER, -when it is called during event handling in `dbus-handle-event'. +BUS identifies the D-Bus the message is coming from. It is +either the symbol `:system' or the symbol `:session'. SERIAL is +the serial number of the received D-Bus message if it is a method +call, or nil. SERVICE and PATH are the unique name and the +object path of the D-Bus object emitting the message. INTERFACE +and MEMBER denote the message which has been sent. HANDLER is +the function which has been registered for this message. ARGS +are the arguments passed to HANDLER, when it is called during +event handling in `dbus-handle-event'. This function raises a `dbus-error' signal in case the event is not well formed." (when dbus-debug (message "DBus-Event %s" event)) (unless (and (listp event) (eq (car event) 'dbus-event) - ;; Handler. - (functionp (nth 1 event)) ;; Bus symbol. - (symbolp (nth 2 event)) + (symbolp (nth 1 event)) + ;; Serial. + (or (natnump (nth 2 event)) (null (nth 2 event))) ;; Service. (stringp (nth 3 event)) ;; Object path. @@ -109,7 +206,9 @@ not well formed." ;; Interface. (stringp (nth 5 event)) ;; Member. - (stringp (nth 6 event))) + (stringp (nth 6 event)) + ;; Handler. + (functionp (nth 7 event))) (signal 'dbus-error (list "Not a valid D-Bus event" event)))) ;;;###autoload @@ -120,11 +219,15 @@ part of the event, is called with arguments ARGS." (interactive "e") ;; We don't want to raise an error, because this function is called ;; in the event handling loop. - (condition-case nil - (progn - (dbus-check-event event) - (apply (cadr event) (nthcdr 7 event))) - (dbus-error))) + (dbus-ignore-errors + (let (result) + (dbus-check-event event) + (setq result (apply (nth 7 event) (nthcdr 8 event))) + (unless (consp result) (setq result (cons result nil))) + ;; Return a message when serial is not nil. + (when (not (null (nth 2 event))) + (apply 'dbus-method-return-internal + (nth 1 event) (nth 2 event) (nth 3 event) result))))) (defun dbus-event-bus-name (event) "Return the bus name the event is coming from. @@ -132,6 +235,16 @@ The result is either the symbol `:system' or the symbol `:session'. EVENT is a D-Bus event, see `dbus-check-event'. This function raises a `dbus-error' signal in case the event is not well formed." + (dbus-check-event event) + (nth 1 event)) + +(defun dbus-event-serial-number (event) + "Return the serial number of the corresponding D-Bus message. +The result is a number in case the D-Bus message is a method +call, or nil for all other mesage types. The serial number is +needed for generating a reply message. EVENT is a D-Bus event, +see `dbus-check-event'. This function raises a `dbus-error' +signal in case the event is not well formed." (dbus-check-event event) (nth 2 event)) @@ -175,11 +288,10 @@ well formed." "Return the D-Bus service names which can be activated as list. The result is a list of strings, which is nil when there are no activatable service names at all." - (condition-case nil - (dbus-call-method - :system "ListActivatableNames" dbus-service-dbus - dbus-path-dbus dbus-interface-dbus) - (dbus-error))) + (dbus-ignore-errors + (dbus-call-method + :system dbus-service-dbus + dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))) (defun dbus-list-names (bus) "Return the service names registered at D-Bus BUS. @@ -187,10 +299,9 @@ The result is a list of strings, which is nil when there are no registered service names at all. Well known names are strings like \"org.freedesktop.DBus\". Names starting with \":\" are unique names for services." - (condition-case nil - (dbus-call-method - bus "ListNames" dbus-service-dbus dbus-path-dbus dbus-interface-dbus) - (dbus-error))) + (dbus-ignore-errors + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))) (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. @@ -204,20 +315,27 @@ A service has a known name if it doesn't start with \":\"." "Return the unique names registered at D-Bus BUS and queued for SERVICE. The result is a list of strings, or nil when there are no queued name owners service names at all." - (condition-case nil - (dbus-call-method - bus "ListQueuedOwners" dbus-service-dbus - dbus-path-dbus dbus-interface-dbus service) - (dbus-error))) + (dbus-ignore-errors + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus + dbus-interface-dbus "ListQueuedOwners" service))) (defun dbus-get-name-owner (bus service) "Return the name owner of SERVICE registered at D-Bus BUS. The result is either a string, or nil if there is no name owner." + (dbus-ignore-errors + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus + dbus-interface-dbus "GetNameOwner" service))) + +(defun dbus-ping (bus service) + "Check whether SERVICE is registered for D-Bus BUS." + ;; "Ping" raises a D-Bus error if SERVICE does not exist. + ;; Otherwise, it returns silently with `nil'. (condition-case nil - (dbus-call-method - bus "GetNameOwner" dbus-service-dbus - dbus-path-dbus dbus-interface-dbus service) - (dbus-error))) + (not + (dbus-call-method bus service dbus-path-dbus dbus-interface-peer "Ping")) + (dbus-error nil))) (defun dbus-introspect (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. @@ -227,11 +345,10 @@ Example: \(dbus-introspect :system \"org.freedesktop.Hal\" - \"/org/freedesktop/Hal/devices/computer\"))" - (condition-case nil - (dbus-call-method - bus "Introspect" service path dbus-interface-introspectable) - (dbus-error))) + \"/org/freedesktop/Hal/devices/computer\")" + (dbus-ignore-errors + (dbus-call-method + bus service path dbus-interface-introspectable "Introspect"))) (if nil ;; Must be reworked. Shall we offer D-Bus signatures at all? (defun dbus-get-signatures (bus interface signal) @@ -247,42 +364,39 @@ the third parameter is of type array of integer. If INTERFACE or SIGNAL do not exist, or if they do not support the D-Bus method org.freedesktop.DBus.Introspectable.Introspect, the function returns nil." - (condition-case nil - (let ((introspect-xml - (with-temp-buffer - (insert (dbus-introspect bus interface)) - (xml-parse-region (point-min) (point-max)))) - node interfaces signals args result) - ;; Get the root node. - (setq node (xml-node-name introspect-xml)) - ;; Get all interfaces. - (setq interfaces (xml-get-children node 'interface)) - (while interfaces - (when (string-equal (xml-get-attribute (car interfaces) 'name) - interface) - ;; That's the requested interface. Check for signals. - (setq signals (xml-get-children (car interfaces) 'signal)) - (while signals - (when (string-equal (xml-get-attribute (car signals) 'name) - signal) - ;; The signal we are looking for. - (setq args (xml-get-children (car signals) 'arg)) - (while args - (unless (xml-get-attribute (car args) 'type) - ;; This shouldn't happen, let's escape. - (signal 'dbus-error "")) - ;; We append the signature. - (setq - result (append result - (list (xml-get-attribute (car args) 'type)))) - (setq args (cdr args))) - (setq signals nil)) - (setq signals (cdr signals))) - (setq interfaces nil)) - (setq interfaces (cdr interfaces))) - result) - ;; We ignore `dbus-error'. There might be no introspectable interface. - (dbus-error nil))) + (dbus-ignore-errors + (let ((introspect-xml + (with-temp-buffer + (insert (dbus-introspect bus interface)) + (xml-parse-region (point-min) (point-max)))) + node interfaces signals args result) + ;; Get the root node. + (setq node (xml-node-name introspect-xml)) + ;; Get all interfaces. + (setq interfaces (xml-get-children node 'interface)) + (while interfaces + (when (string-equal (xml-get-attribute (car interfaces) 'name) + interface) + ;; That's the requested interface. Check for signals. + (setq signals (xml-get-children (car interfaces) 'signal)) + (while signals + (when (string-equal (xml-get-attribute (car signals) 'name) signal) + ;; The signal we are looking for. + (setq args (xml-get-children (car signals) 'arg)) + (while args + (unless (xml-get-attribute (car args) 'type) + ;; This shouldn't happen, let's escape. + (signal 'dbus-error nil)) + ;; We append the signature. + (setq + result (append result + (list (xml-get-attribute (car args) 'type)))) + (setq args (cdr args))) + (setq signals nil)) + (setq signals (cdr signals))) + (setq interfaces nil)) + (setq interfaces (cdr interfaces))) + result))) ) ;; (if nil ... (provide 'dbus)