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