cgit.sxemacs.org Git - sxemacs/blob - lisp/ffi/ffi-dbus.el

   1 ;;; ffi-dbus.el --- FFI for D-Bus.
   2
   3 ;; Copyright (C) 2008 by Zajcev Evgeny.
   4
   5 ;; Author: Zajcev Evgeny <lg@sxemacs.org>
   6 ;; Keywords: interface, ffi
   7
   8 ;; This file is part of SXEmacs.
   9 ;;
  10 ;; SXEmacs 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 ;; SXEmacs 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  22 ;;
  23 ;;; Synched up with: Not in FSF
  24
  25 ;;; Commentary:
  26
  27 ;; Th is the D-Bus for SXEmacs.  For usage please look at TESTING
  28 ;; section at the end of this file.
  29
  30 \f
  31 ;;; Code:
  32 (defun dbus-load-lib (libs)
  33   "Try load any library from LIBS."
  34   (condition-case nil
  35       (ffi-load (car libs))
  36     (t (dbus-load-lib (cdr libs)))))
  37
  38 (dbus-load-lib '("libdbus-1.so" "libdbus.so"))
  39
  40 (define-ffi-type dbus-bus-type int)
  41 (define-ffi-type dbus-bool boolean)
  42
  43 (defconst dbus-type-invalid 0
  44   "Type code that is never equal to a legitimate type code.")
  45
  46 (defconst dbus-type-string (char-int ?s)
  47   "Type code marking a UTF-8 encoded, nul-terminated Unicode string.")
  48
  49 (defconst dbus-type-int32 (char-int ?i)
  50   "Type code marking a 32-bit signed integer.")
  51
  52 ;;{{{ Constants
  53
  54 (defconst DBUS_BUS_SESSION 0 "DBus type: Session")
  55 (defconst DBUS_BUS_SYSTEM 1 "DBus type: System")
  56 (defconst DBUS_BUS_STARTER 2 "DBus type: Starter")
  57
  58 (defconst DBUS_HANDLER_RESULT_HANDLED 0 "Result handled")
  59 (defconst DBUS_HANDLER_RESULT_NOT_YET_HANDLED 1 "Result not yet handled")
  60 (defconst DBUS_HANDLER_RESULT_NEED_MEMORY 2 "Result need memory")
  61
  62 (defconst dbus-service-dbus "org.freedesktop.DBus"
  63   "The bus name used to talk to the bus itself.")
  64
  65 (defconst dbus-path-dbus "/org/freedesktop/DBus"
  66   "The object path used to talk to the bus itself.")
  67
  68 (defconst dbus-path-local "/org/freedesktop/DBus/Local"
  69   "The object path used in local/in-process-generated messages.")
  70
  71 (defconst dbus-interface-dbus "org.freedesktop.DBus"
  72   "The interface exported by the object with `dbus-service-dbus'
  73 and `dbus-path-dbus'.")
  74
  75 (defconst dbus-interface-introspecable "org.freedesktop.DBus.Introspectable"
  76   "The interface supported by introspectable objects.")
  77
  78 (defconst dbus-interface-properties "org.freedesktop.DBus.Properties"
  79   "The interface supported by objects with properties.")
  80
  81 (defconst dbus-interface-peer "org.freedesktop.DBus.Peer"
  82   "The interface supported by most dbus peers.")
  83
  84 (defconst dbus-interface-local "org.freedesktop.DBus.Local"
  85   "This is a special interface whose methods can only be invoked by
  86 the local implementation (messages from remote apps aren't allowed to
  87 specify this interface). ")
  88
  89 (defconst dbus-name-flag-allow-replacement 1
  90   "Allow another service to become the primary owner if requested.")
  91
  92 (defconst dbus-name-flag-replace-existing 2
  93   "Request to replace the current primary owner.")
  94
  95 (defconst dbus-name-flag-do-not-queue 4
  96   "If we can not become the primary owner do not place us in the queue.")
  97
  98 (defconst dbus-request-name-reply-primary-owner 1
  99   "Service has become the primary owner of the requested name.")
 100
 101 (defconst dbus-request-name-reply-in-queue 2
 102   "Service could not become the primary owner and has been placed in
 103 the queue. ")
 104
 105 (defconst dbus-request-name-reply-exists 3
 106   "Service is already in the queue.")
 107
 108 (defconst dbus-request-name-reply-already-owner 4
 109   "Service is already the primary owner.")
 110
 111 (defconst dbus-release-name-reply-released 1
 112   "Service was released from the given name.")
 113
 114 (defconst dbus-release-name-reply-non-existant 2
 115   "The given name does not exist on the bus.")
 116
 117 (defconst dbus-release-name-reply-not-owner 3
 118   "Service is not an owner of the given name.")
 119
 120 (defconst dbus-start-reply-success 1
 121   "Service was auto started.")
 122
 123 (defconst dbus-start-reply-already-running 2
 124   "Service was already running.")
 125
 126 ;;}}}
 127 ;;{{{ D-Bus connection functions
 128
 129 (cffi:defcfun ("dbus_bus_get" dbus:bus-get) :pointer
 130   (type dbus-bus-type)
 131   (error :pointer))
 132
 133 (cffi:defcfun ("dbus_bus_request_name" dbus:bus-request-name) :int
 134   (connection :pointer)
 135   (name :string)
 136   (flags :uint)
 137   (error :pointer))
 138
 139 (cffi:defcstruct dbus-object-path-vtable
 140   (unregister-function :pointer)
 141   (message-function :pointer)
 142   (dummy1 :pointer)
 143   (dummy2 :pointer)
 144   (dummy3 :pointer)
 145   (dummy4 :pointer))
 146
 147 (cffi:defcfun ("dbus_connection_send_with_reply_and_block"
 148                dbus:connection-send-with-reply-and-block) :pointer
 149   (connection :pointer)
 150   (message :pointer)
 151   (timeout_milliseconds :int)
 152   (error :pointer))
 153
 154 (cffi:defcfun ("dbus_connection_send" dbus:connection-send) dbus-bool
 155   (connection :pointer)
 156   (message :pointer)
 157   (serial :pointer))
 158
 159 (cffi:defcfun ("dbus_connection_read_write"
 160                dbus:connection-read-write) dbus-bool
 161   (connection :pointer)
 162   (timeout-milliseconds :int))
 163
 164 (cffi:defcfun ("dbus_connection_read_write_dispatch"
 165                dbus:connection-read-write-dispatch) dbus-bool
 166   (connection :pointer)
 167   (timeout-milliseconds :int))
 168
 169 (cffi:defcfun ("dbus_connection_pop_message"
 170                dbus:connection-pop-message) :pointer
 171   (connection :pointer))
 172
 173 (cffi:defcfun ("dbus_connection_flush" dbus:connection-flush) :void
 174   (connection :pointer))
 175
 176 (cffi:defcfun ("dbus_connection_register_object_path"
 177                dbus:connection-register-object-path) dbus-bool
 178   (connection :pointer)
 179   (path :string)
 180   (vtable :pointer)
 181   (user-data :pointer))
 182
 183 ;;}}}
 184 ;;{{{ Error functions
 185
 186 (cffi:defcstruct dbus-error
 187   (name :string)
 188   (message :string)
 189   (dummy1 :uint)
 190   (dummy2 :uint)
 191   (dummy3 :uint)
 192   (dummy4 :uint)
 193   (dummy5 :uint)
 194   (padding :pointer))
 195
 196 (cffi:defcfun ("dbus_error_init" dbus:error-init) :void
 197   (error :pointer))
 198
 199 (cffi:defcfun ("dbus_error_free" dbus:error-free) :void
 200   (error :pointer))
 201
 202 (cffi:defcfun ("dbus_error_is_set" dbus:error-is-set) dbus-bool
 203   (error :pointer))
 204
 205 ;;}}}
 206 ;;{{{ Message functions
 207
 208 (cffi:defcfun ("dbus_message_new_method_call"
 209                dbus:message-new-method-call) :pointer
 210   (destination :string)
 211   (path :string)
 212   (interface :string)
 213   (method :string))
 214
 215 (cffi:defcfun ("dbus_message_get_args" dbus:message-get-args) dbus-bool
 216   (message :pointer)
 217   (error :pointer)
 218   &rest)
 219
 220 (cffi:defcfun ("dbus_message_append_args"
 221                dbus:message-append-args) dbus-bool
 222   (message :pointer)
 223   (first-arg-type :int)
 224   &rest)
 225
 226 (cffi:defcfun ("dbus_message_get_interface"
 227                dbus:message-get-interface) :string
 228   (message :pointer))
 229
 230 (cffi:defcfun ("dbus_message_get_member"
 231                dbus:message-get-member) :string
 232   (message :pointer))
 233
 234 (cffi:defcfun ("dbus_message_get_path"
 235                dbus:message-get-path) :string
 236   (message :pointer))
 237
 238 (cffi:defcfun ("dbus_message_unref" dbus:message-unref) :void
 239   (message :pointer))
 240
 241 (cffi:defcfun ("dbus_message_is_method_call"
 242                dbus:message-is-method-call) dbus-bool
 243   (message :pointer)
 244   (interface :string)
 245   (method :string))
 246
 247 (cffi:defcfun ("dbus_message_iter_init"
 248                dbus:message-iter-init) dbus-bool
 249   (message :pointer)
 250   (iter :pointer))
 251
 252 (cffi:defcfun ("dbus_message_iter_get_arg_type"
 253                dbus:message-iter-get-arg-type) :int
 254   (iter :pointer))
 255
 256 (cffi:defcfun ("dbus_message_iter_get_basic"
 257                dbus:message-iter-get-basic) :void
 258   (iter :pointer)
 259   (value :pointer))
 260
 261 (cffi:defcfun ("dbus_message_new_method_return"
 262                dbus:message-new-method-return) :pointer
 263   (method_call :pointer))
 264
 265 (cffi:defcfun ("dbus_message_iter_init_append"
 266                dbus:message-iter-init-append) :void
 267   (message :pointer)
 268   (iter :pointer))
 269
 270 (cffi:defcfun ("dbus_message_iter_append_basic"
 271                dbus:message-iter-append-basic) dbus-bool
 272   (iter :pointer)
 273   (type :int)
 274   (value :pointer))
 275
 276 ;;}}}
 277
 278 ;;; TODO: elisp-friendly d-bus implementation.
 279 ;;   - Use macros, like python-dbus uses its decorators
 280 (defstruct (dbus-connection (:type vector) :named
 281                             (:print-function
 282                              (lambda (dc s pl)
 283                                (setq pl pl) ; steenkin byte-compiler! --SY.
 284                                (princ (format "#<dbus connection: %s>"
 285                                               (dbus-connection-object dc)) s))))
 286   bus-name
 287   object
 288   ffi-error
 289   ffi-conn)
 290
 291 (defun dbus-create-connection (object-path bus-name)
 292   "Create connection to D-Bus.
 293 Return newly created connection structure."
 294   (let ((dcon (make-dbus-connection :bus-name bus-name
 295                                     :object object-path)))
 296     (setf (dbus-connection-ffi-error dcon)
 297           (cffi:foreign-alloc 'dbus-error))
 298     (dbus:error-init (dbus-connection-ffi-error dcon))
 299     (setf (dbus-connection-ffi-conn dcon)
 300           (dbus:bus-get DBUS_BUS_SESSION
 301                         (dbus-connection-ffi-error dcon)))
 302     dcon))
 303
 304 (defmacro* define-dbus-signal (dcon iface signature &rest body)
 305   "Define new D-Bus signal emiter for interface IFACE.
 306 Optionally you can specify signal SIGNATURE."
 307   )
 308
 309 (provide 'ffi-dbus)
 310
 311 \f
 312 ;;; TESTING:
 313
 314 ;;; To toggle gajim's roster use something like
 315 ; (let* ((derr (make-ffi-object 'dbus-error))
 316 ;        (dcon (progn
 317 ;                (dbus:error-init (ffi-address-of derr))
 318 ;                (dbus:bus-get DBUS_BUS_SESSION (ffi-address-of derr))))
 319 ;       (gajm-meth (dbus:message-new-method-call
 320 ;                   "org.gajim.dbus"
 321 ;                  "/org/gajim/dbus/RemoteObject"
 322 ;                  "org.gajim.dbus.RemoteInterface"
 323 ;                  "toggle_roster_appearance")))
 324 ;   (unwind-protect
 325 ;       (unless (ffi-null-p dcon)
 326 ;         (dbus:connection-send dcon gajm-meth -1))
 327 ;     (dbus:message-unref gajm-meth)))
 328
 329 ;; To get list of services
 330 ; (let* ((derr (make-ffi-object 'dbus-error))
 331 ;        (dcon (progn
 332 ;                (dbus:error-init (ffi-address-of derr))
 333 ;                (dbus:bus-get DBUS_BUS_SESSION (ffi-address-of derr)))))
 334 ;   (unless (ffi-null-p dcon)
 335 ;     (let* ((lmeth (dbus:message-new-method-call
 336 ;                    "org.freedesktop.DBus"
 337 ;                    "/org/freedesktop/DBus"
 338 ;                    "org.freedesktop.DBus"
 339 ;                    "ListNames"))
 340 ;            (lreply (dbus:connection-send-with-reply-and-block
 341 ;                     dcon lmeth -1 (ffi-address-of derr)))
 342 ;            (slist (cffi:foreign-alloc :pointer))
 343 ;            (slist-len (make-ffi-object :int)))
 344 ;       (unless (ffi-null-p lreply)
 345 ;         (let ((rargs (dbus:message-get-args
 346 ;                       lreply (ffi-address-of derr)
 347 ;                       :int 97 :int 115 :pointer slist
 348 ;                       :pointer (ffi-address-of slist-len)
 349 ;                       :int 0)))
 350 ;           (prog1
 351 ;               (ffi-get (ffi-get (ffi-get slist))
 352 ;                        :type `(array :string ,(ffi-get slist-len)))
 353 ;             (dbus:message-unref lmeth)
 354 ;             (dbus:message-unref lreply)))))))
 355
 356 ;;; ffi-dbus.el ends here