mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-26 23:31:55 -08:00
67ab6bcdba
* src/alloc.c (display_malloc_warning, syms_of_alloc): * src/buffer.c (Fmake_indirect_buffer, Fbuffer_local_variables) (Frename_buffer, Fkill_buffer, Fset_buffer_major_mode) (Fset_buffer_multibyte, syms_of_buffer): * src/callint.c (read_file_name, Fcall_interactively) (syms_of_callint): * src/callproc.c (call_process, create_temp_file) (syms_of_callproc): * src/charset.c (Fdefine_charset_internal, syms_of_charset): * src/cmds.c (internal_self_insert, syms_of_cmds): * src/coding.c (record_conversion_result) (Fdefine_coding_system_internal, syms_of_coding): * src/dbusbind.c (xd_signature, Fdbus_message_internal) (syms_of_dbusbind): * src/dispnew.c (init_faces_initial): * src/doc.c (Fsnarf_documentation, syms_of_doc): * src/dosfns.c (system_process_attributes, syms_of_dosfns): * src/emacs.c (init_cmdargs, Fdump_emacs, decode_env_path) (syms_of_emacs): * src/eval.c (call_debugger, Fdefvaralias, syms_of_eval): * src/fileio.c (barf_or_query_if_file_exists) (Finsert_file_contents, auto_save_error, Fdo_auto_save) (syms_of_fileio): * src/filelock.c (lock_file_1, syms_of_filelock): * src/fontset.c (fontset_from_font, syms_of_fontset): * src/frame.c (make_frame_without_minibuffer, syms_of_frame): * src/gnutls.c (emacs_gnutls_certificate_details) (Fgnutls_peer_status_warning_describe, Fgnutls_peer_status) (gnutls_verify_boot, syms_of_gnutls): * src/gtkutil.c (style_changed_cb, find_rtl_image): * src/image.c (imagemagick_filename_hint, gs_load) (syms_of_image): * src/keyboard.c (command_loop_1, read_char, timer_start_idle) (read_char_minibuf_menu_prompt, Fsuspend_emacs) (syms_of_keyboard): * src/keymap.c (Fmap_keymap, Flookup_key, Fdescribe_vector) (describe_vector, syms_of_keymap): * src/lread.c (Fread, Fread_positioning_symbols, syms_of_lread): * src/minibuf.c (Fabort_minibuffers, Fread_buffer) (Fcompleting_read, syms_of_minibuf): * src/msdos.c (XMenuActivate, run_msdos_command, syms_of_msdos): * src/nsfns.m (Fx_display_backing_store, Fx_display_visual_class) (Fns_hide_emacs, Fsystem_move_file_to_trash, ns_create_tip_frame) (x_hide_tip, Fx_show_tip, syms_of_nsfns): * src/nsfont.m (ns_spec_to_descriptor, ns_descriptor_to_entity) (syms_of_nsfont): * src/pdumper.c (Fdump_emacs_portable): * src/pgtkfns.c (Fx_display_visual_class, x_create_tip_frame) (Fx_show_tip, syms_of_pgtkfns): * src/pgtkterm.c (syms_of_pgtkterm, pgtk_cr_export_frames): * src/term.c (term_get_fkeys_1, set_tty_color_mode, Fsuspend_tty) (Fresume_tty, tty_menu_activate, syms_of_term): * src/terminal.c (create_terminal, syms_of_terminal): * src/w32fns.c (Fx_display_backing_store) (Fx_display_visual_class, Fset_message_beep, Fx_open_connection) (Fx_show_tip, Fx_file_dialog, Fsystem_move_file_to_trash) (Fw32_toggle_lock_key, syms_of_w32fns): * src/w32font.c (w32_enumfont_pattern_entity, syms_of_w32font): * src/w32term.c (w32_bitmap_icon, syms_of_w32term): * src/xdisp.c (message_dolog, define_frame_cursor1) (syms_of_xdisp): * src/xfaces.c (tty_lookup_color, syms_of_xfaces): * src/xml.c (make_dom, syms_of_xml): * src/xterm.c (syms_of_xterm): * src/xwidget.c (store_xwidget_download_callback_event) (store_xwidget_js_callback_event, syms_of_xwidget): Define symbols for symbols interned with `intern' from a constant string, delete duplicate DEFSYM directives, and substitute them for such calls to intern. This excludes only those symbols which are interned and referenced only once during Emacs's initialization, the timing of whose interning is inconsequential, and symbols in w32.c, which would need to be transferred to a new syms_of_w32 function that I cannot test.
2040 lines
62 KiB
C
2040 lines
62 KiB
C
/* Elisp bindings for D-Bus.
|
||
Copyright (C) 2007-2024 Free Software Foundation, Inc.
|
||
|
||
This file is part of GNU Emacs.
|
||
|
||
GNU Emacs is free software: you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation, either version 3 of the License, or (at
|
||
your option) any later version.
|
||
|
||
GNU Emacs is distributed in the hope that it will be useful,
|
||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
GNU General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
|
||
|
||
#include <config.h>
|
||
|
||
#ifdef HAVE_DBUS
|
||
#include <stdio.h>
|
||
#include <stdlib.h>
|
||
#include <dbus/dbus.h>
|
||
|
||
#include "lisp.h"
|
||
#include "termhooks.h"
|
||
#include "keyboard.h"
|
||
#include "pdumper.h"
|
||
#include "process.h"
|
||
|
||
#ifndef DBUS_NUM_MESSAGE_TYPES
|
||
#define DBUS_NUM_MESSAGE_TYPES 5
|
||
#endif
|
||
|
||
|
||
/* Some platforms define the symbol "interface", but we want to use it
|
||
* as a variable name below. */
|
||
|
||
#ifdef interface
|
||
#undef interface
|
||
#endif
|
||
|
||
|
||
/* Alist of D-Bus buses we are polling for messages.
|
||
The key is the symbol or string of the bus, and the value is the
|
||
connection address. For every bus, just one connection is counted.
|
||
If there shall be a second connection to the same bus, a different
|
||
symbol or string for the bus must be chosen. On Lisp level, a bus
|
||
stands for the associated connection. */
|
||
static Lisp_Object xd_registered_buses;
|
||
|
||
/* Whether we are reading a D-Bus event. */
|
||
static bool xd_in_read_queued_messages = 0;
|
||
|
||
|
||
/* We use "xd_" and "XD_" as prefix for all internal symbols, because
|
||
we don't want to poison other namespaces with "dbus_". */
|
||
|
||
/* Raise a signal. If we are reading events, we cannot signal; we
|
||
throw to xd_read_queued_messages then. */
|
||
#define XD_SIGNAL1(arg) \
|
||
do { \
|
||
if (xd_in_read_queued_messages) \
|
||
Fthrow (Qdbus_error, Qnil); \
|
||
else \
|
||
xsignal1 (Qdbus_error, arg); \
|
||
} while (0)
|
||
|
||
#define XD_SIGNAL2(arg1, arg2) \
|
||
do { \
|
||
if (xd_in_read_queued_messages) \
|
||
Fthrow (Qdbus_error, Qnil); \
|
||
else \
|
||
xsignal2 (Qdbus_error, arg1, arg2); \
|
||
} while (0)
|
||
|
||
#define XD_SIGNAL3(arg1, arg2, arg3) \
|
||
do { \
|
||
if (xd_in_read_queued_messages) \
|
||
Fthrow (Qdbus_error, Qnil); \
|
||
else \
|
||
xsignal3 (Qdbus_error, arg1, arg2, arg3); \
|
||
} while (0)
|
||
|
||
/* Raise a Lisp error from a D-Bus ERROR. */
|
||
#define XD_ERROR(error) \
|
||
do { \
|
||
/* Remove the trailing newline. */ \
|
||
char const *mess = error.message; \
|
||
char const *nl = strchr (mess, '\n'); \
|
||
Lisp_Object err = make_string (mess, nl ? nl - mess : strlen (mess)); \
|
||
dbus_error_free (&error); \
|
||
XD_SIGNAL1 (err); \
|
||
} while (0)
|
||
|
||
/* Macros for debugging. In order to enable them, build with
|
||
"make MYCPPFLAGS='-DDBUS_DEBUG'". */
|
||
#ifdef DBUS_DEBUG
|
||
#define XD_DEBUG_MESSAGE(...) \
|
||
do { \
|
||
char s[1024]; \
|
||
snprintf (s, sizeof s, __VA_ARGS__); \
|
||
if (!noninteractive) \
|
||
printf ("%s: %s\n", __func__, s); \
|
||
message ("%s: %s", __func__, s); \
|
||
} while (0)
|
||
#define XD_DEBUG_VALID_LISP_OBJECT_P(object) \
|
||
do { \
|
||
if (!valid_lisp_object_p (object)) \
|
||
{ \
|
||
XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__); \
|
||
XD_SIGNAL1 (build_string ("Assertion failure")); \
|
||
} \
|
||
} while (0)
|
||
|
||
#else /* !DBUS_DEBUG */
|
||
# define XD_DEBUG_MESSAGE(...) \
|
||
do { \
|
||
if (!NILP (Vdbus_debug)) \
|
||
{ \
|
||
char s[1024]; \
|
||
snprintf (s, sizeof s, __VA_ARGS__); \
|
||
message ("%s: %s", __func__, s); \
|
||
} \
|
||
} while (0)
|
||
# define XD_DEBUG_VALID_LISP_OBJECT_P(object)
|
||
#endif
|
||
|
||
/* Check whether TYPE is a basic DBusType. */
|
||
#ifdef HAVE_DBUS_TYPE_IS_VALID
|
||
#define XD_BASIC_DBUS_TYPE(type) \
|
||
(dbus_type_is_valid (type) && dbus_type_is_basic (type))
|
||
#else
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
#define XD_BASIC_DBUS_TYPE(type) \
|
||
((type == DBUS_TYPE_BYTE) \
|
||
|| (type == DBUS_TYPE_BOOLEAN) \
|
||
|| (type == DBUS_TYPE_INT16) \
|
||
|| (type == DBUS_TYPE_UINT16) \
|
||
|| (type == DBUS_TYPE_INT32) \
|
||
|| (type == DBUS_TYPE_UINT32) \
|
||
|| (type == DBUS_TYPE_INT64) \
|
||
|| (type == DBUS_TYPE_UINT64) \
|
||
|| (type == DBUS_TYPE_DOUBLE) \
|
||
|| (type == DBUS_TYPE_STRING) \
|
||
|| (type == DBUS_TYPE_OBJECT_PATH) \
|
||
|| (type == DBUS_TYPE_SIGNATURE) \
|
||
|| (type == DBUS_TYPE_UNIX_FD))
|
||
#else
|
||
#define XD_BASIC_DBUS_TYPE(type) \
|
||
((type == DBUS_TYPE_BYTE) \
|
||
|| (type == DBUS_TYPE_BOOLEAN) \
|
||
|| (type == DBUS_TYPE_INT16) \
|
||
|| (type == DBUS_TYPE_UINT16) \
|
||
|| (type == DBUS_TYPE_INT32) \
|
||
|| (type == DBUS_TYPE_UINT32) \
|
||
|| (type == DBUS_TYPE_INT64) \
|
||
|| (type == DBUS_TYPE_UINT64) \
|
||
|| (type == DBUS_TYPE_DOUBLE) \
|
||
|| (type == DBUS_TYPE_STRING) \
|
||
|| (type == DBUS_TYPE_OBJECT_PATH) \
|
||
|| (type == DBUS_TYPE_SIGNATURE))
|
||
#endif
|
||
#endif
|
||
|
||
/* This was a macro. On Solaris 2.11 it was said to compile for
|
||
hours, when optimization is enabled. So we have transferred it into
|
||
a function. */
|
||
/* Determine the DBusType of a given Lisp symbol. OBJECT must be one
|
||
of the predefined D-Bus type symbols. */
|
||
static int
|
||
xd_symbol_to_dbus_type (Lisp_Object object)
|
||
{
|
||
return
|
||
(EQ (object, QCbyte) ? DBUS_TYPE_BYTE
|
||
: EQ (object, QCboolean) ? DBUS_TYPE_BOOLEAN
|
||
: EQ (object, QCint16) ? DBUS_TYPE_INT16
|
||
: EQ (object, QCuint16) ? DBUS_TYPE_UINT16
|
||
: EQ (object, QCint32) ? DBUS_TYPE_INT32
|
||
: EQ (object, QCuint32) ? DBUS_TYPE_UINT32
|
||
: EQ (object, QCint64) ? DBUS_TYPE_INT64
|
||
: EQ (object, QCuint64) ? DBUS_TYPE_UINT64
|
||
: EQ (object, QCdouble) ? DBUS_TYPE_DOUBLE
|
||
: EQ (object, QCstring) ? DBUS_TYPE_STRING
|
||
: EQ (object, QCobject_path) ? DBUS_TYPE_OBJECT_PATH
|
||
: EQ (object, QCsignature) ? DBUS_TYPE_SIGNATURE
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
: EQ (object, QCunix_fd) ? DBUS_TYPE_UNIX_FD
|
||
#endif
|
||
: EQ (object, QCarray) ? DBUS_TYPE_ARRAY
|
||
: EQ (object, QCvariant) ? DBUS_TYPE_VARIANT
|
||
: EQ (object, QCstruct) ? DBUS_TYPE_STRUCT
|
||
: EQ (object, QCdict_entry) ? DBUS_TYPE_DICT_ENTRY
|
||
: DBUS_TYPE_INVALID);
|
||
}
|
||
|
||
/* Determine the Lisp symbol of DBusType. */
|
||
static Lisp_Object
|
||
xd_dbus_type_to_symbol (int type)
|
||
{
|
||
return
|
||
(type == DBUS_TYPE_BYTE) ? QCbyte
|
||
: (type == DBUS_TYPE_BOOLEAN) ? QCboolean
|
||
: (type == DBUS_TYPE_INT16) ? QCint16
|
||
: (type == DBUS_TYPE_UINT16) ? QCuint16
|
||
: (type == DBUS_TYPE_INT32) ? QCint32
|
||
: (type == DBUS_TYPE_UINT32) ? QCuint32
|
||
: (type == DBUS_TYPE_INT64) ? QCint64
|
||
: (type == DBUS_TYPE_UINT64) ? QCuint64
|
||
: (type == DBUS_TYPE_DOUBLE) ? QCdouble
|
||
: (type == DBUS_TYPE_STRING) ? QCstring
|
||
: (type == DBUS_TYPE_OBJECT_PATH) ? QCobject_path
|
||
: (type == DBUS_TYPE_SIGNATURE) ? QCsignature
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
: (type == DBUS_TYPE_UNIX_FD) ? QCunix_fd
|
||
#endif
|
||
: (type == DBUS_TYPE_ARRAY) ? QCarray
|
||
: (type == DBUS_TYPE_VARIANT) ? QCvariant
|
||
: (type == DBUS_TYPE_STRUCT) ? QCstruct
|
||
: (type == DBUS_TYPE_DICT_ENTRY) ? QCdict_entry
|
||
: Qnil;
|
||
}
|
||
|
||
#define XD_KEYWORDP(object) !NILP (Fkeywordp (object))
|
||
|
||
/* Check whether a Lisp symbol is a predefined D-Bus type symbol. */
|
||
#define XD_DBUS_TYPE_P(object) \
|
||
XD_KEYWORDP (object) && \
|
||
((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID))
|
||
|
||
/* Determine the DBusType of a given Lisp OBJECT. It is used to
|
||
convert Lisp objects, being arguments of `dbus-call-method' or
|
||
`dbus-send-signal', into corresponding C values appended as
|
||
arguments to a D-Bus message. */
|
||
#define XD_OBJECT_TO_DBUS_TYPE(object) \
|
||
((EQ (object, Qt) || NILP (object)) ? DBUS_TYPE_BOOLEAN \
|
||
: (FIXNATP (object)) ? DBUS_TYPE_UINT32 \
|
||
: (FIXNUMP (object)) ? DBUS_TYPE_INT32 \
|
||
: (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
|
||
: (STRINGP (object)) ? DBUS_TYPE_STRING \
|
||
: (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \
|
||
: (CONSP (object)) \
|
||
? ((XD_DBUS_TYPE_P (XCAR (object))) \
|
||
? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (XCAR (object)))) \
|
||
? DBUS_TYPE_ARRAY \
|
||
: xd_symbol_to_dbus_type (XCAR (object))) \
|
||
: DBUS_TYPE_ARRAY) \
|
||
: DBUS_TYPE_INVALID)
|
||
|
||
/* Return a list pointer which does not have a Lisp symbol as car. */
|
||
#define XD_NEXT_VALUE(object) \
|
||
((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
|
||
|
||
/* Transform the message type to its string representation for debug
|
||
messages. */
|
||
#define XD_MESSAGE_TYPE_TO_STRING(mtype) \
|
||
((mtype == DBUS_MESSAGE_TYPE_INVALID) \
|
||
? "DBUS_MESSAGE_TYPE_INVALID" \
|
||
: (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) \
|
||
? "DBUS_MESSAGE_TYPE_METHOD_CALL" \
|
||
: (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) \
|
||
? "DBUS_MESSAGE_TYPE_METHOD_RETURN" \
|
||
: (mtype == DBUS_MESSAGE_TYPE_ERROR) \
|
||
? "DBUS_MESSAGE_TYPE_ERROR" \
|
||
: "DBUS_MESSAGE_TYPE_SIGNAL")
|
||
|
||
/* Transform the object to its string representation for debug
|
||
messages. */
|
||
static char *
|
||
XD_OBJECT_TO_STRING (Lisp_Object object)
|
||
{
|
||
AUTO_STRING (format, "%s");
|
||
return SSDATA (CALLN (Fformat, format, object));
|
||
}
|
||
|
||
#define XD_DBUS_VALIDATE_BUS_ADDRESS(bus) \
|
||
do { \
|
||
char const *session_bus_address = egetenv ("DBUS_SESSION_BUS_ADDRESS"); \
|
||
if (STRINGP (bus)) \
|
||
{ \
|
||
DBusAddressEntry **entries; \
|
||
int len; \
|
||
DBusError derror; \
|
||
dbus_error_init (&derror); \
|
||
if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
|
||
XD_ERROR (derror); \
|
||
/* Cleanup. */ \
|
||
dbus_error_free (&derror); \
|
||
dbus_address_entries_free (entries); \
|
||
/* Canonicalize session bus address. */ \
|
||
if ((session_bus_address != NULL) \
|
||
&& (!NILP (Fstring_equal \
|
||
(bus, build_string (session_bus_address))))) \
|
||
bus = QCsession; \
|
||
} \
|
||
\
|
||
else \
|
||
{ \
|
||
CHECK_SYMBOL (bus); \
|
||
if (!(EQ (bus, QCsystem) || EQ (bus, QCsession) \
|
||
|| EQ (bus, QCsystem_private) \
|
||
|| EQ (bus, QCsession_private))) \
|
||
XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \
|
||
/* We do not want to have an autolaunch for the session bus. */ \
|
||
if ((EQ (bus, QCsession) || EQ (bus, QCsession_private)) \
|
||
&& session_bus_address == NULL) \
|
||
XD_SIGNAL2 (build_string ("No connection to bus"), bus); \
|
||
} \
|
||
} while (0)
|
||
|
||
#if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH \
|
||
|| HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
|
||
#define XD_DBUS_VALIDATE_OBJECT(object, func) \
|
||
do { \
|
||
if (!NILP (object)) \
|
||
{ \
|
||
DBusError derror; \
|
||
CHECK_STRING (object); \
|
||
dbus_error_init (&derror); \
|
||
if (!func (SSDATA (object), &derror)) \
|
||
XD_ERROR (derror); \
|
||
/* Cleanup. */ \
|
||
dbus_error_free (&derror); \
|
||
} \
|
||
} while (0)
|
||
#endif
|
||
|
||
#if HAVE_DBUS_VALIDATE_BUS_NAME
|
||
#define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
|
||
XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
|
||
#else
|
||
#define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
|
||
if (!NILP (bus_name)) CHECK_STRING (bus_name);
|
||
#endif
|
||
|
||
#if HAVE_DBUS_VALIDATE_PATH
|
||
#define XD_DBUS_VALIDATE_PATH(path) \
|
||
XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
|
||
#else
|
||
#define XD_DBUS_VALIDATE_PATH(path) \
|
||
if (!NILP (path)) CHECK_STRING (path);
|
||
#endif
|
||
|
||
#if HAVE_DBUS_VALIDATE_INTERFACE
|
||
#define XD_DBUS_VALIDATE_INTERFACE(interface) \
|
||
XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
|
||
#else
|
||
#define XD_DBUS_VALIDATE_INTERFACE(interface) \
|
||
if (!NILP (interface)) CHECK_STRING (interface);
|
||
#endif
|
||
|
||
#if HAVE_DBUS_VALIDATE_MEMBER
|
||
#define XD_DBUS_VALIDATE_MEMBER(member) \
|
||
XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
|
||
#else
|
||
#define XD_DBUS_VALIDATE_MEMBER(member) \
|
||
if (!NILP (member)) CHECK_STRING (member);
|
||
#endif
|
||
|
||
/* Append to SIGNATURE a copy of X, making sure SIGNATURE does
|
||
not become too long. */
|
||
static void
|
||
xd_signature_cat (char *signature, char const *x)
|
||
{
|
||
ptrdiff_t siglen = strlen (signature);
|
||
ptrdiff_t xlen = strlen (x);
|
||
if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
|
||
string_overflow ();
|
||
strcpy (signature + siglen, x);
|
||
}
|
||
|
||
/* Compute SIGNATURE of OBJECT. It must have a form that it can be
|
||
used in dbus_message_iter_open_container. DTYPE is the DBusType
|
||
the object is related to. It is passed as argument, because it
|
||
cannot be detected in basic type objects, when they are preceded by
|
||
a type symbol. PARENT_TYPE is the DBusType of a container this
|
||
signature is embedded, or DBUS_TYPE_INVALID. It is needed for the
|
||
check that DBUS_TYPE_DICT_ENTRY occurs only as array element. */
|
||
static void
|
||
xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
|
||
{
|
||
int subtype;
|
||
Lisp_Object elt;
|
||
char const *subsig;
|
||
char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
|
||
|
||
elt = object;
|
||
|
||
switch (dtype)
|
||
{
|
||
case DBUS_TYPE_BYTE:
|
||
case DBUS_TYPE_UINT16:
|
||
CHECK_FIXNAT (object);
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_BOOLEAN:
|
||
/* There must be an argument. */
|
||
if (EQ (QCboolean, object))
|
||
wrong_type_argument (Qbooleanp, object);
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_INT16:
|
||
CHECK_FIXNUM (object);
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_UINT32:
|
||
case DBUS_TYPE_UINT64:
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
case DBUS_TYPE_UNIX_FD:
|
||
#endif
|
||
case DBUS_TYPE_INT32:
|
||
case DBUS_TYPE_INT64:
|
||
case DBUS_TYPE_DOUBLE:
|
||
CHECK_NUMBER (object);
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_STRING:
|
||
case DBUS_TYPE_OBJECT_PATH:
|
||
case DBUS_TYPE_SIGNATURE:
|
||
/* We don't check the syntax of signature. This will be done by
|
||
libdbus. */
|
||
if (dtype == DBUS_TYPE_OBJECT_PATH)
|
||
XD_DBUS_VALIDATE_PATH (object)
|
||
else
|
||
CHECK_STRING (object);
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_ARRAY:
|
||
/* Check that all list elements have the same D-Bus type. For
|
||
complex element types, we just check the container type, not
|
||
the whole element's signature. */
|
||
CHECK_CONS (object);
|
||
|
||
/* Type symbol is optional. */
|
||
if (EQ (QCarray, XCAR (elt)))
|
||
elt = XD_NEXT_VALUE (elt);
|
||
|
||
/* If the array is empty, DBUS_TYPE_STRING is the default
|
||
element type. */
|
||
if (NILP (elt))
|
||
{
|
||
subtype = DBUS_TYPE_STRING;
|
||
subsig = DBUS_TYPE_STRING_AS_STRING;
|
||
}
|
||
else
|
||
{
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
subsig = x;
|
||
}
|
||
|
||
/* If the element type is DBUS_TYPE_SIGNATURE, and this is the
|
||
only element, the value of this element is used as the
|
||
array's element signature. */
|
||
if (subtype == DBUS_TYPE_SIGNATURE)
|
||
{
|
||
Lisp_Object elt1 = XD_NEXT_VALUE (elt);
|
||
if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1)))
|
||
{
|
||
subsig = SSDATA (XCAR (elt1));
|
||
elt = Qnil;
|
||
}
|
||
}
|
||
|
||
while (!NILP (elt))
|
||
{
|
||
char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
if (strcmp (subsig, x) != 0)
|
||
wrong_type_argument (QD_Bus, CAR_SAFE (elt));
|
||
elt = CDR_SAFE (XD_NEXT_VALUE (elt));
|
||
}
|
||
|
||
signature[0] = dtype;
|
||
signature[1] = '\0';
|
||
xd_signature_cat (signature, subsig);
|
||
break;
|
||
|
||
case DBUS_TYPE_VARIANT:
|
||
/* Check that there is exactly one list element. */
|
||
CHECK_CONS (object);
|
||
|
||
elt = XD_NEXT_VALUE (elt);
|
||
CHECK_CONS (elt);
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
|
||
if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
|
||
wrong_type_argument (QD_Bus,
|
||
CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
|
||
|
||
sprintf (signature, "%c", dtype);
|
||
break;
|
||
|
||
case DBUS_TYPE_STRUCT:
|
||
/* A struct list might contain any (but zero) number of elements
|
||
with different types. No further check needed. */
|
||
CHECK_CONS (object);
|
||
|
||
elt = XD_NEXT_VALUE (elt);
|
||
CHECK_CONS (elt);
|
||
|
||
/* Compose the signature from the elements. It is enclosed by
|
||
parentheses. */
|
||
sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
|
||
while (!NILP (elt))
|
||
{
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
xd_signature_cat (signature, x);
|
||
elt = CDR_SAFE (XD_NEXT_VALUE (elt));
|
||
}
|
||
xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
|
||
break;
|
||
|
||
case DBUS_TYPE_DICT_ENTRY:
|
||
/* Check that there are exactly two list elements, and the first
|
||
one is of basic type. The dictionary entry itself must be an
|
||
element of an array. */
|
||
CHECK_CONS (object);
|
||
|
||
/* Check the parent object type. */
|
||
if (parent_type != DBUS_TYPE_ARRAY)
|
||
wrong_type_argument (QD_Bus, object);
|
||
|
||
/* Compose the signature from the elements. It is enclosed by
|
||
curly braces. */
|
||
sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
|
||
|
||
/* First element. */
|
||
elt = XD_NEXT_VALUE (elt);
|
||
CHECK_CONS (elt);
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
xd_signature_cat (signature, x);
|
||
|
||
if (!XD_BASIC_DBUS_TYPE (subtype))
|
||
wrong_type_argument (QD_Bus, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
|
||
/* Second element. */
|
||
elt = CDR_SAFE (XD_NEXT_VALUE (elt));
|
||
CHECK_CONS (elt);
|
||
subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
|
||
xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
|
||
xd_signature_cat (signature, x);
|
||
|
||
if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
|
||
wrong_type_argument (QD_Bus,
|
||
CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
|
||
|
||
/* Closing signature. */
|
||
xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
|
||
break;
|
||
|
||
default:
|
||
wrong_type_argument (QD_Bus, object);
|
||
}
|
||
|
||
XD_DEBUG_MESSAGE ("%s", signature);
|
||
}
|
||
|
||
/* Convert X to a signed integer with bounds LO and HI. */
|
||
static intmax_t
|
||
xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
|
||
{
|
||
CHECK_NUMBER (x);
|
||
if (INTEGERP (x))
|
||
{
|
||
intmax_t i;
|
||
if (integer_to_intmax (x, &i) && lo <= i && i <= hi)
|
||
return i;
|
||
}
|
||
else
|
||
{
|
||
double d = XFLOAT_DATA (x);
|
||
if (lo <= d && d < 1.0 + hi)
|
||
{
|
||
intmax_t n = d;
|
||
if (n == d)
|
||
return n;
|
||
}
|
||
}
|
||
|
||
if (xd_in_read_queued_messages)
|
||
Fthrow (Qdbus_error, Qnil);
|
||
else
|
||
args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi));
|
||
}
|
||
|
||
/* Convert X to an unsigned integer with bounds 0 and HI. */
|
||
static uintmax_t
|
||
xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
|
||
{
|
||
CHECK_NUMBER (x);
|
||
if (INTEGERP (x))
|
||
{
|
||
uintmax_t i;
|
||
if (integer_to_uintmax (x, &i) && i <= hi)
|
||
return i;
|
||
}
|
||
else
|
||
{
|
||
double d = XFLOAT_DATA (x);
|
||
if (0 <= d && d < 1.0 + hi)
|
||
{
|
||
uintmax_t n = d;
|
||
if (n == d)
|
||
return n;
|
||
}
|
||
}
|
||
|
||
if (xd_in_read_queued_messages)
|
||
Fthrow (Qdbus_error, Qnil);
|
||
else
|
||
args_out_of_range_3 (x, make_fixnum (0), INT_TO_INTEGER (hi));
|
||
}
|
||
|
||
/* Append C value, extracted from Lisp OBJECT, to iteration ITER.
|
||
DTYPE must be a valid DBusType. It is used to convert Lisp
|
||
objects, being arguments of `dbus-call-method' or
|
||
`dbus-send-signal', into corresponding C values appended as
|
||
arguments to a D-Bus message. */
|
||
static void
|
||
xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
|
||
{
|
||
char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
|
||
DBusMessageIter subiter;
|
||
|
||
if (XD_BASIC_DBUS_TYPE (dtype))
|
||
switch (dtype)
|
||
{
|
||
case DBUS_TYPE_BYTE:
|
||
CHECK_FIXNAT (object);
|
||
{
|
||
unsigned char val = XFIXNAT (object) & 0xFF;
|
||
XD_DEBUG_MESSAGE ("%c %u", dtype, val);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_BOOLEAN:
|
||
/* There must be an argument. */
|
||
if (EQ (QCboolean, object))
|
||
wrong_type_argument (Qbooleanp, object);
|
||
{
|
||
dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_INT16:
|
||
{
|
||
dbus_int16_t val =
|
||
xd_extract_signed (object,
|
||
TYPE_MINIMUM (dbus_int16_t),
|
||
TYPE_MAXIMUM (dbus_int16_t));
|
||
int pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_UINT16:
|
||
{
|
||
dbus_uint16_t val =
|
||
xd_extract_unsigned (object,
|
||
TYPE_MAXIMUM (dbus_uint16_t));
|
||
unsigned int pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_INT32:
|
||
{
|
||
dbus_int32_t val =
|
||
xd_extract_signed (object,
|
||
TYPE_MINIMUM (dbus_int32_t),
|
||
TYPE_MAXIMUM (dbus_int32_t));
|
||
int pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_UINT32:
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
case DBUS_TYPE_UNIX_FD:
|
||
#endif
|
||
{
|
||
dbus_uint32_t val =
|
||
xd_extract_unsigned (object,
|
||
TYPE_MAXIMUM (dbus_uint32_t));
|
||
unsigned int pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_INT64:
|
||
{
|
||
dbus_int64_t val =
|
||
xd_extract_signed (object,
|
||
TYPE_MINIMUM (dbus_int64_t),
|
||
TYPE_MAXIMUM (dbus_int64_t));
|
||
intmax_t pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_UINT64:
|
||
{
|
||
dbus_uint64_t val =
|
||
xd_extract_unsigned (object,
|
||
TYPE_MAXIMUM (dbus_uint64_t));
|
||
uintmax_t pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_DOUBLE:
|
||
{
|
||
double val = extract_float (object);
|
||
XD_DEBUG_MESSAGE ("%c %f", dtype, val);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
|
||
case DBUS_TYPE_STRING:
|
||
case DBUS_TYPE_OBJECT_PATH:
|
||
case DBUS_TYPE_SIGNATURE:
|
||
/* We don't check the syntax of signature. This will be done
|
||
by libdbus. */
|
||
if (dtype == DBUS_TYPE_OBJECT_PATH)
|
||
XD_DBUS_VALIDATE_PATH (object)
|
||
else
|
||
CHECK_STRING (object);
|
||
{
|
||
/* We need to send a valid UTF-8 string. We could encode `object'
|
||
but by not encoding it, we guarantee it's valid utf-8, even if
|
||
it contains eight-bit-bytes. Of course, you can still send
|
||
manually-crafted junk by passing a unibyte string. */
|
||
char *val = SSDATA (object);
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, val);
|
||
if (!dbus_message_iter_append_basic (iter, dtype, &val))
|
||
XD_SIGNAL2 (build_string ("Unable to append argument"), object);
|
||
return;
|
||
}
|
||
}
|
||
|
||
else /* Compound types. */
|
||
{
|
||
|
||
/* All compound types except array have a type symbol. For
|
||
array, it is optional. Skip it. */
|
||
if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
|
||
object = XD_NEXT_VALUE (object);
|
||
|
||
/* Open new subiteration. */
|
||
switch (dtype)
|
||
{
|
||
case DBUS_TYPE_ARRAY:
|
||
/* An array has only elements of the same type. So it is
|
||
sufficient to check the first element's signature
|
||
only. */
|
||
|
||
if (NILP (object))
|
||
/* If the array is empty, DBUS_TYPE_STRING is the default
|
||
element type. */
|
||
strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
|
||
|
||
else
|
||
{
|
||
/* If the element type is DBUS_TYPE_SIGNATURE, and this is
|
||
the only element, the value of this element is used as
|
||
the array's element signature. */
|
||
if (CONSP (object) && (XD_OBJECT_TO_DBUS_TYPE (XCAR (object))
|
||
== DBUS_TYPE_SIGNATURE))
|
||
{
|
||
Lisp_Object val = XD_NEXT_VALUE (object);
|
||
if (CONSP (val) && STRINGP (XCAR (val)) && NILP (XCDR (val))
|
||
&& SBYTES (XCAR (val)) < DBUS_MAXIMUM_SIGNATURE_LENGTH)
|
||
{
|
||
lispstpcpy (signature, XCAR (val));
|
||
object = Qnil;
|
||
}
|
||
}
|
||
|
||
if (!NILP (object))
|
||
xd_signature (signature,
|
||
XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
|
||
dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
|
||
}
|
||
|
||
XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
|
||
XD_OBJECT_TO_STRING (object));
|
||
if (!dbus_message_iter_open_container (iter, dtype,
|
||
signature, &subiter))
|
||
XD_SIGNAL3 (build_string ("Cannot open container"),
|
||
make_fixnum (dtype), build_string (signature));
|
||
break;
|
||
|
||
case DBUS_TYPE_VARIANT:
|
||
/* A variant has just one element. */
|
||
xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
|
||
dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
|
||
|
||
XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
|
||
XD_OBJECT_TO_STRING (object));
|
||
if (!dbus_message_iter_open_container (iter, dtype,
|
||
signature, &subiter))
|
||
XD_SIGNAL3 (build_string ("Cannot open container"),
|
||
make_fixnum (dtype), build_string (signature));
|
||
break;
|
||
|
||
case DBUS_TYPE_STRUCT:
|
||
case DBUS_TYPE_DICT_ENTRY:
|
||
/* These containers do not require a signature. */
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
|
||
if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
|
||
XD_SIGNAL2 (build_string ("Cannot open container"),
|
||
make_fixnum (dtype));
|
||
break;
|
||
}
|
||
|
||
/* Loop over list elements. */
|
||
while (!NILP (object))
|
||
{
|
||
dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
|
||
object = XD_NEXT_VALUE (object);
|
||
|
||
xd_append_arg (dtype, CAR_SAFE (object), &subiter);
|
||
|
||
object = CDR_SAFE (object);
|
||
}
|
||
|
||
/* Close the subiteration. */
|
||
if (!dbus_message_iter_close_container (iter, &subiter))
|
||
XD_SIGNAL2 (build_string ("Cannot close container"),
|
||
make_fixnum (dtype));
|
||
}
|
||
}
|
||
|
||
/* Retrieve C value from a DBusMessageIter structure ITER, and return
|
||
a converted Lisp object. The type DTYPE of the argument of the
|
||
D-Bus message must be a valid DBusType. Compound D-Bus types
|
||
result always in a Lisp list. */
|
||
static Lisp_Object
|
||
xd_retrieve_arg (int dtype, DBusMessageIter *iter)
|
||
{
|
||
|
||
switch (dtype)
|
||
{
|
||
case DBUS_TYPE_BYTE:
|
||
{
|
||
unsigned int val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
val = val & 0xFF;
|
||
XD_DEBUG_MESSAGE ("%c %u", dtype, val);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
|
||
}
|
||
|
||
case DBUS_TYPE_BOOLEAN:
|
||
{
|
||
dbus_bool_t val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
|
||
return list2 (xd_dbus_type_to_symbol (dtype),
|
||
(val == FALSE) ? Qnil : Qt);
|
||
}
|
||
|
||
case DBUS_TYPE_INT16:
|
||
{
|
||
dbus_int16_t val;
|
||
int pval;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
|
||
}
|
||
|
||
case DBUS_TYPE_UINT16:
|
||
{
|
||
dbus_uint16_t val;
|
||
int pval;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
|
||
}
|
||
|
||
case DBUS_TYPE_INT32:
|
||
{
|
||
dbus_int32_t val;
|
||
int pval;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
|
||
}
|
||
|
||
case DBUS_TYPE_UINT32:
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
case DBUS_TYPE_UNIX_FD:
|
||
#endif
|
||
{
|
||
dbus_uint32_t val;
|
||
unsigned int pval;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
|
||
}
|
||
|
||
case DBUS_TYPE_INT64:
|
||
{
|
||
dbus_int64_t val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
intmax_t pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
|
||
}
|
||
|
||
case DBUS_TYPE_UINT64:
|
||
{
|
||
dbus_uint64_t val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
uintmax_t pval = val;
|
||
XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
|
||
}
|
||
|
||
case DBUS_TYPE_DOUBLE:
|
||
{
|
||
double val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
XD_DEBUG_MESSAGE ("%c %f", dtype, val);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), make_float (val));
|
||
}
|
||
|
||
case DBUS_TYPE_STRING:
|
||
case DBUS_TYPE_OBJECT_PATH:
|
||
case DBUS_TYPE_SIGNATURE:
|
||
{
|
||
char *val;
|
||
dbus_message_iter_get_basic (iter, &val);
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, val);
|
||
return list2 (xd_dbus_type_to_symbol (dtype), build_string (val));
|
||
}
|
||
|
||
case DBUS_TYPE_ARRAY:
|
||
case DBUS_TYPE_VARIANT:
|
||
case DBUS_TYPE_STRUCT:
|
||
case DBUS_TYPE_DICT_ENTRY:
|
||
{
|
||
Lisp_Object result;
|
||
DBusMessageIter subiter;
|
||
int subtype;
|
||
result = Qnil;
|
||
dbus_message_iter_recurse (iter, &subiter);
|
||
while ((subtype = dbus_message_iter_get_arg_type (&subiter))
|
||
!= DBUS_TYPE_INVALID)
|
||
{
|
||
result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
|
||
dbus_message_iter_next (&subiter);
|
||
}
|
||
XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
|
||
return Fcons (xd_dbus_type_to_symbol (dtype), Fnreverse (result));
|
||
}
|
||
|
||
default:
|
||
XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
|
||
return Qnil;
|
||
}
|
||
}
|
||
|
||
/* Return the number of references of the shared CONNECTION. */
|
||
static ptrdiff_t
|
||
xd_get_connection_references (DBusConnection *connection)
|
||
{
|
||
ptrdiff_t *refcount;
|
||
|
||
/* We cannot access the DBusConnection structure, it is not public.
|
||
But we know, that the reference counter is the first field in
|
||
that structure. */
|
||
refcount = (void *) &connection;
|
||
refcount = (void *) *refcount;
|
||
return *refcount;
|
||
}
|
||
|
||
/* Convert a Lisp D-Bus object to a pointer. */
|
||
static DBusConnection *
|
||
xd_lisp_dbus_to_dbus (Lisp_Object bus)
|
||
{
|
||
return xmint_pointer (bus);
|
||
}
|
||
|
||
/* Return D-Bus connection address.
|
||
BUS is either a Lisp symbol, :system, :session, :system-private or
|
||
:session-private, or a string denoting the bus address. */
|
||
static DBusConnection *
|
||
xd_get_connection_address (Lisp_Object bus)
|
||
{
|
||
DBusConnection *connection;
|
||
Lisp_Object val;
|
||
|
||
val = CDR_SAFE (Fassoc (bus, xd_registered_buses, Qnil));
|
||
if (NILP (val))
|
||
XD_SIGNAL2 (build_string ("No connection to bus"), bus);
|
||
else
|
||
connection = xd_lisp_dbus_to_dbus (val);
|
||
|
||
if (!dbus_connection_get_is_connected (connection))
|
||
XD_SIGNAL2 (build_string ("No connection to bus"), bus);
|
||
|
||
return connection;
|
||
}
|
||
|
||
/* Return the file descriptor for WATCH, -1 if not found. */
|
||
static int
|
||
xd_find_watch_fd (DBusWatch *watch)
|
||
{
|
||
#if HAVE_DBUS_WATCH_GET_UNIX_FD
|
||
/* TODO: Reverse these on w32, which prefers the opposite. */
|
||
int fd = dbus_watch_get_unix_fd (watch);
|
||
if (fd == -1)
|
||
fd = dbus_watch_get_socket (watch);
|
||
#else
|
||
int fd = dbus_watch_get_fd (watch);
|
||
#endif
|
||
return fd;
|
||
}
|
||
|
||
/* Prototype. */
|
||
static void xd_read_queued_messages (int fd, void *data);
|
||
|
||
/* Start monitoring WATCH for possible I/O. */
|
||
static dbus_bool_t
|
||
xd_add_watch (DBusWatch *watch, void *data)
|
||
{
|
||
unsigned int flags = dbus_watch_get_flags (watch);
|
||
int fd = xd_find_watch_fd (watch);
|
||
|
||
XD_DEBUG_MESSAGE ("fd %d, write %u, enabled %u",
|
||
fd, flags & DBUS_WATCH_WRITABLE,
|
||
dbus_watch_get_enabled (watch));
|
||
|
||
if (fd == -1)
|
||
return FALSE;
|
||
|
||
if (dbus_watch_get_enabled (watch))
|
||
{
|
||
if (flags & DBUS_WATCH_WRITABLE)
|
||
add_write_fd (fd, xd_read_queued_messages, data);
|
||
if (flags & DBUS_WATCH_READABLE)
|
||
add_read_fd (fd, xd_read_queued_messages, data);
|
||
}
|
||
return TRUE;
|
||
}
|
||
|
||
/* Stop monitoring WATCH for possible I/O.
|
||
DATA is the used bus, either a string or QCsystem, QCsession,
|
||
QCsystem_private or QCsession_private. */
|
||
static void
|
||
xd_remove_watch (DBusWatch *watch, void *data)
|
||
{
|
||
unsigned int flags = dbus_watch_get_flags (watch);
|
||
int fd = xd_find_watch_fd (watch);
|
||
|
||
XD_DEBUG_MESSAGE ("fd %d", fd);
|
||
|
||
if (fd == -1)
|
||
return;
|
||
|
||
/* Unset session environment. */
|
||
#if 0
|
||
/* This is buggy, since unsetenv is not thread-safe. */
|
||
if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data)
|
||
{
|
||
XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
|
||
unsetenv ("DBUS_SESSION_BUS_ADDRESS");
|
||
}
|
||
#endif
|
||
|
||
if (flags & DBUS_WATCH_WRITABLE)
|
||
delete_write_fd (fd);
|
||
if (flags & DBUS_WATCH_READABLE)
|
||
delete_read_fd (fd);
|
||
}
|
||
|
||
/* Toggle monitoring WATCH for possible I/O. */
|
||
static void
|
||
xd_toggle_watch (DBusWatch *watch, void *data)
|
||
{
|
||
if (dbus_watch_get_enabled (watch))
|
||
xd_add_watch (watch, data);
|
||
else
|
||
xd_remove_watch (watch, data);
|
||
}
|
||
|
||
/* Close connection to D-Bus BUS. */
|
||
static void
|
||
xd_close_bus (Lisp_Object bus)
|
||
{
|
||
DBusConnection *connection;
|
||
Lisp_Object val;
|
||
Lisp_Object busobj;
|
||
|
||
/* Check whether we are connected. */
|
||
val = Fassoc (bus, xd_registered_buses, Qnil);
|
||
if (NILP (val))
|
||
return;
|
||
|
||
busobj = CDR_SAFE (val);
|
||
if (NILP (busobj)) {
|
||
xd_registered_buses = Fdelete (val, xd_registered_buses);
|
||
return;
|
||
}
|
||
|
||
/* Retrieve bus address. */
|
||
connection = xd_lisp_dbus_to_dbus (busobj);
|
||
|
||
if (xd_get_connection_references (connection) == 1)
|
||
{
|
||
/* Close connection, if there isn't another shared application. */
|
||
XD_DEBUG_MESSAGE ("Close connection to bus %s",
|
||
XD_OBJECT_TO_STRING (bus));
|
||
dbus_connection_close (connection);
|
||
|
||
xd_registered_buses = Fdelete (val, xd_registered_buses);
|
||
}
|
||
|
||
else
|
||
/* Decrement reference count. */
|
||
dbus_connection_unref (connection);
|
||
|
||
/* Return. */
|
||
return;
|
||
}
|
||
|
||
DEFUN ("dbus--init-bus", Fdbus__init_bus, Sdbus__init_bus, 1, 2, 0,
|
||
doc: /* Establish the connection to D-Bus BUS.
|
||
|
||
This function is dbus internal. You almost certainly want to use
|
||
`dbus-init-bus'.
|
||
|
||
BUS can be either the symbol `:system' or the symbol `:session', or it
|
||
can be a string denoting the address of the corresponding bus. For
|
||
the system and session buses, this function is called when loading
|
||
`dbus.el', there is no need to call it again.
|
||
|
||
A special case is BUS being the symbol `:system-private' or
|
||
`:session-private'. These symbols still denote the system or session
|
||
bus, but using a private connection. They should not be used outside
|
||
dbus.el.
|
||
|
||
The function returns a number, which counts the connections this Emacs
|
||
session has established to the BUS under the same unique name (see
|
||
`dbus-get-unique-name'). It depends on the libraries Emacs is linked
|
||
with, and on the environment Emacs is running. For example, if Emacs
|
||
is linked with the gtk toolkit, and it runs in a GTK-aware environment
|
||
like Gnome, another connection might already be established.
|
||
|
||
When PRIVATE is non-nil, a new connection is established instead of
|
||
reusing an existing one. It results in a new unique name at the bus.
|
||
This can be used, if it is necessary to distinguish from another
|
||
connection used in the same Emacs process, like the one established by
|
||
GTK+. It should be used with care for at least the `:system' and
|
||
`:session' buses, because other Emacs Lisp packages might already use
|
||
this connection to those buses. */)
|
||
(Lisp_Object bus, Lisp_Object private)
|
||
{
|
||
DBusConnection *connection;
|
||
DBusError derror;
|
||
Lisp_Object val;
|
||
ptrdiff_t refcount;
|
||
|
||
/* Check parameter. */
|
||
if (!NILP (private))
|
||
bus = EQ (bus, QCsystem)
|
||
? QCsystem_private
|
||
: EQ (bus, QCsession) ? QCsession_private : bus;
|
||
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
|
||
|
||
/* Close bus if it is already open. */
|
||
xd_close_bus (bus);
|
||
|
||
/* Check, whether we are still connected. */
|
||
val = Fassoc (bus, xd_registered_buses, Qnil);
|
||
if (!NILP (val))
|
||
{
|
||
connection = xd_get_connection_address (bus);
|
||
dbus_connection_ref (connection);
|
||
}
|
||
|
||
else
|
||
{
|
||
/* Initialize. */
|
||
dbus_error_init (&derror);
|
||
|
||
/* Open the connection. */
|
||
if (STRINGP (bus))
|
||
if (NILP (private))
|
||
connection = dbus_connection_open (SSDATA (bus), &derror);
|
||
else
|
||
connection = dbus_connection_open_private (SSDATA (bus), &derror);
|
||
|
||
else
|
||
{
|
||
DBusBusType bustype
|
||
= EQ (bus, QCsystem) || EQ (bus, QCsystem_private)
|
||
? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION;
|
||
if (NILP (private))
|
||
connection = dbus_bus_get (bustype, &derror);
|
||
else
|
||
connection = dbus_bus_get_private (bustype, &derror);
|
||
}
|
||
|
||
if (dbus_error_is_set (&derror))
|
||
XD_ERROR (derror);
|
||
|
||
if (connection == NULL)
|
||
XD_SIGNAL2 (build_string ("No connection to bus"), bus);
|
||
|
||
/* If it is not the system or session bus, we must register
|
||
ourselves. Otherwise, we have called dbus_bus_get{_private},
|
||
which has configured us to exit if the connection closes - we
|
||
undo this setting. */
|
||
if (STRINGP (bus))
|
||
dbus_bus_register (connection, &derror);
|
||
else
|
||
dbus_connection_set_exit_on_disconnect (connection, FALSE);
|
||
|
||
if (dbus_error_is_set (&derror))
|
||
XD_ERROR (derror);
|
||
|
||
/* Add the watch functions. We pass also the bus as data, in
|
||
order to distinguish between the buses in xd_remove_watch. */
|
||
if (!dbus_connection_set_watch_functions (connection,
|
||
xd_add_watch,
|
||
xd_remove_watch,
|
||
xd_toggle_watch,
|
||
XD_KEYWORDP (bus)
|
||
? (void *) XSYMBOL (bus)
|
||
: (void *) XSTRING (bus),
|
||
NULL))
|
||
XD_SIGNAL1 (build_string ("Cannot add watch functions"));
|
||
|
||
/* Add bus to list of registered buses. */
|
||
val = make_mint_ptr (connection);
|
||
xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
|
||
|
||
/* Cleanup. */
|
||
dbus_error_free (&derror);
|
||
}
|
||
|
||
XD_DEBUG_MESSAGE ("Registered buses: %s",
|
||
XD_OBJECT_TO_STRING (xd_registered_buses));
|
||
|
||
/* Return reference counter. */
|
||
refcount = xd_get_connection_references (connection);
|
||
XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
|
||
XD_OBJECT_TO_STRING (bus), refcount);
|
||
return make_fixnum (refcount);
|
||
}
|
||
|
||
DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
|
||
1, 1, 0,
|
||
doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
|
||
(Lisp_Object bus)
|
||
{
|
||
DBusConnection *connection;
|
||
const char *name;
|
||
|
||
/* Check parameter. */
|
||
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
|
||
|
||
/* Retrieve bus address. */
|
||
connection = xd_get_connection_address (bus);
|
||
|
||
/* Request the name. */
|
||
name = dbus_bus_get_unique_name (connection);
|
||
if (name == NULL)
|
||
XD_SIGNAL1 (build_string ("No unique name available"));
|
||
|
||
/* Return. */
|
||
return build_string (name);
|
||
}
|
||
|
||
DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
|
||
4, MANY, 0,
|
||
doc: /* Send a D-Bus message.
|
||
This is an internal function, it shall not be used outside dbus.el.
|
||
|
||
The following usages are expected:
|
||
|
||
`dbus-call-method', `dbus-call-method-asynchronously':
|
||
(dbus-message-internal
|
||
dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
|
||
&optional :timeout TIMEOUT &rest ARGS)
|
||
|
||
`dbus-send-signal':
|
||
(dbus-message-internal
|
||
dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
|
||
|
||
`dbus-method-return-internal':
|
||
(dbus-message-internal
|
||
dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
|
||
|
||
`dbus-method-error-internal':
|
||
(dbus-message-internal
|
||
dbus-message-type-error BUS SERVICE SERIAL ERROR-NAME &rest ARGS)
|
||
|
||
`dbus-check-arguments': (does not send a message)
|
||
(dbus-message-internal
|
||
dbus-message-type-invalid BUS SERVICE &rest ARGS)
|
||
|
||
usage: (dbus-message-internal &rest REST) */)
|
||
(ptrdiff_t nargs, Lisp_Object *args)
|
||
{
|
||
Lisp_Object message_type, bus, service, handler;
|
||
Lisp_Object path = Qnil;
|
||
Lisp_Object interface = Qnil;
|
||
Lisp_Object member = Qnil;
|
||
Lisp_Object error_name = Qnil;
|
||
Lisp_Object result;
|
||
DBusConnection *connection;
|
||
DBusMessage *dmessage;
|
||
DBusMessageIter iter;
|
||
int dtype;
|
||
int mtype;
|
||
dbus_uint32_t serial = 0;
|
||
unsigned int ui_serial;
|
||
int timeout = -1;
|
||
ptrdiff_t count, count0;
|
||
char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
|
||
|
||
/* Initialize parameters. */
|
||
message_type = args[0];
|
||
bus = args[1];
|
||
service = args[2];
|
||
handler = Qnil;
|
||
|
||
CHECK_FIXNAT (message_type);
|
||
if (! (DBUS_MESSAGE_TYPE_INVALID <= XFIXNAT (message_type)
|
||
&& XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES))
|
||
XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
|
||
mtype = XFIXNAT (message_type);
|
||
|
||
if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
|
||
{
|
||
path = args[3];
|
||
interface = args[4];
|
||
member = args[5];
|
||
if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|
||
handler = args[6];
|
||
count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
|
||
}
|
||
else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
|
||
{
|
||
serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
|
||
if (mtype == DBUS_MESSAGE_TYPE_ERROR)
|
||
error_name = args[4];
|
||
count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4;
|
||
}
|
||
else /* DBUS_MESSAGE_TYPE_INVALID */
|
||
count = 3;
|
||
|
||
/* Check parameters. */
|
||
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
|
||
XD_DBUS_VALIDATE_BUS_NAME (service);
|
||
if (nargs < count)
|
||
xsignal2 (Qwrong_number_of_arguments,
|
||
Qdbus_message_internal,
|
||
make_fixnum (nargs));
|
||
|
||
if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
|
||
{
|
||
XD_DBUS_VALIDATE_PATH (path);
|
||
XD_DBUS_VALIDATE_INTERFACE (interface);
|
||
XD_DBUS_VALIDATE_MEMBER (member);
|
||
if (!NILP (handler) && !FUNCTIONP (handler))
|
||
wrong_type_argument (Qinvalid_function, handler);
|
||
}
|
||
|
||
/* Trace parameters. */
|
||
switch (mtype)
|
||
{
|
||
case DBUS_MESSAGE_TYPE_METHOD_CALL:
|
||
XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
XD_OBJECT_TO_STRING (bus),
|
||
XD_OBJECT_TO_STRING (service),
|
||
XD_OBJECT_TO_STRING (path),
|
||
XD_OBJECT_TO_STRING (interface),
|
||
XD_OBJECT_TO_STRING (member),
|
||
XD_OBJECT_TO_STRING (handler));
|
||
break;
|
||
case DBUS_MESSAGE_TYPE_SIGNAL:
|
||
XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
XD_OBJECT_TO_STRING (bus),
|
||
XD_OBJECT_TO_STRING (service),
|
||
XD_OBJECT_TO_STRING (path),
|
||
XD_OBJECT_TO_STRING (interface),
|
||
XD_OBJECT_TO_STRING (member));
|
||
break;
|
||
case DBUS_MESSAGE_TYPE_METHOD_RETURN:
|
||
ui_serial = serial;
|
||
XD_DEBUG_MESSAGE ("%s %s %s %u",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
XD_OBJECT_TO_STRING (bus),
|
||
XD_OBJECT_TO_STRING (service),
|
||
ui_serial);
|
||
break;
|
||
case DBUS_MESSAGE_TYPE_ERROR:
|
||
ui_serial = serial;
|
||
XD_DEBUG_MESSAGE ("%s %s %s %u %s",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
XD_OBJECT_TO_STRING (bus),
|
||
XD_OBJECT_TO_STRING (service),
|
||
ui_serial,
|
||
XD_OBJECT_TO_STRING (error_name));
|
||
break;
|
||
default: /* DBUS_MESSAGE_TYPE_INVALID */
|
||
XD_DEBUG_MESSAGE ("%s %s %s",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
XD_OBJECT_TO_STRING (bus),
|
||
XD_OBJECT_TO_STRING (service));
|
||
}
|
||
|
||
/* Retrieve bus address. */
|
||
connection = xd_get_connection_address (bus);
|
||
|
||
/* Create the D-Bus message. Since DBUS_MESSAGE_TYPE_INVALID is not
|
||
a valid message type, we mockup it with DBUS_MESSAGE_TYPE_SIGNAL. */
|
||
dmessage = dbus_message_new
|
||
((mtype == DBUS_MESSAGE_TYPE_INVALID) ? DBUS_MESSAGE_TYPE_SIGNAL : mtype);
|
||
if (dmessage == NULL)
|
||
XD_SIGNAL1 (build_string ("Unable to create a new message"));
|
||
|
||
if ((STRINGP (service)) && (mtype != DBUS_MESSAGE_TYPE_INVALID))
|
||
{
|
||
if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
|
||
/* Set destination. */
|
||
{
|
||
if (!dbus_message_set_destination (dmessage, SSDATA (service)))
|
||
XD_SIGNAL2 (build_string ("Unable to set the destination"),
|
||
service);
|
||
}
|
||
|
||
else
|
||
/* Set destination for unicast signals. */
|
||
{
|
||
Lisp_Object uname;
|
||
|
||
/* If it is the same unique name as we are registered at the
|
||
bus or an unknown name, we regard it as broadcast message
|
||
due to backward compatibility. */
|
||
if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
|
||
uname = call2 (Qdbus_get_name_owner, bus, service);
|
||
else
|
||
uname = Qnil;
|
||
|
||
if (STRINGP (uname)
|
||
&& (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
|
||
!= 0)
|
||
&& (!dbus_message_set_destination (dmessage, SSDATA (service))))
|
||
XD_SIGNAL2 (build_string ("Unable to set signal destination"),
|
||
service);
|
||
}
|
||
}
|
||
|
||
/* Set message parameters. */
|
||
if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
|
||
{
|
||
if ((!dbus_message_set_path (dmessage, SSDATA (path)))
|
||
|| (!dbus_message_set_interface (dmessage, SSDATA (interface)))
|
||
|| (!dbus_message_set_member (dmessage, SSDATA (member))))
|
||
XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
|
||
}
|
||
|
||
else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
|
||
{
|
||
if (!dbus_message_set_reply_serial (dmessage, serial))
|
||
XD_SIGNAL1 (build_string ("Unable to create a return message"));
|
||
|
||
if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
|
||
&& (!dbus_message_set_error_name (dmessage, SSDATA (error_name))))
|
||
XD_SIGNAL1 (build_string ("Unable to create an error message"));
|
||
}
|
||
|
||
/* Check for timeout parameter. */
|
||
if ((count + 2 <= nargs) && EQ (args[count], QCtimeout))
|
||
{
|
||
CHECK_FIXNAT (args[count+1]);
|
||
timeout = min (XFIXNAT (args[count+1]), INT_MAX);
|
||
count = count+2;
|
||
}
|
||
|
||
/* Initialize parameter list of message. */
|
||
dbus_message_iter_init_append (dmessage, &iter);
|
||
|
||
/* Append parameters to the message. */
|
||
count0 = count - 1;
|
||
for (; count < nargs; ++count)
|
||
{
|
||
dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
|
||
if (count + 1 < nargs && XD_DBUS_TYPE_P (args[count]))
|
||
{
|
||
XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
|
||
XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
|
||
XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s Parameter%"pD"d: %s",
|
||
count - count0,
|
||
XD_OBJECT_TO_STRING (args[count]),
|
||
count + 1 - count0,
|
||
XD_OBJECT_TO_STRING (args[count+1]));
|
||
++count;
|
||
}
|
||
else
|
||
{
|
||
XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
|
||
XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s", count - count0,
|
||
XD_OBJECT_TO_STRING (args[count]));
|
||
}
|
||
|
||
/* Check for valid signature. We use DBUS_TYPE_INVALID as
|
||
indication that there is no parent type. */
|
||
xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
|
||
|
||
xd_append_arg (dtype, args[count], &iter);
|
||
}
|
||
|
||
if (mtype == DBUS_MESSAGE_TYPE_INVALID)
|
||
result = Qt;
|
||
|
||
else if (!NILP (handler))
|
||
{
|
||
/* Send the message. The message is just added to the outgoing
|
||
message queue. */
|
||
if (!dbus_connection_send_with_reply (connection, dmessage,
|
||
NULL, timeout))
|
||
XD_SIGNAL1 (build_string ("Cannot send message"));
|
||
|
||
/* The result is the key in Vdbus_registered_objects_table. */
|
||
serial = dbus_message_get_serial (dmessage);
|
||
result = list3 (QCserial, bus, INT_TO_INTEGER (serial));
|
||
|
||
/* Create a hash table entry. */
|
||
Fputhash (result, handler, Vdbus_registered_objects_table);
|
||
}
|
||
else
|
||
{
|
||
/* Send the message. The message is just added to the outgoing
|
||
message queue. */
|
||
if (!dbus_connection_send (connection, dmessage, NULL))
|
||
XD_SIGNAL1 (build_string ("Cannot send message"));
|
||
|
||
result = Qnil;
|
||
}
|
||
|
||
if (mtype != DBUS_MESSAGE_TYPE_INVALID)
|
||
XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
|
||
|
||
/* Cleanup. */
|
||
dbus_message_unref (dmessage);
|
||
|
||
/* Return the result. */
|
||
return result;
|
||
}
|
||
|
||
/* Read one queued incoming message of the D-Bus BUS.
|
||
BUS is either a Lisp symbol, :system, :session, :system-private or
|
||
:session-private, or a string denoting the bus address. */
|
||
static void
|
||
xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
|
||
{
|
||
Lisp_Object args, key, value;
|
||
struct input_event event;
|
||
DBusMessage *dmessage;
|
||
DBusMessageIter iter;
|
||
int dtype;
|
||
int mtype;
|
||
dbus_uint32_t serial;
|
||
unsigned int ui_serial;
|
||
const char *uname, *destination, *path, *interface, *member, *error_name;
|
||
|
||
dmessage = dbus_connection_pop_message (connection);
|
||
|
||
/* Return if there is no queued message. */
|
||
if (dmessage == NULL)
|
||
return;
|
||
|
||
/* Collect the parameters. */
|
||
args = Qnil;
|
||
|
||
/* Loop over the resulting parameters. Construct a list. */
|
||
if (dbus_message_iter_init (dmessage, &iter))
|
||
{
|
||
while ((dtype = dbus_message_iter_get_arg_type (&iter))
|
||
!= DBUS_TYPE_INVALID)
|
||
{
|
||
args = Fcons (xd_retrieve_arg (dtype, &iter), args);
|
||
dbus_message_iter_next (&iter);
|
||
}
|
||
/* The arguments are stored in reverse order. Reorder them. */
|
||
args = Fnreverse (args);
|
||
}
|
||
|
||
/* Read message type, message serial, unique name, object path,
|
||
interface, member and error name from the message. */
|
||
mtype = dbus_message_get_type (dmessage);
|
||
ui_serial = serial =
|
||
((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
|
||
? dbus_message_get_reply_serial (dmessage)
|
||
: dbus_message_get_serial (dmessage);
|
||
uname = dbus_message_get_sender (dmessage);
|
||
destination = dbus_message_get_destination (dmessage);
|
||
path = dbus_message_get_path (dmessage);
|
||
interface = dbus_message_get_interface (dmessage);
|
||
member = dbus_message_get_member (dmessage);
|
||
error_name = dbus_message_get_error_name (dmessage);
|
||
|
||
XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s",
|
||
XD_MESSAGE_TYPE_TO_STRING (mtype),
|
||
ui_serial, uname, destination, path, interface,
|
||
mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member,
|
||
XD_OBJECT_TO_STRING (args));
|
||
|
||
if (mtype == DBUS_MESSAGE_TYPE_INVALID)
|
||
goto cleanup;
|
||
|
||
else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
|
||
|| (mtype == DBUS_MESSAGE_TYPE_ERROR))
|
||
{
|
||
/* Search for a registered function of the message. */
|
||
key = list3 (QCserial, bus, INT_TO_INTEGER (serial));
|
||
value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
|
||
|
||
/* There shall be exactly one entry. Construct an event. */
|
||
if (NILP (value))
|
||
goto monitor;
|
||
|
||
/* Remove the entry. */
|
||
Fremhash (key, Vdbus_registered_objects_table);
|
||
|
||
/* Construct an event. */
|
||
EVENT_INIT (event);
|
||
event.kind = DBUS_EVENT;
|
||
event.frame_or_window = Qnil;
|
||
/* Handler. */
|
||
event.arg = Fcons (value, args);
|
||
}
|
||
|
||
else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
|
||
{
|
||
/* Vdbus_registered_objects_table requires non-nil interface and
|
||
member. */
|
||
if ((interface == NULL) || (member == NULL))
|
||
goto monitor;
|
||
|
||
/* Search for a registered function of the message. */
|
||
key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal,
|
||
bus, build_string (interface), build_string (member));
|
||
value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
|
||
|
||
/* A signal could be registered with a nil interface or member. */
|
||
if (mtype == DBUS_MESSAGE_TYPE_SIGNAL)
|
||
{
|
||
key = list4 (QCsignal, bus, Qnil, build_string (member));
|
||
value = CALLN (Fappend, value,
|
||
Fgethash (key, Vdbus_registered_objects_table, Qnil));
|
||
|
||
key = list4 (QCsignal, bus, build_string (interface), Qnil);
|
||
value = CALLN (Fappend, value,
|
||
Fgethash (key, Vdbus_registered_objects_table, Qnil));
|
||
|
||
key = list4 (QCsignal, bus, Qnil, Qnil);
|
||
value = CALLN (Fappend, value,
|
||
Fgethash (key, Vdbus_registered_objects_table, Qnil));
|
||
}
|
||
|
||
/* Loop over the registered functions. Construct an event. */
|
||
for (; !NILP (value); value = CDR_SAFE (value))
|
||
{
|
||
key = CAR_SAFE (value);
|
||
Lisp_Object key_uname = CAR_SAFE (key);
|
||
/* key has the structure (UNAME SERVICE PATH HANDLER). */
|
||
if (uname && !NILP (key_uname)
|
||
&& strcmp (uname, SSDATA (key_uname)) != 0)
|
||
continue;
|
||
Lisp_Object key_service_etc = CDR_SAFE (key);
|
||
Lisp_Object key_path_etc = CDR_SAFE (key_service_etc);
|
||
Lisp_Object key_path = CAR_SAFE (key_path_etc);
|
||
if (path && !NILP (key_path)
|
||
&& strcmp (path, SSDATA (key_path)) != 0)
|
||
continue;
|
||
Lisp_Object handler = CAR_SAFE (CDR_SAFE (key_path_etc));
|
||
if (NILP (handler))
|
||
continue;
|
||
|
||
/* Construct an event and exit the loop. */
|
||
EVENT_INIT (event);
|
||
event.kind = DBUS_EVENT;
|
||
event.frame_or_window = Qnil;
|
||
event.arg = Fcons (handler, args);
|
||
break;
|
||
}
|
||
|
||
if (NILP (value))
|
||
goto monitor;
|
||
}
|
||
|
||
/* Add type, serial, uname, destination, path, interface and member
|
||
or error_name to the event. */
|
||
event.arg
|
||
= Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
|
||
? error_name == NULL ? Qnil : build_string (error_name)
|
||
: member == NULL ? Qnil : build_string (member),
|
||
event.arg);
|
||
event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
|
||
event.arg);
|
||
event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
|
||
event.arg);
|
||
event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
|
||
event.arg);
|
||
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
|
||
event.arg);
|
||
event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
|
||
event.arg = Fcons (make_fixnum (mtype), event.arg);
|
||
|
||
/* Add the bus symbol to the event. */
|
||
event.arg = Fcons (bus, event.arg);
|
||
|
||
/* Store it into the input event queue. */
|
||
kbd_buffer_store_event (&event);
|
||
|
||
XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
|
||
|
||
/* Monitor. */
|
||
monitor:
|
||
/* Search for a registered function of the message. */
|
||
key = list2 (QCmonitor, bus);
|
||
value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
|
||
|
||
/* There shall be exactly one entry. Construct an event. */
|
||
if (NILP (value))
|
||
goto cleanup;
|
||
|
||
/* Construct an event. */
|
||
EVENT_INIT (event);
|
||
event.kind = DBUS_EVENT;
|
||
event.frame_or_window = Qnil;
|
||
|
||
/* Add type, serial, uname, destination, path, interface, member
|
||
or error_name and handler to the event. */
|
||
event.arg
|
||
= Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))),
|
||
args);
|
||
event.arg
|
||
= Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
|
||
? error_name == NULL ? Qnil : build_string (error_name)
|
||
: member == NULL ? Qnil : build_string (member),
|
||
event.arg);
|
||
event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
|
||
event.arg);
|
||
event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
|
||
event.arg);
|
||
event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
|
||
event.arg);
|
||
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
|
||
event.arg);
|
||
event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
|
||
event.arg = Fcons (make_fixnum (mtype), event.arg);
|
||
|
||
/* Add the bus symbol to the event. */
|
||
event.arg = Fcons (bus, event.arg);
|
||
|
||
/* Store it into the input event queue. */
|
||
kbd_buffer_store_event (&event);
|
||
|
||
XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg));
|
||
|
||
/* Cleanup. */
|
||
cleanup:
|
||
dbus_message_unref (dmessage);
|
||
}
|
||
|
||
/* Read queued incoming messages of the D-Bus BUS.
|
||
BUS is either a Lisp symbol, :system, :session, :system-private or
|
||
:session-private, or a string denoting the bus address. */
|
||
static Lisp_Object
|
||
xd_read_message (Lisp_Object bus)
|
||
{
|
||
/* Retrieve bus address. */
|
||
DBusConnection *connection = xd_get_connection_address (bus);
|
||
|
||
/* Non blocking read of the next available message. */
|
||
dbus_connection_read_write (connection, 0);
|
||
|
||
while (dbus_connection_get_dispatch_status (connection)
|
||
!= DBUS_DISPATCH_COMPLETE)
|
||
xd_read_message_1 (connection, bus);
|
||
return Qnil;
|
||
}
|
||
|
||
/* Callback called when something is ready to read or write. */
|
||
static void
|
||
xd_read_queued_messages (int fd, void *data)
|
||
{
|
||
Lisp_Object busp = xd_registered_buses;
|
||
Lisp_Object bus = Qnil;
|
||
Lisp_Object key;
|
||
|
||
/* Find bus related to fd. */
|
||
if (data != NULL)
|
||
while (!NILP (busp))
|
||
{
|
||
key = CAR_SAFE (CAR_SAFE (busp));
|
||
if ((XD_KEYWORDP (key) && XSYMBOL (key) == data)
|
||
|| (STRINGP (key) && XSTRING (key) == data))
|
||
bus = key;
|
||
busp = CDR_SAFE (busp);
|
||
}
|
||
|
||
if (NILP (bus))
|
||
return;
|
||
|
||
/* We ignore all Lisp errors during the call. */
|
||
xd_in_read_queued_messages = 1;
|
||
internal_catch (Qdbus_error, xd_read_message, bus);
|
||
xd_in_read_queued_messages = 0;
|
||
}
|
||
|
||
|
||
void
|
||
init_dbusbind (void)
|
||
{
|
||
/* We do not want to abort. */
|
||
xputenv ("DBUS_FATAL_WARNINGS=0");
|
||
}
|
||
|
||
static void
|
||
syms_of_dbusbind_for_pdumper (void)
|
||
{
|
||
xd_registered_buses = Qnil;
|
||
}
|
||
|
||
void
|
||
syms_of_dbusbind (void)
|
||
{
|
||
defsubr (&Sdbus__init_bus);
|
||
defsubr (&Sdbus_get_unique_name);
|
||
|
||
DEFSYM (Qdbus_message_internal, "dbus-message-internal");
|
||
defsubr (&Sdbus_message_internal);
|
||
|
||
/* D-Bus error symbol. */
|
||
DEFSYM (Qdbus_error, "dbus-error");
|
||
Fput (Qdbus_error, Qerror_conditions,
|
||
list2 (Qdbus_error, Qerror));
|
||
Fput (Qdbus_error, Qerror_message,
|
||
build_pure_c_string ("D-Bus error"));
|
||
DEFSYM (QD_Bus, "D-Bus");
|
||
|
||
/* Lisp symbols of the system and session buses. */
|
||
DEFSYM (QCsystem, ":system");
|
||
DEFSYM (QCsession, ":session");
|
||
DEFSYM (QCsystem_private, ":system-private");
|
||
DEFSYM (QCsession_private, ":session-private");
|
||
|
||
/* Lisp symbol for method call timeout. */
|
||
DEFSYM (QCtimeout, ":timeout");
|
||
|
||
/* Lisp symbols of D-Bus types. */
|
||
DEFSYM (QCbyte, ":byte");
|
||
DEFSYM (QCboolean, ":boolean");
|
||
DEFSYM (QCint16, ":int16");
|
||
DEFSYM (QCuint16, ":uint16");
|
||
DEFSYM (QCint32, ":int32");
|
||
DEFSYM (QCuint32, ":uint32");
|
||
DEFSYM (QCint64, ":int64");
|
||
DEFSYM (QCuint64, ":uint64");
|
||
DEFSYM (QCdouble, ":double");
|
||
DEFSYM (QCstring, ":string");
|
||
DEFSYM (QCobject_path, ":object-path");
|
||
DEFSYM (QCsignature, ":signature");
|
||
#ifdef DBUS_TYPE_UNIX_FD
|
||
DEFSYM (QCunix_fd, ":unix-fd");
|
||
#endif
|
||
DEFSYM (QCarray, ":array");
|
||
DEFSYM (QCvariant, ":variant");
|
||
DEFSYM (QCstruct, ":struct");
|
||
DEFSYM (QCdict_entry, ":dict-entry");
|
||
|
||
/* Lisp symbols of objects in `dbus-registered-objects-table'.
|
||
`:property', which does exist there as well, is not declared here. */
|
||
DEFSYM (QCserial, ":serial");
|
||
DEFSYM (QCmethod, ":method");
|
||
DEFSYM (QCsignal, ":signal");
|
||
DEFSYM (QCmonitor, ":monitor");
|
||
|
||
/* Miscellaneous Lisp symbols. */
|
||
DEFSYM (Qdbus_get_name_owner, "dbus-get-name-owner");
|
||
|
||
DEFVAR_LISP ("dbus-compiled-version",
|
||
Vdbus_compiled_version,
|
||
doc: /* The version of D-Bus Emacs is compiled against. */);
|
||
#ifdef DBUS_VERSION_STRING
|
||
Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
|
||
#else
|
||
Vdbus_compiled_version = Qnil;
|
||
#endif
|
||
|
||
DEFVAR_LISP ("dbus-runtime-version",
|
||
Vdbus_runtime_version,
|
||
doc: /* The version of D-Bus Emacs runs with. */);
|
||
{
|
||
#ifdef DBUS_VERSION
|
||
int major, minor, micro;
|
||
char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
|
||
dbus_get_version (&major, &minor, µ);
|
||
Vdbus_runtime_version
|
||
= make_formatted_string (s, "%d.%d.%d", major, minor, micro);
|
||
#else
|
||
Vdbus_runtime_version = Qnil;
|
||
#endif
|
||
}
|
||
|
||
DEFVAR_LISP ("dbus-message-type-invalid",
|
||
Vdbus_message_type_invalid,
|
||
doc: /* This value is never a valid message type. */);
|
||
Vdbus_message_type_invalid = make_fixnum (DBUS_MESSAGE_TYPE_INVALID);
|
||
|
||
DEFVAR_LISP ("dbus-message-type-method-call",
|
||
Vdbus_message_type_method_call,
|
||
doc: /* Message type of a method call message. */);
|
||
Vdbus_message_type_method_call = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_CALL);
|
||
|
||
DEFVAR_LISP ("dbus-message-type-method-return",
|
||
Vdbus_message_type_method_return,
|
||
doc: /* Message type of a method return message. */);
|
||
Vdbus_message_type_method_return
|
||
= make_fixnum (DBUS_MESSAGE_TYPE_METHOD_RETURN);
|
||
|
||
DEFVAR_LISP ("dbus-message-type-error",
|
||
Vdbus_message_type_error,
|
||
doc: /* Message type of an error reply message. */);
|
||
Vdbus_message_type_error = make_fixnum (DBUS_MESSAGE_TYPE_ERROR);
|
||
|
||
DEFVAR_LISP ("dbus-message-type-signal",
|
||
Vdbus_message_type_signal,
|
||
doc: /* Message type of a signal message. */);
|
||
Vdbus_message_type_signal = make_fixnum (DBUS_MESSAGE_TYPE_SIGNAL);
|
||
|
||
DEFVAR_LISP ("dbus-registered-objects-table",
|
||
Vdbus_registered_objects_table,
|
||
doc: /* Hash table of registered functions for D-Bus.
|
||
|
||
There are two different uses of the hash table: for accessing
|
||
registered interfaces properties, targeted by signals, method calls or
|
||
monitors, and for calling handlers in case of non-blocking method call
|
||
returns.
|
||
|
||
In the first case, the key in the hash table is the list (TYPE BUS
|
||
[INTERFACE MEMBER]). TYPE is one of the Lisp symbols `:method',
|
||
`:signal', `:property' or `:monitor'. BUS is either a Lisp symbol,
|
||
`:system', `:session', `:system-private' or `:session-private', or a
|
||
string denoting the bus address. INTERFACE is a string which denotes
|
||
a D-Bus interface, and MEMBER, also a string, is either a method, a
|
||
signal or a property INTERFACE is offering. All arguments can be nil.
|
||
|
||
The value in the hash table is a list of quadruple lists ((UNAME
|
||
SERVICE PATH OBJECT [RULE]) ...). SERVICE is the service name as
|
||
registered, UNAME is the corresponding unique name. In case of
|
||
registered methods, properties and monitors, UNAME is nil. PATH is
|
||
the object path of the sending object. All of them can be nil, which
|
||
means a wildcard then.
|
||
|
||
OBJECT is either the handler to be called when a D-Bus message, which
|
||
matches the key criteria, arrives (TYPE `:method', `:signal' and
|
||
`:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE
|
||
`:property'.
|
||
|
||
For entries of type `:signal' or `:monitor', there is also a fifth
|
||
element RULE, which keeps the match string the signal or monitor is
|
||
registered with.
|
||
|
||
In the second case, the key in the hash table is the list (:serial BUS
|
||
SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a
|
||
string denoting the bus address. SERIAL is the serial number of the
|
||
non-blocking method call, a reply is expected. Both arguments must
|
||
not be nil. The value in the hash table is HANDLER, the function to
|
||
be called when the D-Bus reply message arrives. */);
|
||
Vdbus_registered_objects_table = CALLN (Fmake_hash_table, QCtest, Qequal);
|
||
|
||
DEFVAR_LISP ("dbus-debug", Vdbus_debug,
|
||
doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
|
||
#ifdef DBUS_DEBUG
|
||
Vdbus_debug = Qt;
|
||
/* We can also set environment variable DBUS_VERBOSE=1 in order to
|
||
see more traces. This requires libdbus-1 to be configured with
|
||
--enable-verbose-mode. */
|
||
#else
|
||
Vdbus_debug = Qnil;
|
||
#endif
|
||
|
||
/* Initialize internal objects. */
|
||
pdumper_do_now_and_after_load (syms_of_dbusbind_for_pdumper);
|
||
staticpro (&xd_registered_buses);
|
||
|
||
Fprovide (intern_c_string ("dbusbind"), Qnil);
|
||
}
|
||
|
||
#endif /* HAVE_DBUS */
|