1 ;;; ffi-dbus.el --- FFI for D-Bus.
3 ;; Copyright (C) 2008 by Zajcev Evgeny.
5 ;; Author: Zajcev Evgeny <lg@sxemacs.org>
6 ;; Keywords: interface, ffi
8 ;; This file is part of SXEmacs.
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.
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.
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/>.
23 ;;; Synched up with: Not in FSF
27 ;; Th is the D-Bus for SXEmacs. For usage please look at TESTING
28 ;; section at the end of this file.
32 (defun dbus-load-lib (libs)
33 "Try load any library from LIBS."
36 (t (dbus-load-lib (cdr libs)))))
38 (dbus-load-lib '("libdbus-1.so" "libdbus.so"))
40 (define-ffi-type dbus-bus-type int)
41 (define-ffi-type dbus-bool boolean)
43 (defconst dbus-type-invalid 0
44 "Type code that is never equal to a legitimate type code.")
46 (defconst dbus-type-string (char-int ?s)
47 "Type code marking a UTF-8 encoded, nul-terminated Unicode string.")
49 (defconst dbus-type-int32 (char-int ?i)
50 "Type code marking a 32-bit signed integer.")
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")
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")
62 (defconst dbus-service-dbus "org.freedesktop.DBus"
63 "The bus name used to talk to the bus itself.")
65 (defconst dbus-path-dbus "/org/freedesktop/DBus"
66 "The object path used to talk to the bus itself.")
68 (defconst dbus-path-local "/org/freedesktop/DBus/Local"
69 "The object path used in local/in-process-generated messages.")
71 (defconst dbus-interface-dbus "org.freedesktop.DBus"
72 "The interface exported by the object with `dbus-service-dbus'
73 and `dbus-path-dbus'.")
75 (defconst dbus-interface-introspecable "org.freedesktop.DBus.Introspectable"
76 "The interface supported by introspectable objects.")
78 (defconst dbus-interface-properties "org.freedesktop.DBus.Properties"
79 "The interface supported by objects with properties.")
81 (defconst dbus-interface-peer "org.freedesktop.DBus.Peer"
82 "The interface supported by most dbus peers.")
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). ")
89 (defconst dbus-name-flag-allow-replacement 1
90 "Allow another service to become the primary owner if requested.")
92 (defconst dbus-name-flag-replace-existing 2
93 "Request to replace the current primary owner.")
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.")
98 (defconst dbus-request-name-reply-primary-owner 1
99 "Service has become the primary owner of the requested name.")
101 (defconst dbus-request-name-reply-in-queue 2
102 "Service could not become the primary owner and has been placed in
105 (defconst dbus-request-name-reply-exists 3
106 "Service is already in the queue.")
108 (defconst dbus-request-name-reply-already-owner 4
109 "Service is already the primary owner.")
111 (defconst dbus-release-name-reply-released 1
112 "Service was released from the given name.")
114 (defconst dbus-release-name-reply-non-existant 2
115 "The given name does not exist on the bus.")
117 (defconst dbus-release-name-reply-not-owner 3
118 "Service is not an owner of the given name.")
120 (defconst dbus-start-reply-success 1
121 "Service was auto started.")
123 (defconst dbus-start-reply-already-running 2
124 "Service was already running.")
127 ;;{{{ D-Bus connection functions
129 (cffi:defcfun ("dbus_bus_get" dbus:bus-get) :pointer
133 (cffi:defcfun ("dbus_bus_request_name" dbus:bus-request-name) :int
134 (connection :pointer)
139 (cffi:defcstruct dbus-object-path-vtable
140 (unregister-function :pointer)
141 (message-function :pointer)
147 (cffi:defcfun ("dbus_connection_send_with_reply_and_block"
148 dbus:connection-send-with-reply-and-block) :pointer
149 (connection :pointer)
151 (timeout_milliseconds :int)
154 (cffi:defcfun ("dbus_connection_send" dbus:connection-send) dbus-bool
155 (connection :pointer)
159 (cffi:defcfun ("dbus_connection_read_write"
160 dbus:connection-read-write) dbus-bool
161 (connection :pointer)
162 (timeout-milliseconds :int))
164 (cffi:defcfun ("dbus_connection_read_write_dispatch"
165 dbus:connection-read-write-dispatch) dbus-bool
166 (connection :pointer)
167 (timeout-milliseconds :int))
169 (cffi:defcfun ("dbus_connection_pop_message"
170 dbus:connection-pop-message) :pointer
171 (connection :pointer))
173 (cffi:defcfun ("dbus_connection_flush" dbus:connection-flush) :void
174 (connection :pointer))
176 (cffi:defcfun ("dbus_connection_register_object_path"
177 dbus:connection-register-object-path) dbus-bool
178 (connection :pointer)
181 (user-data :pointer))
184 ;;{{{ Error functions
186 (cffi:defcstruct dbus-error
196 (cffi:defcfun ("dbus_error_init" dbus:error-init) :void
199 (cffi:defcfun ("dbus_error_free" dbus:error-free) :void
202 (cffi:defcfun ("dbus_error_is_set" dbus:error-is-set) dbus-bool
206 ;;{{{ Message functions
208 (cffi:defcfun ("dbus_message_new_method_call"
209 dbus:message-new-method-call) :pointer
210 (destination :string)
215 (cffi:defcfun ("dbus_message_get_args" dbus:message-get-args) dbus-bool
220 (cffi:defcfun ("dbus_message_append_args"
221 dbus:message-append-args) dbus-bool
223 (first-arg-type :int)
226 (cffi:defcfun ("dbus_message_get_interface"
227 dbus:message-get-interface) :string
230 (cffi:defcfun ("dbus_message_get_member"
231 dbus:message-get-member) :string
234 (cffi:defcfun ("dbus_message_get_path"
235 dbus:message-get-path) :string
238 (cffi:defcfun ("dbus_message_unref" dbus:message-unref) :void
241 (cffi:defcfun ("dbus_message_is_method_call"
242 dbus:message-is-method-call) dbus-bool
247 (cffi:defcfun ("dbus_message_iter_init"
248 dbus:message-iter-init) dbus-bool
252 (cffi:defcfun ("dbus_message_iter_get_arg_type"
253 dbus:message-iter-get-arg-type) :int
256 (cffi:defcfun ("dbus_message_iter_get_basic"
257 dbus:message-iter-get-basic) :void
261 (cffi:defcfun ("dbus_message_new_method_return"
262 dbus:message-new-method-return) :pointer
263 (method_call :pointer))
265 (cffi:defcfun ("dbus_message_iter_init_append"
266 dbus:message-iter-init-append) :void
270 (cffi:defcfun ("dbus_message_iter_append_basic"
271 dbus:message-iter-append-basic) dbus-bool
278 ;;; TODO: elisp-friendly d-bus implementation.
279 ;; - Use macros, like python-dbus uses its decorators
280 (defstruct (dbus-connection (:type vector) :named
283 (setq pl pl) ; steenkin byte-compiler! --SY.
284 (princ (format "#<dbus connection: %s>"
285 (dbus-connection-object dc)) s))))
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)))
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."
314 ;;; To toggle gajim's roster use something like
315 ; (let* ((derr (make-ffi-object 'dbus-error))
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
321 ; "/org/gajim/dbus/RemoteObject"
322 ; "org.gajim.dbus.RemoteInterface"
323 ; "toggle_roster_appearance")))
325 ; (unless (ffi-null-p dcon)
326 ; (dbus:connection-send dcon gajm-meth -1))
327 ; (dbus:message-unref gajm-meth)))
329 ;; To get list of services
330 ; (let* ((derr (make-ffi-object 'dbus-error))
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"
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)
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)))))))
356 ;;; ffi-dbus.el ends here