LCOV - code coverage report
Current view: top level - lisp/net - dbus.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 104 670 15.5 %
Date: 2017-08-27 09:44:50 Functions: 9 74 12.2 %

          Line data    Source code
       1             : ;;; dbus.el --- Elisp bindings for D-Bus. -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Author: Michael Albinus <michael.albinus@gmx.de>
       6             : ;; Keywords: comm, hardware
       7             : 
       8             : ;; This file is part of GNU Emacs.
       9             : 
      10             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      11             : ;; it under the terms of the GNU General Public License as published by
      12             : ;; the Free Software Foundation, either version 3 of the License, or
      13             : ;; (at your option) any later version.
      14             : 
      15             : ;; GNU Emacs is distributed in the hope that it will be useful,
      16             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      17             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      18             : ;; GNU General Public License for more details.
      19             : 
      20             : ;; You should have received a copy of the GNU General Public License
      21             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      22             : 
      23             : ;;; Commentary:
      24             : 
      25             : ;; This package provides language bindings for the D-Bus API.  D-Bus
      26             : ;; is a message bus system, a simple way for applications to talk to
      27             : ;; one another.  See <http://dbus.freedesktop.org/> for details.
      28             : 
      29             : ;; Low-level language bindings are implemented in src/dbusbind.c.
      30             : 
      31             : ;; D-Bus support in the Emacs core can be disabled with configuration
      32             : ;; option "--without-dbus".
      33             : 
      34             : ;;; Code:
      35             : 
      36             : ;; Declare used subroutines and variables.
      37             : (declare-function dbus-message-internal "dbusbind.c")
      38             : (declare-function dbus--init-bus "dbusbind.c")
      39             : (defvar dbus-message-type-invalid)
      40             : (defvar dbus-message-type-method-call)
      41             : (defvar dbus-message-type-method-return)
      42             : (defvar dbus-message-type-error)
      43             : (defvar dbus-message-type-signal)
      44             : (defvar dbus-debug)
      45             : (defvar dbus-registered-objects-table)
      46             : 
      47             : ;; Pacify byte compiler.
      48             : (eval-when-compile (require 'cl-lib))
      49             : 
      50             : (require 'xml)
      51             : 
      52             : (defconst dbus-service-dbus "org.freedesktop.DBus"
      53             :   "The bus name used to talk to the bus itself.")
      54             : 
      55             : (defconst dbus-path-dbus "/org/freedesktop/DBus"
      56             :   "The object path used to talk to the bus itself.")
      57             : 
      58             : (defconst dbus-path-local (concat dbus-path-dbus "/Local")
      59             :   "The object path used in local/in-process-generated messages.")
      60             : 
      61             : ;; Default D-Bus interfaces.
      62             : 
      63             : (defconst dbus-interface-dbus "org.freedesktop.DBus"
      64             :   "The interface exported by the service `dbus-service-dbus'.")
      65             : 
      66             : (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer")
      67             :   "The interface for peer objects.
      68             : See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-peer'.")
      69             : 
      70             : ;; <interface name="org.freedesktop.DBus.Peer">
      71             : ;;   <method name="Ping">
      72             : ;;   </method>
      73             : ;;   <method name="GetMachineId">
      74             : ;;     <arg name="machine_uuid" type="s" direction="out"/>
      75             : ;;   </method>
      76             : ;; </interface>
      77             : 
      78             : (defconst dbus-interface-introspectable
      79             :   (concat dbus-interface-dbus ".Introspectable")
      80             :   "The interface supported by introspectable objects.
      81             : See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-introspectable'.")
      82             : 
      83             : ;; <interface name="org.freedesktop.DBus.Introspectable">
      84             : ;;   <method name="Introspect">
      85             : ;;     <arg name="data" type="s" direction="out"/>
      86             : ;;   </method>
      87             : ;; </interface>
      88             : 
      89             : (defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties")
      90             :   "The interface for property objects.
      91             : See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-properties'.")
      92             : 
      93             : ;; <interface name="org.freedesktop.DBus.Properties">
      94             : ;;   <method name="Get">
      95             : ;;     <arg name="interface" type="s" direction="in"/>
      96             : ;;     <arg name="propname"  type="s" direction="in"/>
      97             : ;;     <arg name="value"     type="v" direction="out"/>
      98             : ;;   </method>
      99             : ;;   <method name="Set">
     100             : ;;     <arg name="interface" type="s" direction="in"/>
     101             : ;;     <arg name="propname"  type="s" direction="in"/>
     102             : ;;     <arg name="value"     type="v" direction="in"/>
     103             : ;;   </method>
     104             : ;;   <method name="GetAll">
     105             : ;;     <arg name="interface" type="s" direction="in"/>
     106             : ;;     <arg name="props"     type="a{sv}" direction="out"/>
     107             : ;;   </method>
     108             : ;;   <signal name="PropertiesChanged">
     109             : ;;     <arg name="interface" type="s"/>
     110             : ;;     <arg name="changed_properties"     type="a{sv}"/>
     111             : ;;     <arg name="invalidated_properties" type="as"/>
     112             : ;;   </signal>
     113             : ;; </interface>
     114             : 
     115             : (defconst dbus-interface-objectmanager
     116             :   (concat dbus-interface-dbus ".ObjectManager")
     117             :   "The object manager interface.
     118             : See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager'.")
     119             : 
     120             : ;; <interface name="org.freedesktop.DBus.ObjectManager">
     121             : ;;   <method name="GetManagedObjects">
     122             : ;;     <arg name="object_paths_interfaces_and_properties"
     123             : ;;          type="a{oa{sa{sv}}}" direction="out"/>
     124             : ;;   </method>
     125             : ;;   <signal name="InterfacesAdded">
     126             : ;;     <arg name="object_path"               type="o"/>
     127             : ;;     <arg name="interfaces_and_properties" type="a{sa{sv}}"/>
     128             : ;;   </signal>
     129             : ;;   <signal name="InterfacesRemoved">
     130             : ;;     <arg name="object_path"               type="o"/>
     131             : ;;     <arg name="interfaces"                type="as"/>
     132             : ;;   </signal>
     133             : ;; </interface>
     134             : 
     135             : (defconst dbus-interface-local (concat dbus-interface-dbus ".Local")
     136             :   "An interface whose methods can only be invoked by the local implementation.")
     137             : 
     138             : ;; <interface name="org.freedesktop.DBus.Local">
     139             : ;;   <signal name="Disconnected">
     140             : ;;     <arg name="object_path"               type="o"/>
     141             : ;;   </signal>
     142             : ;; </interface>
     143             : 
     144             : ;; Emacs defaults.
     145             : (defconst dbus-service-emacs "org.gnu.Emacs"
     146             :   "The well known service name of Emacs.")
     147             : 
     148             : (defconst dbus-path-emacs "/org/gnu/Emacs"
     149             :   "The object path namespace used by Emacs.
     150             : All object paths provided by the service `dbus-service-emacs'
     151             : shall be subdirectories of this path.")
     152             : 
     153             : (defconst dbus-interface-emacs "org.gnu.Emacs"
     154             :   "The interface namespace used by Emacs.")
     155             : 
     156             : ;; D-Bus constants.
     157             : 
     158             : (defmacro dbus-ignore-errors (&rest body)
     159             :   "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
     160             : Otherwise, return result of last form in BODY, or all other errors."
     161             :   (declare (indent 0) (debug t))
     162          14 :   `(condition-case err
     163          14 :        (progn ,@body)
     164          14 :      (dbus-error (when dbus-debug (signal (car err) (cdr err))))))
     165             : (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
     166             : 
     167             : (define-obsolete-variable-alias 'dbus-event-error-hooks
     168             :   'dbus-event-error-functions "24.3")
     169             : (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors)
     170             :   "Functions to be called when a D-Bus error happens in the event handler.
     171             : Every function must accept two arguments, the event and the error variable
     172             : caught in `condition-case' by `dbus-error'.")
     173             : 
     174             : 
     175             : ;;; Basic D-Bus message functions.
     176             : 
     177             : (defvar dbus-return-values-table (make-hash-table :test 'equal)
     178             :   "Hash table for temporary storing arguments of reply messages.
     179             : A key in this hash table is a list (:serial BUS SERIAL), like in
     180             : `dbus-registered-objects-table'.  BUS is either a Lisp symbol,
     181             : `:system' or `:session', or a string denoting the bus address.
     182             : SERIAL is the serial number of the reply message.
     183             : 
     184             : The value of an entry is a cons (STATE . RESULT).  STATE can be
     185             : either `:pending' (we are still waiting for the result),
     186             : `:complete' (the result is available) or `:error' (the reply
     187             : message was an error message).")
     188             : 
     189             : (defun dbus-call-method-handler (&rest args)
     190             :   "Handler for reply messages of asynchronous D-Bus message calls.
     191             : It calls the function stored in `dbus-registered-objects-table'.
     192             : The result will be made available in `dbus-return-values-table'."
     193           1 :   (let* ((key (list :serial
     194           1 :                     (dbus-event-bus-name last-input-event)
     195           1 :                     (dbus-event-serial-number last-input-event)))
     196           1 :          (result (gethash key dbus-return-values-table)))
     197           1 :     (when (consp result)
     198           1 :       (setcar result :complete)
     199           1 :       (setcdr result (if (= (length args) 1) (car args) args)))))
     200             : 
     201             : (defun dbus-notice-synchronous-call-errors (ev er)
     202             :   "Detect errors resulting from pending synchronous calls."
     203           0 :   (let* ((key (list :serial
     204           0 :                     (dbus-event-bus-name ev)
     205           0 :                     (dbus-event-serial-number ev)))
     206           0 :          (result (gethash key dbus-return-values-table)))
     207           0 :     (when (consp result)
     208           0 :       (setcar result :error)
     209           0 :       (setcdr result er))))
     210             : 
     211             : (defun dbus-call-method (bus service path interface method &rest args)
     212             :   "Call METHOD on the D-Bus BUS.
     213             : 
     214             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     215             : denoting the bus address.
     216             : 
     217             : SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
     218             : object path SERVICE is registered at.  INTERFACE is an interface
     219             : offered by SERVICE.  It must provide METHOD.
     220             : 
     221             : If the parameter `:timeout' is given, the following integer TIMEOUT
     222             : specifies the maximum number of milliseconds the method call must
     223             : return.  The default value is 25,000.  If the method call doesn't
     224             : return in time, a D-Bus error is raised.
     225             : 
     226             : All other arguments ARGS are passed to METHOD as arguments.  They are
     227             : converted into D-Bus types via the following rules:
     228             : 
     229             :   t and nil => DBUS_TYPE_BOOLEAN
     230             :   number    => DBUS_TYPE_UINT32
     231             :   integer   => DBUS_TYPE_INT32
     232             :   float     => DBUS_TYPE_DOUBLE
     233             :   string    => DBUS_TYPE_STRING
     234             :   list      => DBUS_TYPE_ARRAY
     235             : 
     236             : All arguments can be preceded by a type symbol.  For details about
     237             : type symbols, see Info node `(dbus)Type Conversion'.
     238             : 
     239             : `dbus-call-method' returns the resulting values of METHOD as a list of
     240             : Lisp objects.  The type conversion happens the other direction as for
     241             : input arguments.  It follows the mapping rules:
     242             : 
     243             :   DBUS_TYPE_BOOLEAN     => t or nil
     244             :   DBUS_TYPE_BYTE        => number
     245             :   DBUS_TYPE_UINT16      => number
     246             :   DBUS_TYPE_INT16       => integer
     247             :   DBUS_TYPE_UINT32      => number or float
     248             :   DBUS_TYPE_UNIX_FD     => number or float
     249             :   DBUS_TYPE_INT32       => integer or float
     250             :   DBUS_TYPE_UINT64      => number or float
     251             :   DBUS_TYPE_INT64       => integer or float
     252             :   DBUS_TYPE_DOUBLE      => float
     253             :   DBUS_TYPE_STRING      => string
     254             :   DBUS_TYPE_OBJECT_PATH => string
     255             :   DBUS_TYPE_SIGNATURE   => string
     256             :   DBUS_TYPE_ARRAY       => list
     257             :   DBUS_TYPE_VARIANT     => list
     258             :   DBUS_TYPE_STRUCT      => list
     259             :   DBUS_TYPE_DICT_ENTRY  => list
     260             : 
     261             : Example:
     262             : 
     263             : \(dbus-call-method
     264             :   :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\"
     265             :   \"org.gnome.seahorse.Keys\" \"GetKeyField\"
     266             :   \"openpgp:657984B8C7A966DD\" \"simple-name\")
     267             : 
     268             :   => (t (\"Philip R. Zimmermann\"))
     269             : 
     270             : If the result of the METHOD call is just one value, the converted Lisp
     271             : object is returned instead of a list containing this single Lisp object.
     272             : 
     273             : \(dbus-call-method
     274             :   :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
     275             :   \"org.freedesktop.Hal.Device\" \"GetPropertyString\"
     276             :   \"system.kernel.machine\")
     277             : 
     278             :   => \"i686\""
     279             : 
     280           1 :   (or (featurep 'dbusbind)
     281           1 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
     282           1 :   (or (memq bus '(:system :session)) (stringp bus)
     283           1 :       (signal 'wrong-type-argument (list 'keywordp bus)))
     284           1 :   (or (stringp service)
     285           1 :       (signal 'wrong-type-argument (list 'stringp service)))
     286           1 :   (or (stringp path)
     287           1 :       (signal 'wrong-type-argument (list 'stringp path)))
     288           1 :   (or (stringp interface)
     289           1 :       (signal 'wrong-type-argument (list 'stringp interface)))
     290           1 :   (or (stringp method)
     291           1 :       (signal 'wrong-type-argument (list 'stringp method)))
     292             : 
     293           1 :   (let ((timeout (plist-get args :timeout))
     294             :         (check-interval 0.001)
     295             :         (key
     296           1 :          (apply
     297           1 :           'dbus-message-internal dbus-message-type-method-call
     298           1 :           bus service path interface method 'dbus-call-method-handler args))
     299           1 :         (result (cons :pending nil)))
     300             : 
     301             :     ;; Wait until `dbus-call-method-handler' has put the result into
     302             :     ;; `dbus-return-values-table'.  If no timeout is given, use the
     303             :     ;; default 25".  Events which are not from D-Bus must be restored.
     304             :     ;; `read-event' performs a redisplay.  This must be suppressed; it
     305             :     ;; hurts when reading D-Bus events asynchronously.
     306             : 
     307             :     ;; Work around bug#16775 by busy-waiting with gradual backoff for
     308             :     ;; dbus calls to complete.  A better approach would involve either
     309             :     ;; adding arbitrary wait condition support to read-event or
     310             :     ;; restructuring dbus as a kind of process object.  Poll at most
     311             :     ;; about once per second for completion.
     312             : 
     313           1 :     (puthash key result dbus-return-values-table)
     314           1 :     (unwind-protect
     315           1 :          (progn
     316           1 :            (with-timeout ((if timeout (/ timeout 1000.0) 25)
     317           0 :                           (signal 'dbus-error (list "call timed out")))
     318           2 :              (while (eq (car result) :pending)
     319           1 :                (let ((event (let ((inhibit-redisplay t) unread-command-events)
     320           1 :                               (read-event nil nil check-interval))))
     321           1 :                  (when event
     322           0 :                    (if (ignore-errors (dbus-check-event event))
     323           0 :                        (setf result (gethash key dbus-return-values-table))
     324           0 :                      (setf unread-command-events
     325           0 :                            (nconc unread-command-events
     326           1 :                                   (cons event nil)))))
     327           1 :                  (when (< check-interval 1)
     328           1 :                    (setf check-interval (* check-interval 1.05))))))
     329           1 :            (when (eq (car result) :error)
     330           1 :              (signal (cadr result) (cddr result)))
     331           1 :            (cdr result))
     332           1 :       (remhash key dbus-return-values-table))))
     333             : 
     334             : ;; `dbus-call-method' works non-blocking now.
     335             : (defalias 'dbus-call-method-non-blocking 'dbus-call-method)
     336             : (make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3")
     337             : 
     338             : (defun dbus-call-method-asynchronously
     339             :  (bus service path interface method handler &rest args)
     340             :  "Call METHOD on the D-Bus BUS asynchronously.
     341             : 
     342             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     343             : denoting the bus address.
     344             : 
     345             : SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
     346             : object path SERVICE is registered at.  INTERFACE is an interface
     347             : offered by SERVICE.  It must provide METHOD.
     348             : 
     349             : HANDLER is a Lisp function, which is called when the corresponding
     350             : return message has arrived.  If HANDLER is nil, no return message
     351             : will be expected.
     352             : 
     353             : If the parameter `:timeout' is given, the following integer TIMEOUT
     354             : specifies the maximum number of milliseconds the method call must
     355             : return.  The default value is 25,000.  If the method call doesn't
     356             : return in time, a D-Bus error is raised.
     357             : 
     358             : All other arguments ARGS are passed to METHOD as arguments.  They are
     359             : converted into D-Bus types via the following rules:
     360             : 
     361             :   t and nil => DBUS_TYPE_BOOLEAN
     362             :   number    => DBUS_TYPE_UINT32
     363             :   integer   => DBUS_TYPE_INT32
     364             :   float     => DBUS_TYPE_DOUBLE
     365             :   string    => DBUS_TYPE_STRING
     366             :   list      => DBUS_TYPE_ARRAY
     367             : 
     368             : All arguments can be preceded by a type symbol.  For details about
     369             : type symbols, see Info node `(dbus)Type Conversion'.
     370             : 
     371             : If HANDLER is a Lisp function, the function returns a key into the
     372             : hash table `dbus-registered-objects-table'.  The corresponding entry
     373             : in the hash table is removed, when the return message has been arrived,
     374             : and HANDLER is called.
     375             : 
     376             : Example:
     377             : 
     378             : \(dbus-call-method-asynchronously
     379             :   :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
     380             :   \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message
     381             :   \"system.kernel.machine\")
     382             : 
     383             :   => (:serial :system 2)
     384             : 
     385             :   -| i686"
     386             : 
     387           0 :   (or (featurep 'dbusbind)
     388           0 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
     389           0 :   (or (memq bus '(:system :session)) (stringp bus)
     390           0 :       (signal 'wrong-type-argument (list 'keywordp bus)))
     391           0 :   (or (stringp service)
     392           0 :       (signal 'wrong-type-argument (list 'stringp service)))
     393           0 :   (or (stringp path)
     394           0 :       (signal 'wrong-type-argument (list 'stringp path)))
     395           0 :   (or (stringp interface)
     396           0 :       (signal 'wrong-type-argument (list 'stringp interface)))
     397           0 :   (or (stringp method)
     398           0 :       (signal 'wrong-type-argument (list 'stringp method)))
     399           0 :   (or (null handler) (functionp handler)
     400           0 :       (signal 'wrong-type-argument (list 'functionp handler)))
     401             : 
     402           0 :   (apply 'dbus-message-internal dbus-message-type-method-call
     403           0 :          bus service path interface method handler args))
     404             : 
     405             : (defun dbus-send-signal (bus service path interface signal &rest args)
     406             :   "Send signal SIGNAL on the D-Bus BUS.
     407             : 
     408             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     409             : denoting the bus address.  The signal is sent from the D-Bus object
     410             : Emacs is registered at BUS.
     411             : 
     412             : SERVICE is the D-Bus name SIGNAL is sent to.  It can be either a known
     413             : name or a unique name.  If SERVICE is nil, the signal is sent as
     414             : broadcast message.  PATH is the D-Bus object path SIGNAL is sent from.
     415             : INTERFACE is an interface available at PATH.  It must provide signal
     416             : SIGNAL.
     417             : 
     418             : All other arguments ARGS are passed to SIGNAL as arguments.  They are
     419             : converted into D-Bus types via the following rules:
     420             : 
     421             :   t and nil => DBUS_TYPE_BOOLEAN
     422             :   number    => DBUS_TYPE_UINT32
     423             :   integer   => DBUS_TYPE_INT32
     424             :   float     => DBUS_TYPE_DOUBLE
     425             :   string    => DBUS_TYPE_STRING
     426             :   list      => DBUS_TYPE_ARRAY
     427             : 
     428             : All arguments can be preceded by a type symbol.  For details about
     429             : type symbols, see Info node `(dbus)Type Conversion'.
     430             : 
     431             : Example:
     432             : 
     433             : \(dbus-send-signal
     434             :   :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\"
     435             :   \"FileModified\" \"/home/albinus/.emacs\")"
     436             : 
     437           0 :   (or (featurep 'dbusbind)
     438           0 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
     439           0 :   (or (memq bus '(:system :session)) (stringp bus)
     440           0 :       (signal 'wrong-type-argument (list 'keywordp bus)))
     441           0 :   (or (null service) (stringp service)
     442           0 :       (signal 'wrong-type-argument (list 'stringp service)))
     443           0 :   (or (stringp path)
     444           0 :       (signal 'wrong-type-argument (list 'stringp path)))
     445           0 :   (or (stringp interface)
     446           0 :       (signal 'wrong-type-argument (list 'stringp interface)))
     447           0 :   (or (stringp signal)
     448           0 :       (signal 'wrong-type-argument (list 'stringp signal)))
     449             : 
     450           0 :   (apply 'dbus-message-internal dbus-message-type-signal
     451           0 :          bus service path interface signal args))
     452             : 
     453             : (defun dbus-method-return-internal (bus service serial &rest args)
     454             :   "Return for message SERIAL on the D-Bus BUS.
     455             : This is an internal function, it shall not be used outside dbus.el."
     456             : 
     457           0 :   (or (featurep 'dbusbind)
     458           0 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
     459           0 :   (or (memq bus '(:system :session)) (stringp bus)
     460           0 :       (signal 'wrong-type-argument (list 'keywordp bus)))
     461           0 :   (or (stringp service)
     462           0 :       (signal 'wrong-type-argument (list 'stringp service)))
     463           0 :   (or (natnump serial)
     464           0 :       (signal 'wrong-type-argument (list 'natnump serial)))
     465             : 
     466           0 :   (apply 'dbus-message-internal dbus-message-type-method-return
     467           0 :          bus service serial args))
     468             : 
     469             : (defun dbus-method-error-internal (bus service serial &rest args)
     470             :   "Return error message for message SERIAL on the D-Bus BUS.
     471             : This is an internal function, it shall not be used outside dbus.el."
     472             : 
     473           0 :   (or (featurep 'dbusbind)
     474           0 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
     475           0 :   (or (memq bus '(:system :session)) (stringp bus)
     476           0 :       (signal 'wrong-type-argument (list 'keywordp bus)))
     477           0 :   (or (stringp service)
     478           0 :       (signal 'wrong-type-argument (list 'stringp service)))
     479           0 :   (or (natnump serial)
     480           0 :       (signal 'wrong-type-argument (list 'natnump serial)))
     481             : 
     482           0 :   (apply 'dbus-message-internal dbus-message-type-error
     483           0 :          bus service serial args))
     484             : 
     485             : 
     486             : ;;; Hash table of registered functions.
     487             : 
     488             : (defun dbus-list-hash-table ()
     489             :   "Returns all registered member registrations to D-Bus.
     490             : The return value is a list, with elements of kind (KEY . VALUE).
     491             : See `dbus-registered-objects-table' for a description of the
     492             : hash table."
     493           0 :   (let (result)
     494           0 :     (maphash
     495           0 :      (lambda (key value) (push (cons key value) result))
     496           0 :      dbus-registered-objects-table)
     497           0 :     result))
     498             : 
     499             : (defun dbus-setenv (bus variable value)
     500             :   "Set the value of the BUS environment variable named VARIABLE to VALUE.
     501             : 
     502             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     503             : denoting the bus address.  Both VARIABLE and VALUE should be strings.
     504             : 
     505             : Normally, services inherit the environment of the BUS daemon.  This
     506             : function adds to or modifies that environment when activating services.
     507             : 
     508             : Some bus instances, such as `:system', may disable setting the environment."
     509           0 :   (dbus-call-method
     510           0 :    bus dbus-service-dbus dbus-path-dbus
     511           0 :    dbus-interface-dbus "UpdateActivationEnvironment"
     512           0 :    `(:array (:dict-entry ,variable ,value))))
     513             : 
     514             : (defun dbus-register-service (bus service &rest flags)
     515             :   "Register known name SERVICE on the D-Bus BUS.
     516             : 
     517             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     518             : denoting the bus address.
     519             : 
     520             : SERVICE is the D-Bus service name that should be registered.  It must
     521             : be a known name.
     522             : 
     523             : FLAGS are keywords, which control how the service name is registered.
     524             : The following keywords are recognized:
     525             : 
     526             : `:allow-replacement': Allow another service to become the primary
     527             : owner if requested.
     528             : 
     529             : `:replace-existing': Request to replace the current primary owner.
     530             : 
     531             : `:do-not-queue': If we can not become the primary owner do not place
     532             : us in the queue.
     533             : 
     534             : The function returns a keyword, indicating the result of the
     535             : operation.  One of the following keywords is returned:
     536             : 
     537             : `:primary-owner': Service has become the primary owner of the
     538             : requested name.
     539             : 
     540             : `:in-queue': Service could not become the primary owner and has been
     541             : placed in the queue.
     542             : 
     543             : `:exists': Service is already in the queue.
     544             : 
     545             : `:already-owner': Service is already the primary owner."
     546             : 
     547             :   ;; Add Peer handler.
     548           0 :   (dbus-register-method
     549           0 :    bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register)
     550             : 
     551             :   ;; Add ObjectManager handler.
     552           0 :   (dbus-register-method
     553           0 :    bus service nil dbus-interface-objectmanager "GetManagedObjects"
     554           0 :    'dbus-managed-objects-handler 'dont-register)
     555             : 
     556           0 :   (let ((arg 0)
     557             :         reply)
     558           0 :     (dolist (flag flags)
     559           0 :       (setq arg
     560           0 :             (+ arg
     561           0 :                (pcase flag
     562             :                  (:allow-replacement 1)
     563             :                  (:replace-existing 2)
     564             :                  (:do-not-queue 4)
     565           0 :                  (_ (signal 'wrong-type-argument (list flag)))))))
     566           0 :     (setq reply (dbus-call-method
     567           0 :                  bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
     568           0 :                  "RequestName" service arg))
     569           0 :     (pcase reply
     570             :       (1 :primary-owner)
     571             :       (2 :in-queue)
     572             :       (3 :exists)
     573             :       (4 :already-owner)
     574           0 :       (_ (signal 'dbus-error (list "Could not register service" service))))))
     575             : 
     576             : (defun dbus-unregister-service (bus service)
     577             :   "Unregister all objects related to SERVICE from D-Bus BUS.
     578             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     579             : denoting the bus address.  SERVICE must be a known service name.
     580             : 
     581             : The function returns a keyword, indicating the result of the
     582             : operation.  One of the following keywords is returned:
     583             : 
     584             : `:released': We successfully released the service.
     585             : 
     586             : `:non-existent': Service name does not exist on this bus.
     587             : 
     588             : `:not-owner': We are neither the primary owner nor waiting in the
     589             : queue of this service."
     590             : 
     591           0 :   (maphash
     592             :    (lambda (key value)
     593           0 :      (unless (equal :serial (car key))
     594           0 :        (dolist (elt value)
     595           0 :          (ignore-errors
     596           0 :            (when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
     597           0 :              (unless
     598           0 :                  (puthash key (delete elt value) dbus-registered-objects-table)
     599           0 :                (remhash key dbus-registered-objects-table)))))))
     600           0 :    dbus-registered-objects-table)
     601           0 :   (let ((reply (dbus-call-method
     602           0 :                 bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
     603           0 :                 "ReleaseName" service)))
     604           0 :     (pcase reply
     605             :       (1 :released)
     606             :       (2 :non-existent)
     607             :       (3 :not-owner)
     608           0 :       (_ (signal 'dbus-error (list "Could not unregister service" service))))))
     609             : 
     610             : (defun dbus-register-signal
     611             :   (bus service path interface signal handler &rest args)
     612             :   "Register for a signal on the D-Bus BUS.
     613             : 
     614             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     615             : denoting the bus address.
     616             : 
     617             : SERVICE is the D-Bus service name used by the sending D-Bus object.
     618             : It can be either a known name or the unique name of the D-Bus object
     619             : sending the signal.
     620             : 
     621             : PATH is the D-Bus object path SERVICE is registered.  INTERFACE
     622             : is an interface offered by SERVICE.  It must provide SIGNAL.
     623             : HANDLER is a Lisp function to be called when the signal is
     624             : received.  It must accept as arguments the values SIGNAL is
     625             : sending.
     626             : 
     627             : SERVICE, PATH, INTERFACE and SIGNAL can be nil.  This is
     628             : interpreted as a wildcard for the respective argument.
     629             : 
     630             : The remaining arguments ARGS can be keywords or keyword string pairs.
     631             : The meaning is as follows:
     632             : 
     633             : `:argN' STRING:
     634             : `:pathN' STRING: This stands for the Nth argument of the
     635             : signal.  `:pathN' arguments can be used for object path wildcard
     636             : matches as specified by D-Bus, while an `:argN' argument
     637             : requires an exact match.
     638             : 
     639             : `:arg-namespace' STRING: Register for the signals, which first
     640             : argument defines the service or interface namespace STRING.
     641             : 
     642             : `:path-namespace' STRING: Register for the object path namespace
     643             : STRING.  All signals sent from an object path, which has STRING as
     644             : the preceding string, are matched.  This requires PATH to be nil.
     645             : 
     646             : `:eavesdrop': Register for unicast signals which are not directed
     647             : to the D-Bus object Emacs is registered at D-Bus BUS, if the
     648             : security policy of BUS allows this.
     649             : 
     650             : Example:
     651             : 
     652             : \(defun my-signal-handler (device)
     653             :   (message \"Device %s added\" device))
     654             : 
     655             : \(dbus-register-signal
     656             :   :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
     657             :   \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler)
     658             : 
     659             :   => ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\")
     660             :       (\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler))
     661             : 
     662             : `dbus-register-signal' returns an object, which can be used in
     663             : `dbus-unregister-object' for removing the registration."
     664             : 
     665           1 :   (let ((counter 0)
     666             :         (rule "type='signal'")
     667             :         uname key key1 value)
     668             : 
     669             :     ;; Retrieve unique name of service.  If service is a known name,
     670             :     ;; we will register for the corresponding unique name, if any.
     671             :     ;; Signals are sent always with the unique name as sender.  Note:
     672             :     ;; the unique name of `dbus-service-dbus' is that string itself.
     673           1 :     (if (and (stringp service)
     674           0 :              (not (zerop (length service)))
     675           0 :              (not (string-equal service dbus-service-dbus))
     676           1 :              (not (string-match "^:" service)))
     677           0 :         (setq uname (dbus-get-name-owner bus service))
     678           1 :       (setq uname service))
     679             : 
     680           1 :     (setq rule (concat rule
     681           1 :                        (when uname (format ",sender='%s'" uname))
     682           1 :                        (when interface (format ",interface='%s'" interface))
     683           1 :                        (when signal (format ",member='%s'" signal))
     684           1 :                        (when path (format ",path='%s'" path))))
     685             : 
     686             :     ;; Add arguments to the rule.
     687           1 :     (if (or (stringp (car args)) (null (car args)))
     688             :         ;; As backward compatibility option, we allow just strings.
     689           1 :         (dolist (arg args)
     690           0 :           (if (stringp arg)
     691           0 :               (setq rule (concat rule (format ",arg%d='%s'" counter arg)))
     692           0 :             (if arg (signal 'wrong-type-argument (list "Wrong argument" arg))))
     693           1 :           (setq counter (1+ counter)))
     694             : 
     695             :       ;; Parse keywords.
     696           0 :       (while args
     697           0 :         (setq
     698           0 :          key (car args)
     699           0 :          rule (concat
     700           0 :                rule
     701           0 :                (cond
     702             :                 ;; `:arg0' .. `:arg63', `:path0' .. `:path63'.
     703           0 :                 ((and (keywordp key)
     704           0 :                       (string-match
     705             :                        "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$"
     706           0 :                        (symbol-name key)))
     707           0 :                  (setq counter (match-string 2 (symbol-name key))
     708           0 :                        args (cdr args)
     709           0 :                        value (car args))
     710           0 :                  (unless (and (<= (string-to-number counter) 63)
     711           0 :                               (stringp value))
     712           0 :                    (signal 'wrong-type-argument
     713           0 :                            (list "Wrong argument" key value)))
     714           0 :                  (format
     715             :                   ",arg%s%s='%s'"
     716           0 :                   counter
     717           0 :                   (if (string-equal (match-string 1 (symbol-name key)) "path")
     718           0 :                       "path" "")
     719           0 :                   value))
     720             :                 ;; `:arg-namespace', `:path-namespace'.
     721           0 :                 ((and (keywordp key)
     722           0 :                       (string-match
     723           0 :                        "^:\\(arg\\|path\\)-namespace$" (symbol-name key)))
     724           0 :                  (setq args (cdr args)
     725           0 :                        value (car args))
     726           0 :                  (unless (stringp value)
     727           0 :                    (signal 'wrong-type-argument
     728           0 :                            (list "Wrong argument" key value)))
     729           0 :                  (format
     730             :                   ",%s='%s'"
     731           0 :                   (if (string-equal (match-string 1 (symbol-name key)) "path")
     732           0 :                       "path_namespace" "arg0namespace")
     733           0 :                   value))
     734             :                 ;; `:eavesdrop'.
     735           0 :                 ((eq key :eavesdrop)
     736             :                  ",eavesdrop='true'")
     737           0 :                 (t (signal 'wrong-type-argument (list "Wrong argument" key)))))
     738           1 :          args (cdr args))))
     739             : 
     740             :     ;; Add the rule to the bus.
     741           1 :     (condition-case err
     742           1 :         (dbus-call-method
     743           1 :          bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
     744           1 :          "AddMatch" rule)
     745             :       (dbus-error
     746           0 :        (if (not (string-match "eavesdrop" rule))
     747           0 :            (signal (car err) (cdr err))
     748             :          ;; The D-Bus spec says we shall fall back to a rule without eavesdrop.
     749           0 :          (when dbus-debug (message "Removing eavesdrop from rule %s" rule))
     750           0 :          (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule))
     751           0 :          (dbus-call-method
     752           0 :           bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
     753           1 :           "AddMatch" rule))))
     754             : 
     755           1 :     (when dbus-debug (message "Matching rule \"%s\" created" rule))
     756             : 
     757             :     ;; Create a hash table entry.
     758           1 :     (setq key (list :signal bus interface signal)
     759           1 :           key1 (list uname service path handler rule)
     760           1 :           value (gethash key dbus-registered-objects-table))
     761           1 :     (unless  (member key1 value)
     762           1 :       (puthash key (cons key1 value) dbus-registered-objects-table))
     763             : 
     764             :     ;; Return the object.
     765           1 :     (list key (list service path handler))))
     766             : 
     767             : (defun dbus-register-method
     768             :   (bus service path interface method handler &optional dont-register-service)
     769             :   "Register for method METHOD on the D-Bus BUS.
     770             : 
     771             : BUS is either a Lisp symbol, `:system' or `:session', or a string
     772             : denoting the bus address.
     773             : 
     774             : SERVICE is the D-Bus service name of the D-Bus object METHOD is
     775             : registered for.  It must be a known name (See discussion of
     776             : DONT-REGISTER-SERVICE below).
     777             : 
     778             : PATH is the D-Bus object path SERVICE is registered (See discussion of
     779             : DONT-REGISTER-SERVICE below).  INTERFACE is the interface offered by
     780             : SERVICE.  It must provide METHOD.
     781             : 
     782             : HANDLER is a Lisp function to be called when a method call is
     783             : received.  It must accept the input arguments of METHOD.  The return
     784             : value of HANDLER is used for composing the returning D-Bus message.
     785             : In case HANDLER shall return a reply message with an empty argument
     786             : list, HANDLER must return the symbol `:ignore'.
     787             : 
     788             : When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not
     789             : registered.  This means that other D-Bus clients have no way of
     790             : noticing the newly registered method.  When interfaces are constructed
     791             : incrementally by adding single methods or properties at a time,
     792             : DONT-REGISTER-SERVICE can be used to prevent other clients from
     793             : discovering the still incomplete interface."
     794             : 
     795             :   ;; Register SERVICE.
     796           0 :   (unless (or dont-register-service
     797           0 :               (member service (dbus-list-names bus)))
     798           0 :     (dbus-register-service bus service))
     799             : 
     800             :   ;; Create a hash table entry.  We use nil for the unique name,
     801             :   ;; because the method might be called from anybody.
     802           0 :   (let* ((key (list :method bus interface method))
     803           0 :          (key1 (list nil service path handler))
     804           0 :          (value (gethash key dbus-registered-objects-table)))
     805             : 
     806           0 :     (unless  (member key1 value)
     807           0 :       (puthash key (cons key1 value) dbus-registered-objects-table))
     808             : 
     809             :     ;; Return the object.
     810           0 :     (list key (list service path handler))))
     811             : 
     812             : (defun dbus-unregister-object (object)
     813             :   "Unregister OBJECT from D-Bus.
     814             : OBJECT must be the result of a preceding `dbus-register-method',
     815             : `dbus-register-property' or `dbus-register-signal' call.  It
     816             : returns t if OBJECT has been unregistered, nil otherwise.
     817             : 
     818             : When OBJECT identifies the last method or property, which is
     819             : registered for the respective service, Emacs releases its
     820             : association to the service from D-Bus."
     821             :   ;; Check parameter.
     822           0 :   (unless (and (consp object) (not (null (car object))) (consp (cdr object)))
     823           0 :     (signal 'wrong-type-argument (list 'D-Bus object)))
     824             : 
     825             :   ;; Find the corresponding entry in the hash table.
     826           0 :   (let* ((key (car object))
     827           0 :          (type (car key))
     828           0 :          (bus (cadr key))
     829           0 :          (value (cadr object))
     830           0 :          (service (car value))
     831           0 :          (entry (gethash key dbus-registered-objects-table))
     832             :          ret)
     833             :     ;; key has the structure (TYPE BUS INTERFACE MEMBER).
     834             :     ;; value has the structure (SERVICE PATH [HANDLER]).
     835             :     ;; entry has the structure ((UNAME SERVICE PATH MEMBER [RULE]) ...).
     836             :     ;; MEMBER is either a string (the handler), or a cons cell (a
     837             :     ;; property value).  UNAME and property values are not taken into
     838             :     ;; account for comparison.
     839             : 
     840             :     ;; Loop over the registered functions.
     841           0 :     (dolist (elt entry)
     842           0 :       (when (equal
     843           0 :              value
     844           0 :              (butlast (cdr elt) (- (length (cdr elt)) (length value))))
     845           0 :         (setq ret t)
     846             :         ;; Compute new hash value.  If it is empty, remove it from the
     847             :         ;; hash table.
     848           0 :         (unless (puthash key (delete elt entry) dbus-registered-objects-table)
     849           0 :           (remhash key dbus-registered-objects-table))
     850             :         ;; Remove match rule of signals.
     851           0 :         (when (eq type :signal)
     852           0 :           (dbus-call-method
     853           0 :            bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
     854           0 :            "RemoveMatch" (nth 4 elt)))))
     855             : 
     856             :     ;; Check, whether there is still a registered function or property
     857             :     ;; for the given service.  If not, unregister the service from the
     858             :     ;; bus.
     859           0 :     (when (and service (memq type '(:method :property))
     860           0 :                (not (catch :found
     861           0 :                       (progn
     862           0 :                         (maphash
     863             :                          (lambda (k v)
     864           0 :                            (dolist (e v)
     865           0 :                              (ignore-errors
     866           0 :                                (and
     867             :                                 ;; Bus.
     868           0 :                                 (equal bus (cadr k))
     869             :                                 ;; Service.
     870           0 :                                 (string-equal service (cadr e))
     871             :                                 ;; Non-empty object path.
     872           0 :                                 (nth 2 e)
     873           0 :                                 (throw :found t)))))
     874           0 :                          dbus-registered-objects-table)
     875           0 :                         nil))))
     876           0 :       (dbus-unregister-service bus service))
     877             :     ;; Return.
     878           0 :     ret))
     879             : 
     880             : 
     881             : ;;; D-Bus type conversion.
     882             : 
     883             : (defun dbus-string-to-byte-array (string)
     884             :   "Transforms STRING to list (:array :byte c1 :byte c2 ...).
     885             : STRING shall be UTF8 coded."
     886           0 :   (if (zerop (length string))
     887             :       '(:array :signature "y")
     888           0 :     (let (result)
     889           0 :       (dolist (elt (string-to-list string) (append '(:array) result))
     890           0 :         (setq result (append result (list :byte elt)))))))
     891             : 
     892             : (defun dbus-byte-array-to-string (byte-array &optional multibyte)
     893             :   "Transforms BYTE-ARRAY into UTF8 coded string.
     894             : BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte
     895             : array as produced by `dbus-string-to-byte-array'.  The resulting
     896             : string is unibyte encoded, unless MULTIBYTE is non-nil."
     897           0 :   (apply
     898           0 :    (if multibyte 'string 'unibyte-string)
     899           0 :    (if (equal byte-array '(:array :signature "y"))
     900             :        nil
     901           0 :      (let (result)
     902           0 :        (dolist (elt byte-array result)
     903           0 :          (when (characterp elt) (setq result (append result `(,elt)))))))))
     904             : 
     905             : (defun dbus-escape-as-identifier (string)
     906             :   "Escape an arbitrary STRING so it follows the rules for a C identifier.
     907             : The escaped string can be used as object path component, interface element
     908             : component, bus name component or member name in D-Bus.
     909             : 
     910             : The escaping consists of replacing all non-alphanumerics, and the
     911             : first character if it's a digit, with an underscore and two
     912             : lower-case hex digits:
     913             : 
     914             :    \"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\"
     915             : 
     916             : i.e. similar to URI encoding, but with \"_\" taking the role of \"%\",
     917             : and a smaller allowed set. As a special case, \"\" is escaped to
     918             : \"_\".
     919             : 
     920             : Returns the escaped string.  Algorithm taken from
     921             : telepathy-glib's `tp_escape_as_identifier'."
     922           0 :   (if (zerop (length string))
     923             :       "_"
     924           0 :     (replace-regexp-in-string
     925             :      "^[0-9]\\|[^A-Za-z0-9]"
     926           0 :      (lambda (x) (format "_%2x" (aref x 0)))
     927           0 :      string)))
     928             : 
     929             : (defun dbus-unescape-from-identifier (string)
     930             :   "Retrieve the original string from the encoded STRING as unibyte string.
     931             : STRING must have been encoded with `dbus-escape-as-identifier'."
     932           0 :   (if (string-equal string "_")
     933             :       ""
     934           0 :     (replace-regexp-in-string
     935             :      "_.."
     936           0 :      (lambda (x) (byte-to-string (string-to-number (substring x 1) 16)))
     937           0 :      string)))
     938             : 
     939             : 
     940             : ;;; D-Bus events.
     941             : 
     942             : (defun dbus-check-event (event)
     943             :   "Checks whether EVENT is a well formed D-Bus event.
     944             : EVENT is a list which starts with symbol `dbus-event':
     945             : 
     946             :   (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
     947             : 
     948             : BUS identifies the D-Bus the message is coming from.  It is
     949             : either a Lisp symbol, `:system' or `:session', or a string
     950             : denoting the bus address.  TYPE is the D-Bus message type which
     951             : has caused the event, SERIAL is the serial number of the received
     952             : D-Bus message.  SERVICE and PATH are the unique name and the
     953             : object path of the D-Bus object emitting the message.  INTERFACE
     954             : and MEMBER denote the message which has been sent.  HANDLER is
     955             : the function which has been registered for this message.  ARGS
     956             : are the arguments passed to HANDLER, when it is called during
     957             : event handling in `dbus-handle-event'.
     958             : 
     959             : This function raises a `dbus-error' signal in case the event is
     960             : not well formed."
     961           3 :   (when dbus-debug (message "DBus-Event %s" event))
     962           3 :   (unless (and (listp event)
     963           3 :                (eq (car event) 'dbus-event)
     964             :                ;; Bus symbol.
     965           3 :                (or (symbolp (nth 1 event))
     966           3 :                    (stringp (nth 1 event)))
     967             :                ;; Type.
     968           3 :                (and (natnump (nth 2 event))
     969           3 :                     (< dbus-message-type-invalid (nth 2 event)))
     970             :                ;; Serial.
     971           3 :                (natnump (nth 3 event))
     972             :                ;; Service.
     973           3 :                (or (= dbus-message-type-method-return (nth 2 event))
     974           0 :                    (= dbus-message-type-error (nth 2 event))
     975           0 :                    (or (stringp (nth 4 event))
     976           3 :                        (null (nth 4 event))))
     977             :                ;; Object path.
     978           3 :                (or (= dbus-message-type-method-return (nth 2 event))
     979           0 :                    (= dbus-message-type-error (nth 2 event))
     980           3 :                    (stringp (nth 5 event)))
     981             :                ;; Interface.
     982           3 :                (or (= dbus-message-type-method-return (nth 2 event))
     983           0 :                    (= dbus-message-type-error (nth 2 event))
     984           3 :                    (stringp (nth 6 event)))
     985             :                ;; Member.
     986           3 :                (or (= dbus-message-type-method-return (nth 2 event))
     987           0 :                    (= dbus-message-type-error (nth 2 event))
     988           3 :                    (stringp (nth 7 event)))
     989             :                ;; Handler.
     990           3 :                (functionp (nth 8 event)))
     991           3 :     (signal 'dbus-error (list "Not a valid D-Bus event" event))))
     992             : 
     993             : ;;;###autoload
     994             : (defun dbus-handle-event (event)
     995             :   "Handle events from the D-Bus.
     996             : EVENT is a D-Bus event, see `dbus-check-event'.  HANDLER, being
     997             : part of the event, is called with arguments ARGS.
     998             : If the HANDLER returns a `dbus-error', it is propagated as return message."
     999             :   (interactive "e")
    1000           1 :   (condition-case err
    1001           1 :       (let (result)
    1002             :         ;; We ignore not well-formed events.
    1003           1 :         (dbus-check-event event)
    1004             :         ;; Error messages must be propagated.
    1005           1 :         (when (= dbus-message-type-error (nth 2 event))
    1006           1 :           (signal 'dbus-error (nthcdr 9 event)))
    1007             :         ;; Apply the handler.
    1008           1 :         (setq result (apply (nth 8 event) (nthcdr 9 event)))
    1009             :         ;; Return a message when it is a message call.
    1010           1 :         (when (= dbus-message-type-method-call (nth 2 event))
    1011           0 :           (dbus-ignore-errors
    1012           0 :             (if (eq result :ignore)
    1013           0 :                 (dbus-method-return-internal
    1014           0 :                  (nth 1 event) (nth 4 event) (nth 3 event))
    1015           0 :               (apply 'dbus-method-return-internal
    1016           0 :                      (nth 1 event) (nth 4 event) (nth 3 event)
    1017           1 :                      (if (consp result) result (list result)))))))
    1018             :     ;; Error handling.
    1019             :     (dbus-error
    1020             :      ;; Return an error message when it is a message call.
    1021           0 :      (when (= dbus-message-type-method-call (nth 2 event))
    1022           0 :        (dbus-ignore-errors
    1023           0 :          (dbus-method-error-internal
    1024           0 :           (nth 1 event) (nth 4 event) (nth 3 event) (cadr err))))
    1025             :      ;; Propagate D-Bus error messages.
    1026           0 :      (run-hook-with-args 'dbus-event-error-functions event err)
    1027           0 :      (when dbus-debug
    1028           1 :        (signal (car err) (cdr err))))))
    1029             : 
    1030             : (defun dbus-event-bus-name (event)
    1031             :   "Return the bus name the event is coming from.
    1032             : The result is either a Lisp symbol, `:system' or `:session', or a
    1033             : string denoting the bus address.  EVENT is a D-Bus event, see
    1034             : `dbus-check-event'.  This function raises a `dbus-error' signal
    1035             : in case the event is not well formed."
    1036           1 :   (dbus-check-event event)
    1037           1 :   (nth 1 event))
    1038             : 
    1039             : (defun dbus-event-message-type (event)
    1040             :   "Return the message type of the corresponding D-Bus message.
    1041             : The result is a number.  EVENT is a D-Bus event, see
    1042             : `dbus-check-event'.  This function raises a `dbus-error' signal
    1043             : in case the event is not well formed."
    1044           0 :   (dbus-check-event event)
    1045           0 :   (nth 2 event))
    1046             : 
    1047             : (defun dbus-event-serial-number (event)
    1048             :   "Return the serial number of the corresponding D-Bus message.
    1049             : The result is a number.  The serial number is needed for
    1050             : generating a reply message.  EVENT is a D-Bus event, see
    1051             : `dbus-check-event'.  This function raises a `dbus-error' signal
    1052             : in case the event is not well formed."
    1053           1 :   (dbus-check-event event)
    1054           1 :   (nth 3 event))
    1055             : 
    1056             : (defun dbus-event-service-name (event)
    1057             :   "Return the name of the D-Bus object the event is coming from.
    1058             : The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
    1059             : This function raises a `dbus-error' signal in case the event is
    1060             : not well formed."
    1061           0 :   (dbus-check-event event)
    1062           0 :   (nth 4 event))
    1063             : 
    1064             : (defun dbus-event-path-name (event)
    1065             :   "Return the object path of the D-Bus object the event is coming from.
    1066             : The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
    1067             : This function raises a `dbus-error' signal in case the event is
    1068             : not well formed."
    1069           0 :   (dbus-check-event event)
    1070           0 :   (nth 5 event))
    1071             : 
    1072             : (defun dbus-event-interface-name (event)
    1073             :   "Return the interface name of the D-Bus object the event is coming from.
    1074             : The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
    1075             : This function raises a `dbus-error' signal in case the event is
    1076             : not well formed."
    1077           0 :   (dbus-check-event event)
    1078           0 :   (nth 6 event))
    1079             : 
    1080             : (defun dbus-event-member-name (event)
    1081             :   "Return the member name the event is coming from.
    1082             : It is either a signal name or a method name. The result is a
    1083             : string.  EVENT is a D-Bus event, see `dbus-check-event'.  This
    1084             : function raises a `dbus-error' signal in case the event is not
    1085             : well formed."
    1086           0 :   (dbus-check-event event)
    1087           0 :   (nth 7 event))
    1088             : 
    1089             : 
    1090             : ;;; D-Bus registered names.
    1091             : 
    1092             : (defun dbus-list-activatable-names (&optional bus)
    1093             :   "Return the D-Bus service names which can be activated as list.
    1094             : If BUS is left nil, `:system' is assumed.  The result is a list
    1095             : of strings, which is nil when there are no activatable service
    1096             : names at all."
    1097           0 :   (dbus-ignore-errors
    1098           0 :     (dbus-call-method
    1099           0 :      (or bus :system) dbus-service-dbus
    1100           0 :      dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
    1101             : 
    1102             : (defun dbus-list-names (bus)
    1103             :   "Return the service names registered at D-Bus BUS.
    1104             : The result is a list of strings, which is nil when there are no
    1105             : registered service names at all.  Well known names are strings
    1106             : like \"org.freedesktop.DBus\".  Names starting with \":\" are
    1107             : unique names for services."
    1108           0 :   (dbus-ignore-errors
    1109           0 :     (dbus-call-method
    1110           0 :      bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
    1111             : 
    1112             : (defun dbus-list-known-names (bus)
    1113             :   "Retrieve all services which correspond to a known name in BUS.
    1114             : A service has a known name if it doesn't start with \":\"."
    1115           0 :   (let (result)
    1116           0 :     (dolist (name (dbus-list-names bus) (nreverse result))
    1117           0 :       (unless (string-equal ":" (substring name 0 1))
    1118           0 :         (push name result)))))
    1119             : 
    1120             : (defun dbus-list-queued-owners (bus service)
    1121             :   "Return the unique names registered at D-Bus BUS and queued for SERVICE.
    1122             : The result is a list of strings, or nil when there are no
    1123             : queued name owners service names at all."
    1124           0 :   (dbus-ignore-errors
    1125           0 :     (dbus-call-method
    1126           0 :      bus dbus-service-dbus dbus-path-dbus
    1127           0 :      dbus-interface-dbus "ListQueuedOwners" service)))
    1128             : 
    1129             : (defun dbus-get-name-owner (bus service)
    1130             :   "Return the name owner of SERVICE registered at D-Bus BUS.
    1131             : The result is either a string, or nil if there is no name owner."
    1132           0 :   (dbus-ignore-errors
    1133           0 :     (dbus-call-method
    1134           0 :      bus dbus-service-dbus dbus-path-dbus
    1135           0 :      dbus-interface-dbus "GetNameOwner" service)))
    1136             : 
    1137             : (defun dbus-ping (bus service &optional timeout)
    1138             :   "Check whether SERVICE is registered for D-Bus BUS.
    1139             : TIMEOUT, a nonnegative integer, specifies the maximum number of
    1140             : milliseconds `dbus-ping' must return.  The default value is 25,000.
    1141             : 
    1142             : Note, that this autoloads SERVICE if it is not running yet.  If
    1143             : it shall be checked whether SERVICE is already running, one shall
    1144             : apply
    1145             : 
    1146             :   (member service \(dbus-list-known-names bus))"
    1147             :   ;; "Ping" raises a D-Bus error if SERVICE does not exist.
    1148             :   ;; Otherwise, it returns silently with nil.
    1149           0 :   (condition-case nil
    1150           0 :       (not
    1151           0 :        (if (natnump timeout)
    1152           0 :            (dbus-call-method
    1153           0 :             bus service dbus-path-dbus dbus-interface-peer
    1154           0 :             "Ping" :timeout timeout)
    1155           0 :          (dbus-call-method
    1156           0 :           bus service dbus-path-dbus dbus-interface-peer "Ping")))
    1157           0 :     (dbus-error nil)))
    1158             : 
    1159             : (defun dbus-peer-handler ()
    1160             :   "Default handler for the \"org.freedesktop.DBus.Peer\" interface.
    1161             : It will be registered for all objects created by `dbus-register-service'."
    1162           0 :   (let* ((last-input-event last-input-event)
    1163           0 :          (method (dbus-event-member-name last-input-event)))
    1164           0 :     (cond
    1165             :      ;; "Ping" does not return an output parameter.
    1166           0 :      ((string-equal method "Ping")
    1167             :       :ignore)
    1168             :      ;; "GetMachineId" returns "s".
    1169           0 :      ((string-equal method "GetMachineId")
    1170           0 :       (signal
    1171             :        'dbus-error
    1172           0 :        (list
    1173           0 :         (format "%s.GetMachineId not implemented" dbus-interface-peer)))))))
    1174             : 
    1175             : 
    1176             : ;;; D-Bus introspection.
    1177             : 
    1178             : (defun dbus-introspect (bus service path)
    1179             :   "Return all interfaces and sub-nodes of SERVICE,
    1180             : registered at object path PATH at bus BUS.
    1181             : 
    1182             : BUS is either a Lisp symbol, `:system' or `:session', or a string
    1183             : denoting the bus address.  SERVICE must be a known service name,
    1184             : and PATH must be a valid object path.  The last two parameters
    1185             : are strings.  The result, the introspection data, is a string in
    1186             : XML format."
    1187             :   ;; We don't want to raise errors.
    1188           0 :   (dbus-ignore-errors
    1189           0 :     (dbus-call-method
    1190           0 :      bus service path dbus-interface-introspectable "Introspect"
    1191           0 :      :timeout 1000)))
    1192             : 
    1193             : (defun dbus-introspect-xml (bus service path)
    1194             :   "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
    1195             : The data are a parsed list.  The root object is a \"node\",
    1196             : representing the object path PATH.  The root object can contain
    1197             : \"interface\" and further \"node\" objects."
    1198             :   ;; We don't want to raise errors.
    1199           0 :   (xml-node-name
    1200           0 :    (ignore-errors
    1201           0 :      (with-temp-buffer
    1202           0 :        (insert (dbus-introspect bus service path))
    1203           0 :        (xml-parse-region (point-min) (point-max))))))
    1204             : 
    1205             : (defun dbus-introspect-get-attribute (object attribute)
    1206             :   "Return the ATTRIBUTE value of D-Bus introspection OBJECT.
    1207             : ATTRIBUTE must be a string according to the attribute names in
    1208             : the D-Bus specification."
    1209           0 :   (xml-get-attribute-or-nil object (intern attribute)))
    1210             : 
    1211             : (defun dbus-introspect-get-node-names (bus service path)
    1212             :   "Return all node names of SERVICE in D-Bus BUS at object path PATH.
    1213             : It returns a list of strings.  The node names stand for further
    1214             : object paths of the D-Bus service."
    1215           0 :   (let ((object (dbus-introspect-xml bus service path))
    1216             :         result)
    1217           0 :     (dolist (elt (xml-get-children object 'node) (nreverse result))
    1218           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1219             : 
    1220             : (defun dbus-introspect-get-all-nodes (bus service path)
    1221             :   "Return all node names of SERVICE in D-Bus BUS at object path PATH.
    1222             : It returns a list of strings, which are further object paths of SERVICE."
    1223           0 :   (let ((result (list path)))
    1224           0 :     (dolist (elt
    1225           0 :              (dbus-introspect-get-node-names bus service path)
    1226           0 :              result)
    1227           0 :       (setq elt (expand-file-name elt path))
    1228           0 :       (setq result
    1229           0 :             (append result (dbus-introspect-get-all-nodes bus service elt))))))
    1230             : 
    1231             : (defun dbus-introspect-get-interface-names (bus service path)
    1232             :   "Return all interface names of SERVICE in D-Bus BUS at object path PATH.
    1233             : It returns a list of strings.
    1234             : 
    1235             : There will be always the default interface
    1236             : \"org.freedesktop.DBus.Introspectable\".  Another default
    1237             : interface is \"org.freedesktop.DBus.Properties\".  If present,
    1238             : \"interface\" objects can also have \"property\" objects as
    1239             : children, beside \"method\" and \"signal\" objects."
    1240           0 :   (let ((object (dbus-introspect-xml bus service path))
    1241             :         result)
    1242           0 :     (dolist (elt (xml-get-children object 'interface) (nreverse result))
    1243           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1244             : 
    1245             : (defun dbus-introspect-get-interface (bus service path interface)
    1246             :   "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH.
    1247             : The return value is an XML object.  INTERFACE must be a string,
    1248             : element of the list returned by `dbus-introspect-get-interface-names'.
    1249             : The resulting \"interface\" object can contain \"method\", \"signal\",
    1250             : \"property\" and \"annotation\" children."
    1251           0 :   (let ((elt (xml-get-children
    1252           0 :               (dbus-introspect-xml bus service path) 'interface)))
    1253           0 :     (while (and elt
    1254           0 :                 (not (string-equal
    1255           0 :                       interface
    1256           0 :                       (dbus-introspect-get-attribute (car elt) "name"))))
    1257           0 :       (setq elt (cdr elt)))
    1258           0 :     (car elt)))
    1259             : 
    1260             : (defun dbus-introspect-get-method-names (bus service path interface)
    1261             :   "Return a list of strings of all method names of INTERFACE.
    1262             : SERVICE is a service of D-Bus BUS at object path PATH."
    1263           0 :   (let ((object (dbus-introspect-get-interface bus service path interface))
    1264             :         result)
    1265           0 :     (dolist (elt (xml-get-children object 'method) (nreverse result))
    1266           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1267             : 
    1268             : (defun dbus-introspect-get-method (bus service path interface method)
    1269             :   "Return method METHOD of interface INTERFACE as XML object.
    1270             : It must be located at SERVICE in D-Bus BUS at object path PATH.
    1271             : METHOD must be a string, element of the list returned by
    1272             : `dbus-introspect-get-method-names'.  The resulting \"method\"
    1273             : object can contain \"arg\" and \"annotation\" children."
    1274           0 :   (let ((elt (xml-get-children
    1275           0 :               (dbus-introspect-get-interface bus service path interface)
    1276           0 :               'method)))
    1277           0 :     (while (and elt
    1278           0 :                 (not (string-equal
    1279           0 :                       method (dbus-introspect-get-attribute (car elt) "name"))))
    1280           0 :       (setq elt (cdr elt)))
    1281           0 :     (car elt)))
    1282             : 
    1283             : (defun dbus-introspect-get-signal-names (bus service path interface)
    1284             :   "Return a list of strings of all signal names of INTERFACE.
    1285             : SERVICE is a service of D-Bus BUS at object path PATH."
    1286           0 :   (let ((object (dbus-introspect-get-interface bus service path interface))
    1287             :         result)
    1288           0 :     (dolist (elt (xml-get-children object 'signal) (nreverse result))
    1289           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1290             : 
    1291             : (defun dbus-introspect-get-signal (bus service path interface signal)
    1292             :   "Return signal SIGNAL of interface INTERFACE as XML object.
    1293             : It must be located at SERVICE in D-Bus BUS at object path PATH.
    1294             : SIGNAL must be a string, element of the list returned by
    1295             : `dbus-introspect-get-signal-names'.  The resulting \"signal\"
    1296             : object can contain \"arg\" and \"annotation\" children."
    1297           0 :   (let ((elt (xml-get-children
    1298           0 :               (dbus-introspect-get-interface bus service path interface)
    1299           0 :               'signal)))
    1300           0 :     (while (and elt
    1301           0 :                 (not (string-equal
    1302           0 :                       signal (dbus-introspect-get-attribute (car elt) "name"))))
    1303           0 :       (setq elt (cdr elt)))
    1304           0 :     (car elt)))
    1305             : 
    1306             : (defun dbus-introspect-get-property-names (bus service path interface)
    1307             :   "Return a list of strings of all property names of INTERFACE.
    1308             : SERVICE is a service of D-Bus BUS at object path PATH."
    1309           0 :   (let ((object (dbus-introspect-get-interface bus service path interface))
    1310             :         result)
    1311           0 :     (dolist (elt (xml-get-children object 'property) (nreverse result))
    1312           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1313             : 
    1314             : (defun dbus-introspect-get-property (bus service path interface property)
    1315             :   "This function returns PROPERTY of INTERFACE as XML object.
    1316             : It must be located at SERVICE in D-Bus BUS at object path PATH.
    1317             : PROPERTY must be a string, element of the list returned by
    1318             : `dbus-introspect-get-property-names'.  The resulting PROPERTY
    1319             : object can contain \"annotation\" children."
    1320           0 :   (let ((elt (xml-get-children
    1321           0 :               (dbus-introspect-get-interface bus service path interface)
    1322           0 :               'property)))
    1323           0 :     (while (and elt
    1324           0 :                 (not (string-equal
    1325           0 :                       property
    1326           0 :                       (dbus-introspect-get-attribute (car elt) "name"))))
    1327           0 :       (setq elt (cdr elt)))
    1328           0 :     (car elt)))
    1329             : 
    1330             : (defun dbus-introspect-get-annotation-names
    1331             :   (bus service path interface &optional name)
    1332             :   "Return all annotation names as list of strings.
    1333             : If NAME is nil, the annotations are children of INTERFACE,
    1334             : otherwise NAME must be a \"method\", \"signal\", or \"property\"
    1335             : object, where the annotations belong to."
    1336           0 :   (let ((object
    1337           0 :          (if name
    1338           0 :              (or (dbus-introspect-get-method bus service path interface name)
    1339           0 :                  (dbus-introspect-get-signal bus service path interface name)
    1340           0 :                  (dbus-introspect-get-property bus service path interface name))
    1341           0 :            (dbus-introspect-get-interface bus service path interface)))
    1342             :         result)
    1343           0 :     (dolist (elt (xml-get-children object 'annotation) (nreverse result))
    1344           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1345             : 
    1346             : (defun dbus-introspect-get-annotation
    1347             :   (bus service path interface name annotation)
    1348             :   "Return ANNOTATION as XML object.
    1349             : If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise
    1350             : NAME must be the name of a \"method\", \"signal\", or
    1351             : \"property\" object, where the ANNOTATION belongs to."
    1352           0 :   (let ((elt (xml-get-children
    1353           0 :               (if name
    1354           0 :                   (or (dbus-introspect-get-method
    1355           0 :                        bus service path interface name)
    1356           0 :                       (dbus-introspect-get-signal
    1357           0 :                        bus service path interface name)
    1358           0 :                       (dbus-introspect-get-property
    1359           0 :                        bus service path interface name))
    1360           0 :                 (dbus-introspect-get-interface bus service path interface))
    1361           0 :               'annotation)))
    1362           0 :     (while (and elt
    1363           0 :                 (not (string-equal
    1364           0 :                       annotation
    1365           0 :                       (dbus-introspect-get-attribute (car elt) "name"))))
    1366           0 :       (setq elt (cdr elt)))
    1367           0 :     (car elt)))
    1368             : 
    1369             : (defun dbus-introspect-get-argument-names (bus service path interface name)
    1370             :   "Return a list of all argument names as list of strings.
    1371             : NAME must be a \"method\" or \"signal\" object.
    1372             : 
    1373             : Argument names are optional, the function can return nil
    1374             : therefore, even if the method or signal has arguments."
    1375           0 :   (let ((object
    1376           0 :          (or (dbus-introspect-get-method bus service path interface name)
    1377           0 :              (dbus-introspect-get-signal bus service path interface name)))
    1378             :         result)
    1379           0 :     (dolist (elt (xml-get-children object 'arg) (nreverse result))
    1380           0 :       (push (dbus-introspect-get-attribute elt "name") result))))
    1381             : 
    1382             : (defun dbus-introspect-get-argument (bus service path interface name arg)
    1383             :   "Return argument ARG as XML object.
    1384             : NAME must be a \"method\" or \"signal\" object.  ARG must be a string,
    1385             : element of the list returned by `dbus-introspect-get-argument-names'."
    1386           0 :   (let ((elt (xml-get-children
    1387           0 :               (or (dbus-introspect-get-method bus service path interface name)
    1388           0 :                   (dbus-introspect-get-signal bus service path interface name))
    1389           0 :               'arg)))
    1390           0 :     (while (and elt
    1391           0 :                 (not (string-equal
    1392           0 :                       arg (dbus-introspect-get-attribute (car elt) "name"))))
    1393           0 :       (setq elt (cdr elt)))
    1394           0 :     (car elt)))
    1395             : 
    1396             : (defun dbus-introspect-get-signature
    1397             :   (bus service path interface name &optional direction)
    1398             :   "Return signature of a `method' or `signal', represented by NAME, as string.
    1399             : If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
    1400             : If DIRECTION is nil, \"in\" is assumed.
    1401             : 
    1402             : If NAME is a `signal', and DIRECTION is non-nil, DIRECTION must
    1403             : be \"out\"."
    1404             :   ;; For methods, we use "in" as default direction.
    1405           0 :   (let ((object (or (dbus-introspect-get-method
    1406           0 :                      bus service path interface name)
    1407           0 :                     (dbus-introspect-get-signal
    1408           0 :                      bus service path interface name))))
    1409           0 :     (when (and (string-equal
    1410           0 :                 "method" (dbus-introspect-get-attribute object "name"))
    1411           0 :                (not (stringp direction)))
    1412           0 :       (setq direction "in"))
    1413             :     ;; In signals, no direction is given.
    1414           0 :     (when (string-equal "signal" (dbus-introspect-get-attribute object "name"))
    1415           0 :       (setq direction nil))
    1416             :     ;; Collect the signatures.
    1417           0 :     (mapconcat
    1418             :      (lambda (x)
    1419           0 :        (let ((arg (dbus-introspect-get-argument
    1420           0 :                    bus service path interface name x)))
    1421           0 :          (if (or (not (stringp direction))
    1422           0 :                  (string-equal
    1423           0 :                   direction
    1424           0 :                   (dbus-introspect-get-attribute arg "direction")))
    1425           0 :              (dbus-introspect-get-attribute arg "type")
    1426           0 :            "")))
    1427           0 :      (dbus-introspect-get-argument-names bus service path interface name)
    1428           0 :      "")))
    1429             : 
    1430             : 
    1431             : ;;; D-Bus properties.
    1432             : 
    1433             : (defun dbus-get-property (bus service path interface property)
    1434             :   "Return the value of PROPERTY of INTERFACE.
    1435             : It will be checked at BUS, SERVICE, PATH.  The result can be any
    1436             : valid D-Bus value, or nil if there is no PROPERTY."
    1437           0 :   (dbus-ignore-errors
    1438             :    ;; "Get" returns a variant, so we must use the `car'.
    1439           0 :    (car
    1440           0 :     (dbus-call-method
    1441           0 :      bus service path dbus-interface-properties
    1442           0 :      "Get" :timeout 500 interface property))))
    1443             : 
    1444             : (defun dbus-set-property (bus service path interface property value)
    1445             :   "Set value of PROPERTY of INTERFACE to VALUE.
    1446             : It will be checked at BUS, SERVICE, PATH.  When the value has
    1447             : been set successful, the result is VALUE.  Otherwise, nil is
    1448             : returned."
    1449           0 :   (dbus-ignore-errors
    1450             :    ;; "Set" requires a variant.
    1451           0 :    (dbus-call-method
    1452           0 :     bus service path dbus-interface-properties
    1453           0 :     "Set" :timeout 500 interface property (list :variant value))
    1454             :    ;; Return VALUE.
    1455           0 :    (dbus-get-property bus service path interface property)))
    1456             : 
    1457             : (defun dbus-get-all-properties (bus service path interface)
    1458             :   "Return all properties of INTERFACE at BUS, SERVICE, PATH.
    1459             : The result is a list of entries.  Every entry is a cons of the
    1460             : name of the property, and its value.  If there are no properties,
    1461             : nil is returned."
    1462           0 :   (dbus-ignore-errors
    1463             :     ;; "GetAll" returns "a{sv}".
    1464           0 :     (let (result)
    1465           0 :       (dolist (dict
    1466           0 :                (dbus-call-method
    1467           0 :                 bus service path dbus-interface-properties
    1468           0 :                 "GetAll" :timeout 500 interface)
    1469           0 :                (nreverse result))
    1470           0 :         (push (cons (car dict) (cl-caadr dict)) result)))))
    1471             : 
    1472             : (defun dbus-register-property
    1473             :   (bus service path interface property access value
    1474             :    &optional emits-signal dont-register-service)
    1475             :   "Register property PROPERTY on the D-Bus BUS.
    1476             : 
    1477             : BUS is either a Lisp symbol, `:system' or `:session', or a string
    1478             : denoting the bus address.
    1479             : 
    1480             : SERVICE is the D-Bus service name of the D-Bus.  It must be a
    1481             : known name (See discussion of DONT-REGISTER-SERVICE below).
    1482             : 
    1483             : PATH is the D-Bus object path SERVICE is registered (See
    1484             : discussion of DONT-REGISTER-SERVICE below).  INTERFACE is the
    1485             : name of the interface used at PATH, PROPERTY is the name of the
    1486             : property of INTERFACE.  ACCESS indicates, whether the property
    1487             : can be changed by other services via D-Bus.  It must be either
    1488             : the symbol `:read' or `:readwrite'.  VALUE is the initial value
    1489             : of the property, it can be of any valid type (see
    1490             : `dbus-call-method' for details).
    1491             : 
    1492             : If PROPERTY already exists on PATH, it will be overwritten.  For
    1493             : properties with access type `:read' this is the only way to
    1494             : change their values.  Properties with access type `:readwrite'
    1495             : can be changed by `dbus-set-property'.
    1496             : 
    1497             : The interface \"org.freedesktop.DBus.Properties\" is added to
    1498             : PATH, including a default handler for the \"Get\", \"GetAll\" and
    1499             : \"Set\" methods of this interface.  When EMITS-SIGNAL is non-nil,
    1500             : the signal \"PropertiesChanged\" is sent when the property is
    1501             : changed by `dbus-set-property'.
    1502             : 
    1503             : When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is
    1504             : not registered.  This means that other D-Bus clients have no way
    1505             : of noticing the newly registered property.  When interfaces are
    1506             : constructed incrementally by adding single methods or properties
    1507             : at a time, DONT-REGISTER-SERVICE can be used to prevent other
    1508             : clients from discovering the still incomplete interface."
    1509           0 :   (unless (member access '(:read :readwrite))
    1510           0 :     (signal 'wrong-type-argument (list "Access type invalid" access)))
    1511             : 
    1512             :   ;; Add handlers for the three property-related methods.
    1513           0 :   (dbus-register-method
    1514           0 :    bus service path dbus-interface-properties "Get"
    1515           0 :    'dbus-property-handler 'dont-register)
    1516           0 :   (dbus-register-method
    1517           0 :    bus service path dbus-interface-properties "GetAll"
    1518           0 :    'dbus-property-handler 'dont-register)
    1519           0 :   (dbus-register-method
    1520           0 :    bus service path dbus-interface-properties "Set"
    1521           0 :    'dbus-property-handler 'dont-register)
    1522             : 
    1523             :   ;; Register SERVICE.
    1524           0 :   (unless (or dont-register-service (member service (dbus-list-names bus)))
    1525           0 :     (dbus-register-service bus service))
    1526             : 
    1527             :   ;; Send the PropertiesChanged signal.
    1528           0 :   (when emits-signal
    1529           0 :     (dbus-send-signal
    1530           0 :      bus service path dbus-interface-properties "PropertiesChanged"
    1531           0 :      `((:dict-entry ,property (:variant ,value)))
    1532           0 :      '(:array)))
    1533             : 
    1534             :   ;; Create a hash table entry.  We use nil for the unique name,
    1535             :   ;; because the property might be accessed from anybody.
    1536           0 :   (let ((key (list :property bus interface property))
    1537             :         (val
    1538           0 :          (list
    1539           0 :           (list
    1540           0 :            nil service path
    1541           0 :            (cons
    1542           0 :             (if emits-signal (list access :emits-signal) (list access))
    1543           0 :             value)))))
    1544           0 :     (puthash key val dbus-registered-objects-table)
    1545             : 
    1546             :     ;; Return the object.
    1547           0 :     (list key (list service path))))
    1548             : 
    1549             : (defun dbus-property-handler (&rest args)
    1550             :   "Default handler for the \"org.freedesktop.DBus.Properties\" interface.
    1551             : It will be registered for all objects created by `dbus-register-property'."
    1552           0 :   (let ((bus (dbus-event-bus-name last-input-event))
    1553           0 :         (service (dbus-event-service-name last-input-event))
    1554           0 :         (path (dbus-event-path-name last-input-event))
    1555           0 :         (method (dbus-event-member-name last-input-event))
    1556           0 :         (interface (car args))
    1557           0 :         (property (cadr args)))
    1558           0 :     (cond
    1559             :      ;; "Get" returns a variant.
    1560           0 :      ((string-equal method "Get")
    1561           0 :       (let ((entry (gethash (list :property bus interface property)
    1562           0 :                             dbus-registered-objects-table)))
    1563           0 :         (when (string-equal path (nth 2 (car entry)))
    1564           0 :           `((:variant ,(cdar (last (car entry))))))))
    1565             : 
    1566             :      ;; "Set" expects a variant.
    1567           0 :      ((string-equal method "Set")
    1568           0 :       (let* ((value (caar (cddr args)))
    1569           0 :              (entry (gethash (list :property bus interface property)
    1570           0 :                              dbus-registered-objects-table))
    1571             :              ;; The value of the hash table is a list; in case of
    1572             :              ;; properties it contains just one element (UNAME SERVICE
    1573             :              ;; PATH OBJECT).  OBJECT is a cons cell of a list, which
    1574             :              ;; contains a list of annotations (like :read,
    1575             :              ;; :read-write, :emits-signal), and the value of the
    1576             :              ;; property.
    1577           0 :              (object (car (last (car entry)))))
    1578           0 :         (unless (consp object)
    1579           0 :           (signal 'dbus-error
    1580           0 :                   (list "Property not registered at path" property path)))
    1581           0 :         (unless (member :readwrite (car object))
    1582           0 :           (signal 'dbus-error
    1583           0 :                   (list "Property not writable at path" property path)))
    1584           0 :         (puthash (list :property bus interface property)
    1585           0 :                  (list (append (butlast (car entry))
    1586           0 :                                (list (cons (car object) value))))
    1587           0 :                  dbus-registered-objects-table)
    1588             :         ;; Send the "PropertiesChanged" signal.
    1589           0 :         (when (member :emits-signal (car object))
    1590           0 :           (dbus-send-signal
    1591           0 :            bus service path dbus-interface-properties "PropertiesChanged"
    1592           0 :            `((:dict-entry ,property (:variant ,value)))
    1593           0 :            '(:array)))
    1594             :         ;; Return empty reply.
    1595           0 :         :ignore))
    1596             : 
    1597             :      ;; "GetAll" returns "a{sv}".
    1598           0 :      ((string-equal method "GetAll")
    1599           0 :       (let (result)
    1600           0 :         (maphash
    1601             :          (lambda (key val)
    1602           0 :            (when (and (equal (butlast key) (list :property bus interface))
    1603           0 :                       (string-equal path (nth 2 (car val)))
    1604           0 :                       (not (functionp (car (last (car val))))))
    1605           0 :              (push
    1606           0 :               (list :dict-entry
    1607           0 :                     (car (last key))
    1608           0 :                     (list :variant (cdar (last (car val)))))
    1609           0 :               result)))
    1610           0 :          dbus-registered-objects-table)
    1611             :         ;; Return the result, or an empty array.
    1612           0 :         (list :array (or result '(:signature "{sv}"))))))))
    1613             : 
    1614             : 
    1615             : ;;; D-Bus object manager.
    1616             : 
    1617             : (defun dbus-get-all-managed-objects (bus service path)
    1618             :   "Return all objects at BUS, SERVICE, PATH, and the children of PATH.
    1619             : The result is a list of objects.  Every object is a cons of an
    1620             : existing path name, and the list of available interface objects.
    1621             : An interface object is another cons, which car is the interface
    1622             : name, and the cdr is the list of properties as returned by
    1623             : `dbus-get-all-properties' for that path and interface.  Example:
    1624             : 
    1625             : \(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\")
    1626             : 
    1627             :   => ((\"/org/gnome/SettingsDaemon/MediaKeys\"
    1628             :        (\"org.gnome.SettingsDaemon.MediaKeys\")
    1629             :        (\"org.freedesktop.DBus.Peer\")
    1630             :        (\"org.freedesktop.DBus.Introspectable\")
    1631             :        (\"org.freedesktop.DBus.Properties\")
    1632             :        (\"org.freedesktop.DBus.ObjectManager\"))
    1633             :       (\"/org/gnome/SettingsDaemon/Power\"
    1634             :        (\"org.gnome.SettingsDaemon.Power.Keyboard\")
    1635             :        (\"org.gnome.SettingsDaemon.Power.Screen\")
    1636             :        (\"org.gnome.SettingsDaemon.Power\"
    1637             :         (\"Icon\" . \". GThemedIcon battery-full-charged-symbolic \")
    1638             :         (\"Tooltip\" . \"Laptop battery is charged\"))
    1639             :        (\"org.freedesktop.DBus.Peer\")
    1640             :        (\"org.freedesktop.DBus.Introspectable\")
    1641             :        (\"org.freedesktop.DBus.Properties\")
    1642             :        (\"org.freedesktop.DBus.ObjectManager\"))
    1643             :       ...)
    1644             : 
    1645             : If possible, \"org.freedesktop.DBus.ObjectManager.GetManagedObjects\"
    1646             : is used for retrieving the information.  Otherwise, the information
    1647             : is collected via \"org.freedesktop.DBus.Introspectable.Introspect\"
    1648             : and \"org.freedesktop.DBus.Properties.GetAll\", which is slow."
    1649           0 :     (let ((result
    1650             :            ;; Direct call.  Fails, if the target does not support the
    1651             :            ;; object manager interface.
    1652           0 :            (dbus-ignore-errors
    1653           0 :             (dbus-call-method
    1654           0 :              bus service path dbus-interface-objectmanager
    1655           0 :              "GetManagedObjects" :timeout 1000))))
    1656             : 
    1657           0 :       (if result
    1658             :           ;; Massage the returned structure.
    1659           0 :           (dolist (entry result result)
    1660             :             ;; "a{oa{sa{sv}}}".
    1661           0 :             (dolist (entry1 (cdr entry))
    1662             :               ;; "a{sa{sv}}".
    1663           0 :               (dolist (entry2 entry1)
    1664             :                 ;; "a{sv}".
    1665           0 :                 (if (cadr entry2)
    1666             :                     ;; "sv".
    1667           0 :                     (dolist (entry3 (cadr entry2))
    1668           0 :                       (setcdr entry3 (cl-caadr entry3)))
    1669           0 :                   (setcdr entry2 nil)))))
    1670             : 
    1671             :         ;; Fallback: collect the information.  Slooow!
    1672           0 :         (dolist (object
    1673           0 :                  (dbus-introspect-get-all-nodes bus service path)
    1674           0 :                  result)
    1675           0 :           (let (result1)
    1676           0 :             (dolist
    1677             :                 (interface
    1678           0 :                  (dbus-introspect-get-interface-names bus service object)
    1679           0 :                  result1)
    1680           0 :               (push
    1681           0 :                (cons interface
    1682           0 :                      (dbus-get-all-properties bus service object interface))
    1683           0 :                result1))
    1684           0 :             (when result1
    1685           0 :               (push (cons object result1) result)))))))
    1686             : 
    1687             : (defun dbus-managed-objects-handler ()
    1688             :   "Default handler for the \"org.freedesktop.DBus.ObjectManager\" interface.
    1689             : It will be registered for all objects created by `dbus-register-service'."
    1690           0 :   (let* ((last-input-event last-input-event)
    1691           0 :          (bus (dbus-event-bus-name last-input-event))
    1692           0 :          (path (dbus-event-path-name last-input-event)))
    1693             :     ;; "GetManagedObjects" returns "a{oa{sa{sv}}}".
    1694           0 :     (let (interfaces result)
    1695             : 
    1696             :       ;; Check for object path wildcard interfaces.
    1697           0 :       (maphash
    1698             :        (lambda (key val)
    1699           0 :          (when (and (equal (butlast key 2) (list :method bus))
    1700           0 :                     (null (nth 2 (car-safe val))))
    1701           0 :            (push (nth 2 key) interfaces)))
    1702           0 :        dbus-registered-objects-table)
    1703             : 
    1704             :       ;; Check all registered object paths.
    1705           0 :       (maphash
    1706             :        (lambda (key val)
    1707           0 :          (let ((object (or (nth 2 (car-safe val)) "")))
    1708           0 :            (when (and (equal (butlast key 2) (list :method bus))
    1709           0 :                       (string-prefix-p path object))
    1710           0 :              (dolist (interface (cons (nth 2 key) interfaces))
    1711           0 :                (unless (assoc object result)
    1712           0 :                  (push (list object) result))
    1713           0 :                (unless (assoc interface (cdr (assoc object result)))
    1714           0 :                  (setcdr
    1715           0 :                   (assoc object result)
    1716           0 :                   (append
    1717           0 :                    (list (cons
    1718           0 :                     interface
    1719             :                     ;; We simulate "org.freedesktop.DBus.Properties.GetAll"
    1720             :                     ;; by using an appropriate D-Bus event.
    1721           0 :                     (let ((last-input-event
    1722           0 :                            (append
    1723           0 :                             (butlast last-input-event 4)
    1724           0 :                             (list object dbus-interface-properties
    1725           0 :                                   "GetAll" 'dbus-property-handler))))
    1726           0 :                       (dbus-property-handler interface))))
    1727           0 :                    (cdr (assoc object result)))))))))
    1728           0 :        dbus-registered-objects-table)
    1729             : 
    1730             :       ;; Return the result, or an empty array.
    1731           0 :       (list
    1732             :        :array
    1733           0 :        (or
    1734           0 :         (mapcar
    1735             :          (lambda (x)
    1736           0 :            (list
    1737           0 :             :dict-entry :object-path (car x)
    1738           0 :             (cons :array (mapcar (lambda (y) (cons :dict-entry y)) (cdr x)))))
    1739           0 :          result)
    1740           0 :         '(:signature "{oa{sa{sv}}}"))))))
    1741             : 
    1742             : (defun dbus-handle-bus-disconnect ()
    1743             :   "React to a bus disconnection.
    1744             : BUS is the bus that disconnected.  This routine unregisters all
    1745             : handlers on the given bus and causes all synchronous calls
    1746             : pending at the time of disconnect to fail."
    1747           0 :   (let ((bus (dbus-event-bus-name last-input-event))
    1748             :         (keys-to-remove))
    1749           0 :     (maphash
    1750             :      (lambda (key value)
    1751           0 :        (when (and (eq (nth 0 key) :serial)
    1752           0 :                   (eq (nth 1 key) bus))
    1753           0 :          (run-hook-with-args
    1754             :           'dbus-event-error-functions
    1755           0 :           (list 'dbus-event
    1756           0 :                 bus
    1757           0 :                 dbus-message-type-error
    1758           0 :                 (nth 2 key)
    1759             :                 nil
    1760             :                 nil
    1761             :                 nil
    1762             :                 nil
    1763           0 :                 value)
    1764           0 :           (list 'dbus-error "Bus disconnected" bus))
    1765           0 :          (push key keys-to-remove)))
    1766           0 :      dbus-registered-objects-table)
    1767           0 :     (dolist (key keys-to-remove)
    1768           0 :       (remhash key dbus-registered-objects-table))))
    1769             : 
    1770             : (defun dbus-init-bus (bus &optional private)
    1771             :   "Establish the connection to D-Bus BUS.
    1772             : 
    1773             : BUS can be either the symbol `:system' or the symbol `:session', or it
    1774             : can be a string denoting the address of the corresponding bus.  For
    1775             : the system and session buses, this function is called when loading
    1776             : `dbus.el', there is no need to call it again.
    1777             : 
    1778             : The function returns a number, which counts the connections this Emacs
    1779             : session has established to the BUS under the same unique name (see
    1780             : `dbus-get-unique-name').  It depends on the libraries Emacs is linked
    1781             : with, and on the environment Emacs is running.  For example, if Emacs
    1782             : is linked with the gtk toolkit, and it runs in a GTK-aware environment
    1783             : like Gnome, another connection might already be established.
    1784             : 
    1785             : When PRIVATE is non-nil, a new connection is established instead of
    1786             : reusing an existing one.  It results in a new unique name at the bus.
    1787             : This can be used, if it is necessary to distinguish from another
    1788             : connection used in the same Emacs process, like the one established by
    1789             : GTK+.  It should be used with care for at least the `:system' and
    1790             : `:session' buses, because other Emacs Lisp packages might already use
    1791             : this connection to those buses."
    1792           2 :   (or (featurep 'dbusbind)
    1793           2 :       (signal 'dbus-error (list "Emacs not compiled with dbus support")))
    1794           2 :   (dbus--init-bus bus private)
    1795           1 :   (dbus-register-signal
    1796           1 :    bus nil dbus-path-local dbus-interface-local
    1797           1 :    "Disconnected" #'dbus-handle-bus-disconnect))
    1798             : 
    1799             :  
    1800             : ;; Initialize `:system' and `:session' buses.  This adds their file
    1801             : ;; descriptors to input_wait_mask, in order to detect incoming
    1802             : ;; messages immediately.
    1803             : (when (featurep 'dbusbind)
    1804             :   (dbus-ignore-errors
    1805             :     (dbus-init-bus :system))
    1806             :   (dbus-ignore-errors
    1807             :     (dbus-init-bus :session)))
    1808             : 
    1809             : (provide 'dbus)
    1810             : 
    1811             : ;;; TODO:
    1812             : 
    1813             : ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
    1814             : ;;   org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
    1815             : 
    1816             : ;;; dbus.el ends here

Generated by: LCOV version 1.12