X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d29ee6b1a110cf5d170a10317a96acbbd4a1c68b..874a927a022d6445a98b4e4faf165a66b10b4a13:/lisp/net/dbus.el diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 83d0f7fa3e..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,9 +52,24 @@ (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. @@ -54,7 +78,7 @@ (setq dbus-registered-functions-table (make-hash-table :test 'equal)) (defun dbus-list-hash-table () - "Returns all registered signal registrations to D-Bus. + "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." @@ -64,48 +88,88 @@ hash table." dbus-registered-functions-table) result)) -(defun dbus-name-owner-changed-handler (service old-owner new-owner) - "Reapplies all signal registrations to D-Bus. +(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." +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 whether SERVICE is a known name. - (when (and (stringp service) (not (string-match "^:" service)) - (stringp old-owner) (stringp new-owner)) - (maphash - '(lambda (key value) - (dolist (elt value) - ;; key has the structure (BUS INTERFACE SIGNAL). - ;; elt has the structure (SERVICE UNAME PATH HANDLER). - (when (string-equal old-owner (cadr elt)) - ;; Remove old key, and add new entry with changed name. - (when dbus-debug (message "Remove rule for %s %s" key elt)) - ;(dbus-unregister-signal key) - (setcar (cdr elt) new-owner) - (when dbus-debug (message "Add rule for %s %s" key elt)) - ;; Maybe we could arrange the lists a little bit better - ;; that we don't need to extract every single element? - (when (not (zerop (length new-owner))) - (dbus-register-signal - ;; BUS SERVICE PATH - (nth 0 key) (nth 0 elt) (nth 2 elt) - ;; INTERFACE SIGNAL HANDLER - (nth 1 key) (nth 2 key) (nth 3 elt)))))) - (copy-hash-table dbus-registered-functions-table))))) + ;; 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. -(condition-case nil - (progn - (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)) - (dbus-error)) +(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. @@ -114,16 +178,17 @@ owner of SERVICE, or the empty string if SERVICE looses any name owner." "Checks whether EVENT is a well formed D-Bus event. EVENT is a list which starts with symbol `dbus-event': - (dbus-event BUS SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) + (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) -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 unique name and the object path of the D-Bus object -emitting the signal. INTERFACE and MEMBER denote the signal -which has been sent. HANDLER is the function which has been -registered for this signal. 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." @@ -132,16 +197,18 @@ not well formed." (eq (car event) 'dbus-event) ;; Bus symbol. (symbolp (nth 1 event)) + ;; Serial. + (or (natnump (nth 2 event)) (null (nth 2 event))) ;; Service. - (stringp (nth 2 event)) - ;; Object path. (stringp (nth 3 event)) - ;; Interface. + ;; Object path. (stringp (nth 4 event)) - ;; Member. + ;; Interface. (stringp (nth 5 event)) + ;; Member. + (stringp (nth 6 event)) ;; Handler. - (functionp (nth 6 event))) + (functionp (nth 7 event))) (signal 'dbus-error (list "Not a valid D-Bus event" event)))) ;;;###autoload @@ -152,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 (nth 6 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. @@ -167,13 +238,23 @@ 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)) + (defun dbus-event-service-name (event) "Return the name of the D-Bus object the event is coming from. The result is a string. 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)) + (nth 3 event)) (defun dbus-event-path-name (event) "Return the object path of the D-Bus object the event is coming from. @@ -181,7 +262,7 @@ The result is a string. 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 3 event)) + (nth 4 event)) (defun dbus-event-interface-name (event) "Return the interface name of the D-Bus object the event is coming from. @@ -189,7 +270,7 @@ The result is a string. 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 4 event)) + (nth 5 event)) (defun dbus-event-member-name (event) "Return the member name the event is coming from. @@ -198,7 +279,7 @@ string. 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 5 event)) + (nth 6 event)) ;;; D-Bus registered names. @@ -207,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 dbus-service-dbus - dbus-path-dbus dbus-interface-dbus "ListActivatableNames") - (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. @@ -219,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 dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames") - (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. @@ -236,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 dbus-service-dbus dbus-path-dbus - dbus-interface-dbus "ListQueuedOwners" 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 dbus-service-dbus dbus-path-dbus - dbus-interface-dbus "GetNameOwner" 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. @@ -260,10 +346,9 @@ Example: \(dbus-introspect :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\")" - (condition-case nil - (dbus-call-method - bus service path dbus-interface-introspectable "Introspect") - (dbus-error))) + (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) @@ -279,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)