Now on revision 108002. ------------------------------------------------------------ revno: 108002 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 22:44:49 -0700 message: Spelling fixes. diff: === modified file 'doc/misc/dbus.texi' --- doc/misc/dbus.texi 2012-04-22 14:11:43 +0000 +++ doc/misc/dbus.texi 2012-04-23 05:44:49 +0000 @@ -1707,7 +1707,7 @@ @code{:pathN} @var{string}:@* This stands for the Nth argument of the signal. @code{:pathN} arguments can be used for object path wildcard matches as specified by -D-Bus, whilest an @code{:argN} argument requires an exact match. +D-Bus, while an @code{:argN} argument requires an exact match. @item @code{:arg-namespace} @var{string}:@* Register for the signals, which first argument defines the service or === modified file 'lisp/abbrev.el' --- lisp/abbrev.el 2012-04-18 16:43:23 +0000 +++ lisp/abbrev.el 2012-04-23 05:44:49 +0000 @@ -135,7 +135,7 @@ (insert-abbrev-table-description table t))) (dolist (table (nreverse empty-tables)) (insert-abbrev-table-description table t))) - ;; Note: `list-abbrevs' can dispaly only local abbrevs, in + ;; Note: `list-abbrevs' can display only local abbrevs, in ;; which case editing could lose abbrevs of other tables. Thus ;; enter `edit-abbrevs-mode' only if LOCAL is nil. (edit-abbrevs-mode)) === modified file 'lisp/net/dbus.el' --- lisp/net/dbus.el 2012-04-22 14:11:43 +0000 +++ lisp/net/dbus.el 2012-04-23 05:44:49 +0000 @@ -564,7 +564,7 @@ `:argN' STRING: `:pathN' STRING: This stands for the Nth argument of the signal. `:pathN' arguments can be used for object path wildcard -matches as specified by D-Bus, whilest an `:argN' argument +matches as specified by D-Bus, while an `:argN' argument requires an exact match. `:arg-namespace' STRING: Register for the signals, which first === modified file 'src/alloc.c' --- src/alloc.c 2012-04-22 07:50:17 +0000 +++ src/alloc.c 2012-04-23 05:44:49 +0000 @@ -5838,7 +5838,7 @@ } /* Mark the Lisp pointers in the terminal objects. - Called by the Fgarbage_collector. */ + Called by Fgarbage_collect. */ static void mark_terminals (void) === modified file 'src/keyboard.c' --- src/keyboard.c 2012-04-23 04:08:51 +0000 +++ src/keyboard.c 2012-04-23 05:44:49 +0000 @@ -12393,7 +12393,7 @@ } /* Mark the pointers in the kboard objects. - Called by the Fgarbage_collector. */ + Called by Fgarbage_collect. */ void mark_kboards (void) { === modified file 'src/term.c' --- src/term.c 2012-01-19 07:21:25 +0000 +++ src/term.c 2012-04-23 05:44:49 +0000 @@ -3601,7 +3601,7 @@ /* Mark the pointers in the tty_display_info objects. - Called by the Fgarbage_collector. */ + Called by Fgarbage_collect. */ void mark_ttys (void) ------------------------------------------------------------ revno: 108001 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 22:43:08 -0700 message: * configure.in: Remove wrong part of comment. diff: === modified file 'configure.in' --- configure.in 2012-04-22 14:11:43 +0000 +++ configure.in 2012-04-23 05:43:08 +0000 @@ -737,7 +737,7 @@ AC_SUBST([WERROR_CFLAGS]) nw="$nw -Waggregate-return" # anachronistic - nw="$nw -Wlong-long" # C90 is anachronistic (lib/gethrxtime.h) + nw="$nw -Wlong-long" # C90 is anachronistic nw="$nw -Wc++-compat" # We don't care about C++ compilers nw="$nw -Wundef" # Warns on '#if GNULIB_FOO' etc in gnulib nw="$nw -Wtraditional" # Warns on #elif which we use often ------------------------------------------------------------ revno: 108000 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 21:08:51 -0700 message: * keyboard.c (handle_async_input): Define only if SYNC_INPUT || SIGIO. Problem reported by Juanma Barranquero for Windows -Wunused-function. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 19:23:51 +0000 +++ src/ChangeLog 2012-04-23 04:08:51 +0000 @@ -1,3 +1,8 @@ +2012-04-23 Paul Eggert + + * keyboard.c (handle_async_input): Define only if SYNC_INPUT || SIGIO. + Problem reported by Juanma Barranquero for Windows -Wunused-function. + 2012-04-22 Paul Eggert Modernize and clean up gmalloc.c to assume C89 (Bug#9119). === modified file 'src/keyboard.c' --- src/keyboard.c 2012-04-20 21:26:18 +0000 +++ src/keyboard.c 2012-04-23 04:08:51 +0000 @@ -7169,6 +7169,7 @@ return nread; } +#if defined SYNC_INPUT || defined SIGIO static void handle_async_input (void) { @@ -7195,6 +7196,7 @@ --handling_signal; #endif } +#endif /* SYNC_INPUT || SIGIO */ #ifdef SYNC_INPUT void ------------------------------------------------------------ revno: 107999 fixes bug(s): http://debbugs.gnu.org/9119 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 12:23:51 -0700 message: Modernize and clean up gmalloc.c to assume C89 (Bug#9119). * gmalloc.c: (_MALLOC_INTERNAL, _MALLOC_H, _PP, __ptr_t) (__malloc_size_t, __malloc_ptrdiff_t): Remove. All uses removed, replaced by the definiens if needed, since we can assume C89 or better now. Include , for PTRDIFF_MAX, uintptr_t. (protect_malloc_state, align, get_contiguous_space) (malloc_atfork_handler_prepare, malloc_atfork_handler_parent) (malloc_atfork_handler_child, malloc_enable_thread) (malloc_initialize_1, __malloc_initialize, morecore_nolock) (_malloc_internal_nolock, _malloc_internal, malloc, _malloc) (_free, _realloc, _free_internal_nolock, _free_internal, free, cfree) (special_realloc, _realloc_internal_nolock, _realloc_internal) (realloc, calloc, __default_morecore, memalign, valloc, checkhdr) (freehook, mallochook, reallochook, mabort, mcheck, mprobe): Define using prototypes, not old style. (align, _malloc_internal_nolock, _free_internal_nolock, memalign): Don't assume ptrdiff_t and uintptr_t are no wider than unsigned long. (align): Don't assume that signed integer overflow wraps around. Omit unused local var. (malloc_initialize_1, morecore_nolock, _malloc_internal_nolock) (_free_internal_nolock, memalign, mallochook, reallochook): Omit no-longer-needed casts. (valloc): Use getpagesize, not __getpagesize. (MAGICWORD, MAGICFREE): Now randomish size_t values, not 32-bit. (struct hdr): The 'magic' member is now size_t, not unsigned long. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 17:46:49 +0000 +++ src/ChangeLog 2012-04-22 19:23:51 +0000 @@ -1,5 +1,32 @@ 2012-04-22 Paul Eggert + Modernize and clean up gmalloc.c to assume C89 (Bug#9119). + * gmalloc.c: (_MALLOC_INTERNAL, _MALLOC_H, _PP, __ptr_t) + (__malloc_size_t, __malloc_ptrdiff_t): + Remove. All uses removed, replaced by the definiens if needed, + since we can assume C89 or better now. + Include , for PTRDIFF_MAX, uintptr_t. + (protect_malloc_state, align, get_contiguous_space) + (malloc_atfork_handler_prepare, malloc_atfork_handler_parent) + (malloc_atfork_handler_child, malloc_enable_thread) + (malloc_initialize_1, __malloc_initialize, morecore_nolock) + (_malloc_internal_nolock, _malloc_internal, malloc, _malloc) + (_free, _realloc, _free_internal_nolock, _free_internal, free, cfree) + (special_realloc, _realloc_internal_nolock, _realloc_internal) + (realloc, calloc, __default_morecore, memalign, valloc, checkhdr) + (freehook, mallochook, reallochook, mabort, mcheck, mprobe): + Define using prototypes, not old style. + (align, _malloc_internal_nolock, _free_internal_nolock, memalign): + Don't assume ptrdiff_t and uintptr_t are no wider than unsigned long. + (align): Don't assume that signed integer overflow wraps around. + Omit unused local var. + (malloc_initialize_1, morecore_nolock, _malloc_internal_nolock) + (_free_internal_nolock, memalign, mallochook, reallochook): + Omit no-longer-needed casts. + (valloc): Use getpagesize, not __getpagesize. + (MAGICWORD, MAGICFREE): Now randomish size_t values, not 32-bit. + (struct hdr): The 'magic' member is now size_t, not unsigned long. + * dbusbind.c (XD_DBUS_VALIDATE_OBJECT): Define only if needed. 2012-04-22 Michael Albinus === modified file 'src/gmalloc.c' --- src/gmalloc.c 2011-09-09 01:06:52 +0000 +++ src/gmalloc.c 2012-04-22 19:23:51 +0000 @@ -1,9 +1,3 @@ -/* This file is no longer automatically generated from libc. */ - -#define _MALLOC_INTERNAL - -/* The malloc headers and source files from the C library follow here. */ - /* Declarations for `malloc' and friends. Copyright (C) 1990, 1991, 1992, 1993, 1995, 1996, 1999, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. @@ -27,12 +21,6 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifndef _MALLOC_H - -#define _MALLOC_H 1 - -#ifdef _MALLOC_INTERNAL - #ifdef HAVE_CONFIG_H #include #endif @@ -41,62 +29,44 @@ #define USE_PTHREAD #endif -#undef PP -#define PP(args) args -#undef __ptr_t -#define __ptr_t void * - #include #include +#include #include #ifdef USE_PTHREAD #include #endif -#endif /* _MALLOC_INTERNAL. */ - - #ifdef __cplusplus extern "C" { #endif #include -#define __malloc_size_t size_t -#define __malloc_ptrdiff_t ptrdiff_t /* Allocate SIZE bytes of memory. */ -extern __ptr_t malloc PP ((__malloc_size_t __size)); +extern void *malloc (size_t size); /* Re-allocate the previously allocated block - in __ptr_t, making the new block SIZE bytes long. */ -extern __ptr_t realloc PP ((__ptr_t __ptr, __malloc_size_t __size)); + in ptr, making the new block SIZE bytes long. */ +extern void *realloc (void *ptr, size_t size); /* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ -extern __ptr_t calloc PP ((__malloc_size_t __nmemb, __malloc_size_t __size)); +extern void *calloc (size_t nmemb, size_t size); /* Free a block allocated by `malloc', `realloc' or `calloc'. */ -extern void free PP ((__ptr_t __ptr)); +extern void free (void *ptr); /* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ -#if !defined (_MALLOC_INTERNAL) || defined (MSDOS) /* Avoid conflict. */ -extern __ptr_t memalign PP ((__malloc_size_t __alignment, - __malloc_size_t __size)); -extern int posix_memalign PP ((__ptr_t *, __malloc_size_t, - __malloc_size_t size)); -#endif - -/* Allocate SIZE bytes on a page boundary. */ -#if ! (defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC)) -extern __ptr_t valloc PP ((__malloc_size_t __size)); +#ifdef MSDOS +extern void *memalign (size_t, size_t); +extern int posix_memalign (void **, size_t, size_t); #endif #ifdef USE_PTHREAD /* Set up mutexes and make malloc etc. thread-safe. */ -extern void malloc_enable_thread PP ((void)); +extern void malloc_enable_thread (void); #endif -#ifdef _MALLOC_INTERNAL - /* The allocator divides the heap into blocks of fixed size; large requests receive one or more whole blocks, and small requests receive a fragment of a block. Fragment sizes are powers of two, @@ -128,22 +98,22 @@ { struct { - __malloc_size_t nfree; /* Free frags in a fragmented block. */ - __malloc_size_t first; /* First free fragment of the block. */ + size_t nfree; /* Free frags in a fragmented block. */ + size_t first; /* First free fragment of the block. */ } frag; /* For a large object, in its first block, this has the number of blocks in the object. In the other blocks, this has a negative number which says how far back the first block is. */ - __malloc_ptrdiff_t size; + ptrdiff_t size; } info; } busy; /* Heap information for a free block (that may be the first of a free cluster). */ struct { - __malloc_size_t size; /* Size (in blocks) of a free cluster. */ - __malloc_size_t next; /* Index of next free cluster. */ - __malloc_size_t prev; /* Index of previous free cluster. */ + size_t size; /* Size (in blocks) of a free cluster. */ + size_t next; /* Index of next free cluster. */ + size_t prev; /* Index of previous free cluster. */ } free; } malloc_info; @@ -155,13 +125,13 @@ /* Address to block number and vice versa. */ #define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) -#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase)) +#define ADDRESS(B) ((void *) (((B) - 1) * BLOCKSIZE + _heapbase)) /* Current search index for the heap table. */ -extern __malloc_size_t _heapindex; +extern size_t _heapindex; /* Limit of valid info table indices. */ -extern __malloc_size_t _heaplimit; +extern size_t _heaplimit; /* Doubly linked lists of free fragments. */ struct list @@ -177,26 +147,26 @@ struct alignlist { struct alignlist *next; - __ptr_t aligned; /* The address that memaligned returned. */ - __ptr_t exact; /* The address that malloc returned. */ + void *aligned; /* The address that memaligned returned. */ + void *exact; /* The address that malloc returned. */ }; extern struct alignlist *_aligned_blocks; /* Instrumentation. */ -extern __malloc_size_t _chunks_used; -extern __malloc_size_t _bytes_used; -extern __malloc_size_t _chunks_free; -extern __malloc_size_t _bytes_free; +extern size_t _chunks_used; +extern size_t _bytes_used; +extern size_t _chunks_free; +extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. They are the same but don't call the hooks. */ -extern __ptr_t _malloc_internal PP ((__malloc_size_t __size)); -extern __ptr_t _realloc_internal PP ((__ptr_t __ptr, __malloc_size_t __size)); -extern void _free_internal PP ((__ptr_t __ptr)); -extern __ptr_t _malloc_internal_nolock PP ((__malloc_size_t __size)); -extern __ptr_t _realloc_internal_nolock PP ((__ptr_t __ptr, __malloc_size_t __size)); -extern void _free_internal_nolock PP ((__ptr_t __ptr)); +extern void *_malloc_internal (size_t); +extern void *_realloc_internal (void *, size_t); +extern void _free_internal (void *); +extern void *_malloc_internal_nolock (size_t); +extern void *_realloc_internal_nolock (void *, size_t); +extern void _free_internal_nolock (void *); #ifdef USE_PTHREAD extern pthread_mutex_t _malloc_mutex, _aligned_blocks_mutex; @@ -228,39 +198,36 @@ #define UNLOCK_ALIGNED_BLOCKS() #endif -#endif /* _MALLOC_INTERNAL. */ - /* Given an address in the middle of a malloc'd object, return the address of the beginning of the object. */ -extern __ptr_t malloc_find_object_address PP ((__ptr_t __ptr)); +extern void *malloc_find_object_address (void *ptr); /* Underlying allocation function; successive calls should return contiguous pieces of memory. */ -extern __ptr_t (*__morecore) PP ((__malloc_ptrdiff_t __size)); +extern void *(*__morecore) (ptrdiff_t size); /* Default value of `__morecore'. */ -extern __ptr_t __default_morecore PP ((__malloc_ptrdiff_t __size)); +extern void *__default_morecore (ptrdiff_t size); /* If not NULL, this function is called after each time `__morecore' is called to increase the data size. */ -extern void (*__after_morecore_hook) PP ((void)); +extern void (*__after_morecore_hook) (void); /* Number of extra blocks to get each time we ask for more core. This reduces the frequency of calling `(*__morecore)'. */ -extern __malloc_size_t __malloc_extra_blocks; +extern size_t __malloc_extra_blocks; /* Nonzero if `malloc' has been called and done its initialization. */ extern int __malloc_initialized; /* Function called to initialize malloc data structures. */ -extern int __malloc_initialize PP ((void)); +extern int __malloc_initialize (void); /* Hooks for debugging versions. */ -extern void (*__malloc_initialize_hook) PP ((void)); -extern void (*__free_hook) PP ((__ptr_t __ptr)); -extern __ptr_t (*__malloc_hook) PP ((__malloc_size_t __size)); -extern __ptr_t (*__realloc_hook) PP ((__ptr_t __ptr, __malloc_size_t __size)); -extern __ptr_t (*__memalign_hook) PP ((__malloc_size_t __size, - __malloc_size_t __alignment)); +extern void (*__malloc_initialize_hook) (void); +extern void (*__free_hook) (void *ptr); +extern void *(*__malloc_hook) (size_t size); +extern void *(*__realloc_hook) (void *ptr, size_t size); +extern void *(*__memalign_hook) (size_t size, size_t alignment); /* Return values for `mprobe': these are the kinds of inconsistencies that `mcheck' enables detection of. */ @@ -277,52 +244,37 @@ before `malloc' is ever called. ABORTFUNC is called with an error code (see enum above) when an inconsistency is detected. If ABORTFUNC is null, the standard function prints on stderr and then calls `abort'. */ -extern int mcheck PP ((void (*__abortfunc) PP ((enum mcheck_status)))); +extern int mcheck (void (*abortfunc) (enum mcheck_status)); /* Check for aberrations in a particular malloc'd block. You must have called `mcheck' already. These are the same checks that `mcheck' does when you free or reallocate a block. */ -extern enum mcheck_status mprobe PP ((__ptr_t __ptr)); +extern enum mcheck_status mprobe (void *ptr); /* Activate a standard collection of tracing hooks. */ -extern void mtrace PP ((void)); -extern void muntrace PP ((void)); +extern void mtrace (void); +extern void muntrace (void); /* Statistics available to the user. */ struct mstats { - __malloc_size_t bytes_total; /* Total size of the heap. */ - __malloc_size_t chunks_used; /* Chunks allocated by the user. */ - __malloc_size_t bytes_used; /* Byte total of user-allocated chunks. */ - __malloc_size_t chunks_free; /* Chunks in the free list. */ - __malloc_size_t bytes_free; /* Byte total of chunks in the free list. */ + size_t bytes_total; /* Total size of the heap. */ + size_t chunks_used; /* Chunks allocated by the user. */ + size_t bytes_used; /* Byte total of user-allocated chunks. */ + size_t chunks_free; /* Chunks in the free list. */ + size_t bytes_free; /* Byte total of chunks in the free list. */ }; /* Pick up the current statistics. */ -extern struct mstats mstats PP ((void)); +extern struct mstats mstats (void); /* Call WARNFUN with a warning message when memory usage is high. */ -extern void memory_warnings PP ((__ptr_t __start, - void (*__warnfun) PP ((const char *)))); - - -/* Relocating allocator. */ - -/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */ -extern __ptr_t r_alloc PP ((__ptr_t *__handleptr, __malloc_size_t __size)); - -/* Free the storage allocated in HANDLEPTR. */ -extern void r_alloc_free PP ((__ptr_t *__handleptr)); - -/* Adjust the block at HANDLEPTR to be SIZE bytes long. */ -extern __ptr_t r_re_alloc PP ((__ptr_t *__handleptr, __malloc_size_t __size)); - +extern void memory_warnings (void *start, void (*warnfun) (const char *)); #ifdef __cplusplus } #endif -#endif /* malloc.h */ /* Memory allocator `malloc'. Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Written May 1989 by Mike Haertel. @@ -345,10 +297,6 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif #include /* On Cygwin there are two heaps. temacs uses the static heap @@ -362,15 +310,15 @@ this is changed in the future, we'll have to similarly deal with reinitializing ralloc. */ #ifdef CYGWIN -extern __ptr_t bss_sbrk PP ((ptrdiff_t __size)); +extern void *bss_sbrk (ptrdiff_t size); extern int bss_sbrk_did_unexec; char *bss_sbrk_heapbase; /* _heapbase for static heap */ malloc_info *bss_sbrk_heapinfo; /* _heapinfo for static heap */ #endif -__ptr_t (*__morecore) PP ((__malloc_ptrdiff_t __size)) = __default_morecore; +void *(*__morecore) (ptrdiff_t size) = __default_morecore; /* Debugging hook for `malloc'. */ -__ptr_t (*__malloc_hook) PP ((__malloc_size_t __size)); +void *(*__malloc_hook) (size_t size); /* Pointer to the base of the first block. */ char *_heapbase; @@ -379,30 +327,30 @@ malloc_info *_heapinfo; /* Number of info entries. */ -static __malloc_size_t heapsize; +static size_t heapsize; /* Search index in the info table. */ -__malloc_size_t _heapindex; +size_t _heapindex; /* Limit of valid info table indices. */ -__malloc_size_t _heaplimit; +size_t _heaplimit; /* Free lists for each fragment size. */ struct list _fraghead[BLOCKLOG]; /* Instrumentation. */ -__malloc_size_t _chunks_used; -__malloc_size_t _bytes_used; -__malloc_size_t _chunks_free; -__malloc_size_t _bytes_free; +size_t _chunks_used; +size_t _bytes_used; +size_t _chunks_free; +size_t _bytes_free; /* Are you experienced? */ int __malloc_initialized; -__malloc_size_t __malloc_extra_blocks; +size_t __malloc_extra_blocks; -void (*__malloc_initialize_hook) PP ((void)); -void (*__after_morecore_hook) PP ((void)); +void (*__malloc_initialize_hook) (void); +void (*__after_morecore_hook) (void); #if defined GC_MALLOC_CHECK && defined GC_PROTECT_MALLOC_STATE @@ -419,12 +367,11 @@ #include static int state_protected_p; -static __malloc_size_t last_state_size; +static size_t last_state_size; static malloc_info *last_heapinfo; void -protect_malloc_state (protect_p) - int protect_p; +protect_malloc_state (int protect_p) { /* If _heapinfo has been relocated, make sure its old location isn't left read-only; it will be reused by malloc. */ @@ -453,29 +400,25 @@ /* Aligned allocation. */ -static __ptr_t align PP ((__malloc_size_t)); -static __ptr_t -align (size) - __malloc_size_t size; +static void * +align (size_t size) { - __ptr_t result; - unsigned long int adj; + void *result; + ptrdiff_t adj; /* align accepts an unsigned argument, but __morecore accepts a - signed one. This could lead to trouble if SIZE overflows a - signed int type accepted by __morecore. We just punt in that + signed one. This could lead to trouble if SIZE overflows the + ptrdiff_t type accepted by __morecore. We just punt in that case, since they are requesting a ludicrous amount anyway. */ - if ((__malloc_ptrdiff_t)size < 0) + if (PTRDIFF_MAX < size) result = 0; else result = (*__morecore) (size); - adj = (unsigned long int) ((unsigned long int) ((char *) result - - (char *) NULL)) % BLOCKSIZE; + adj = (uintptr_t) result % BLOCKSIZE; if (adj != 0) { - __ptr_t new; adj = BLOCKSIZE - adj; - new = (*__morecore) (adj); + (*__morecore) (adj); result = (char *) result + adj; } @@ -488,14 +431,11 @@ /* Get SIZE bytes, if we can get them starting at END. Return the address of the space we got. If we cannot get space at END, fail and return 0. */ -static __ptr_t get_contiguous_space PP ((__malloc_ptrdiff_t, __ptr_t)); -static __ptr_t -get_contiguous_space (size, position) - __malloc_ptrdiff_t size; - __ptr_t position; +static void * +get_contiguous_space (ptrdiff_t size, void *position) { - __ptr_t before; - __ptr_t after; + void *before; + void *after; before = (*__morecore) (0); /* If we can tell in advance that the break is at the wrong place, @@ -525,7 +465,7 @@ static inline void register_heapinfo (void) { - __malloc_size_t block, blocks; + size_t block, blocks; block = BLOCK (_heapinfo); blocks = BLOCKIFY (heapsize * sizeof (malloc_info)); @@ -548,21 +488,21 @@ int _malloc_thread_enabled_p; static void -malloc_atfork_handler_prepare () +malloc_atfork_handler_prepare (void) { LOCK (); LOCK_ALIGNED_BLOCKS (); } static void -malloc_atfork_handler_parent () +malloc_atfork_handler_parent (void) { UNLOCK_ALIGNED_BLOCKS (); UNLOCK (); } static void -malloc_atfork_handler_child () +malloc_atfork_handler_child (void) { UNLOCK_ALIGNED_BLOCKS (); UNLOCK (); @@ -570,7 +510,7 @@ /* Set up mutexes and make malloc etc. thread-safe. */ void -malloc_enable_thread () +malloc_enable_thread (void) { if (_malloc_thread_enabled_p) return; @@ -589,7 +529,7 @@ #endif static void -malloc_initialize_1 () +malloc_initialize_1 (void) { #ifdef GC_MCHECK mcheck (NULL); @@ -609,7 +549,7 @@ (*__malloc_initialize_hook) (); heapsize = HEAP / BLOCKSIZE; - _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info)); + _heapinfo = align (heapsize * sizeof (malloc_info)); if (_heapinfo == NULL) return; memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); @@ -630,7 +570,7 @@ main will call malloc which calls this function. That is before any threads or signal handlers has been set up, so we don't need thread protection. */ int -__malloc_initialize () +__malloc_initialize (void) { if (__malloc_initialized) return 0; @@ -644,14 +584,12 @@ /* Get neatly aligned memory, initializing or growing the heap info table as necessary. */ -static __ptr_t morecore_nolock PP ((__malloc_size_t)); -static __ptr_t -morecore_nolock (size) - __malloc_size_t size; +static void * +morecore_nolock (size_t size) { - __ptr_t result; + void *result; malloc_info *newinfo, *oldinfo; - __malloc_size_t newsize; + size_t newsize; if (morecore_recursing) /* Avoid recursion. The caller will know how to handle a null return. */ @@ -664,7 +602,7 @@ PROTECT_MALLOC_STATE (0); /* Check if we need to grow the info table. */ - if ((__malloc_size_t) BLOCK ((char *) result + size) > heapsize) + if ((size_t) BLOCK ((char *) result + size) > heapsize) { /* Calculate the new _heapinfo table size. We do not account for the added blocks in the table itself, as we hope to place them in @@ -673,7 +611,7 @@ newsize = heapsize; do newsize *= 2; - while ((__malloc_size_t) BLOCK ((char *) result + size) > newsize); + while ((size_t) BLOCK ((char *) result + size) > newsize); /* We must not reuse existing core for the new info table when called from realloc in the case of growing a large block, because the @@ -689,8 +627,8 @@ `morecore_recursing' flag and return null. */ int save = errno; /* Don't want to clobber errno with ENOMEM. */ morecore_recursing = 1; - newinfo = (malloc_info *) _realloc_internal_nolock - (_heapinfo, newsize * sizeof (malloc_info)); + newinfo = _realloc_internal_nolock (_heapinfo, + newsize * sizeof (malloc_info)); morecore_recursing = 0; if (newinfo == NULL) errno = save; @@ -710,7 +648,7 @@ /* Allocate new space for the malloc info table. */ while (1) { - newinfo = (malloc_info *) align (newsize * sizeof (malloc_info)); + newinfo = align (newsize * sizeof (malloc_info)); /* Did it fail? */ if (newinfo == NULL) @@ -721,8 +659,8 @@ /* Is it big enough to record status for its own space? If so, we win. */ - if ((__malloc_size_t) BLOCK ((char *) newinfo - + newsize * sizeof (malloc_info)) + if ((size_t) BLOCK ((char *) newinfo + + newsize * sizeof (malloc_info)) < newsize) break; @@ -759,13 +697,12 @@ } /* Allocate memory from the heap. */ -__ptr_t -_malloc_internal_nolock (size) - __malloc_size_t size; +void * +_malloc_internal_nolock (size_t size) { - __ptr_t result; - __malloc_size_t block, blocks, lastblocks, start; - register __malloc_size_t i; + void *result; + size_t block, blocks, lastblocks, start; + register size_t i; struct list *next; /* ANSI C allows `malloc (0)' to either return NULL, or to return a @@ -790,7 +727,7 @@ { /* Small allocation to receive a fragment of a block. Determine the logarithm to base two of the fragment size. */ - register __malloc_size_t log = 1; + register size_t log = 1; --size; while ((size /= 2) != 0) ++log; @@ -803,15 +740,14 @@ /* There are free fragments of this size. Pop a fragment out of the fragment list and return it. Update the block's nfree and first counters. */ - result = (__ptr_t) next; + result = next; next->prev->next = next->next; if (next->next != NULL) next->next->prev = next->prev; block = BLOCK (result); if (--_heapinfo[block].busy.info.frag.nfree != 0) - _heapinfo[block].busy.info.frag.first = (unsigned long int) - ((unsigned long int) ((char *) next->next - (char *) NULL) - % BLOCKSIZE) >> log; + _heapinfo[block].busy.info.frag.first = + (uintptr_t) next->next % BLOCKSIZE >> log; /* Update the statistics. */ ++_chunks_used; @@ -843,7 +779,7 @@ next->prev = &_fraghead[log]; _fraghead[log].next = next; - for (i = 2; i < (__malloc_size_t) (BLOCKSIZE >> log); ++i) + for (i = 2; i < (size_t) (BLOCKSIZE >> log); ++i) { next = (struct list *) ((char *) result + (i << log)); next->next = _fraghead[log].next; @@ -877,7 +813,7 @@ if (block == start) { /* Need to get more from the system. Get a little extra. */ - __malloc_size_t wantblocks = blocks + __malloc_extra_blocks; + size_t wantblocks = blocks + __malloc_extra_blocks; block = _heapinfo[0].free.prev; lastblocks = _heapinfo[block].free.size; /* Check to see if the new core will be contiguous with the @@ -959,11 +895,10 @@ return result; } -__ptr_t -_malloc_internal (size) - __malloc_size_t size; +void * +_malloc_internal (size_t size) { - __ptr_t result; + void *result; LOCK (); result = _malloc_internal_nolock (size); @@ -972,11 +907,10 @@ return result; } -__ptr_t -malloc (size) - __malloc_size_t size; +void * +malloc (size_t size) { - __ptr_t (*hook) (__malloc_size_t); + void *(*hook) (size_t); if (!__malloc_initialized && !__malloc_initialize ()) return NULL; @@ -998,24 +932,24 @@ /* On some ANSI C systems, some libc functions call _malloc, _free and _realloc. Make them use the GNU functions. */ -__ptr_t -_malloc (size) - __malloc_size_t size; +extern void *_malloc (size_t); +extern void _free (void *); +extern void *_realloc (void *, size_t); + +void * +_malloc (size_t size) { return malloc (size); } void -_free (ptr) - __ptr_t ptr; +_free (void *ptr) { free (ptr); } -__ptr_t -_realloc (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +void * +_realloc (void *ptr, size_t size) { return realloc (ptr, size); } @@ -1043,14 +977,9 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - /* Debugging hook for free. */ -void (*__free_hook) PP ((__ptr_t __ptr)); +void (*__free_hook) (void *__ptr); /* List of blocks allocated by memalign. */ struct alignlist *_aligned_blocks = NULL; @@ -1058,15 +987,14 @@ /* Return memory to the heap. Like `_free_internal' but don't lock mutex. */ void -_free_internal_nolock (ptr) - __ptr_t ptr; +_free_internal_nolock (void *ptr) { int type; - __malloc_size_t block, blocks; - register __malloc_size_t i; + size_t block, blocks; + register size_t i; struct list *prev, *next; - __ptr_t curbrk; - const __malloc_size_t lesscore_threshold + void *curbrk; + const size_t lesscore_threshold /* Threshold of free space at which we will return some to the system. */ = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks; @@ -1162,12 +1090,12 @@ It's possible that moving _heapinfo will allow us to return some space to the system. */ - __malloc_size_t info_block = BLOCK (_heapinfo); - __malloc_size_t info_blocks = _heapinfo[info_block].busy.info.size; - __malloc_size_t prev_block = _heapinfo[block].free.prev; - __malloc_size_t prev_blocks = _heapinfo[prev_block].free.size; - __malloc_size_t next_block = _heapinfo[block].free.next; - __malloc_size_t next_blocks = _heapinfo[next_block].free.size; + size_t info_block = BLOCK (_heapinfo); + size_t info_blocks = _heapinfo[info_block].busy.info.size; + size_t prev_block = _heapinfo[block].free.prev; + size_t prev_blocks = _heapinfo[prev_block].free.size; + size_t next_block = _heapinfo[block].free.next; + size_t next_blocks = _heapinfo[next_block].free.size; if (/* Win if this block being freed is last in core, the info table is just before it, the previous free block is just before the @@ -1190,7 +1118,7 @@ ) { malloc_info *newinfo; - __malloc_size_t oldlimit = _heaplimit; + size_t oldlimit = _heaplimit; /* Free the old info table, clearing _heaplimit to avoid recursion into this code. We don't want to return the @@ -1205,8 +1133,7 @@ _heapindex = 0; /* Allocate new space for the info table and move its data. */ - newinfo = (malloc_info *) _malloc_internal_nolock (info_blocks - * BLOCKSIZE); + newinfo = _malloc_internal_nolock (info_blocks * BLOCKSIZE); PROTECT_MALLOC_STATE (0); memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE); _heapinfo = newinfo; @@ -1222,7 +1149,7 @@ /* Now see if we can return stuff to the system. */ if (block + blocks == _heaplimit && blocks >= lesscore_threshold) { - register __malloc_size_t bytes = blocks * BLOCKSIZE; + register size_t bytes = blocks * BLOCKSIZE; _heaplimit -= blocks; (*__morecore) (-bytes); _heapinfo[_heapinfo[block].free.prev].free.next @@ -1255,7 +1182,7 @@ /* If all fragments of this block are free, remove them from the fragment list and free the whole block. */ next = prev; - for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> type); ++i) + for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i) next = next->next; prev->prev->next = next; if (next != NULL) @@ -1280,7 +1207,7 @@ /* If some fragments of this block are free, link this fragment into the fragment list after the first free fragment of this block. */ - next = (struct list *) ptr; + next = ptr; next->next = prev->next; next->prev = prev; prev->next = next; @@ -1293,11 +1220,10 @@ /* No fragments of this block are free, so link this fragment into the fragment list and announce that it is the first free fragment of this block. */ - prev = (struct list *) ptr; + prev = ptr; _heapinfo[block].busy.info.frag.nfree = 1; - _heapinfo[block].busy.info.frag.first = (unsigned long int) - ((unsigned long int) ((char *) ptr - (char *) NULL) - % BLOCKSIZE >> type); + _heapinfo[block].busy.info.frag.first = + (uintptr_t) ptr % BLOCKSIZE >> type; prev->next = _fraghead[type].next; prev->prev = &_fraghead[type]; prev->prev->next = prev; @@ -1313,8 +1239,7 @@ /* Return memory to the heap. Like `free' but don't call a __free_hook if there is one. */ void -_free_internal (ptr) - __ptr_t ptr; +_free_internal (void *ptr) { LOCK (); _free_internal_nolock (ptr); @@ -1324,10 +1249,9 @@ /* Return memory to the heap. */ void -free (ptr) - __ptr_t ptr; +free (void *ptr) { - void (*hook) (__ptr_t) = __free_hook; + void (*hook) (void *) = __free_hook; if (hook != NULL) (*hook) (ptr); @@ -1340,8 +1264,7 @@ weak_alias (free, cfree) #else void -cfree (ptr) - __ptr_t ptr; +cfree (void *ptr) { free (ptr); } @@ -1368,32 +1291,24 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - - #define min(A, B) ((A) < (B) ? (A) : (B)) /* On Cygwin the dumped emacs may try to realloc storage allocated in the static heap. We just malloc space in the new heap and copy the data. */ #ifdef CYGWIN -__ptr_t -special_realloc (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +void * +special_realloc (void *ptr, size_t size) { - __ptr_t result; + void *result; int type; - __malloc_size_t block, oldsize; + size_t block, oldsize; block = ((char *) ptr - bss_sbrk_heapbase) / BLOCKSIZE + 1; type = bss_sbrk_heapinfo[block].busy.type; oldsize = type == 0 ? bss_sbrk_heapinfo[block].busy.info.size * BLOCKSIZE - : (__malloc_size_t) 1 << type; + : (size_t) 1 << type; result = _malloc_internal_nolock (size); if (result != NULL) memcpy (result, ptr, min (oldsize, size)); @@ -1402,7 +1317,7 @@ #endif /* Debugging hook for realloc. */ -__ptr_t (*__realloc_hook) PP ((__ptr_t __ptr, __malloc_size_t __size)); +void *(*__realloc_hook) (void *ptr, size_t size); /* Resize the given region to the new size, returning a pointer to the (possibly moved) region. This is optimized for speed; @@ -1410,14 +1325,12 @@ achieved by unconditionally allocating and copying to a new region. This module has incestuous knowledge of the internals of both free and malloc. */ -__ptr_t -_realloc_internal_nolock (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +void * +_realloc_internal_nolock (void *ptr, size_t size) { - __ptr_t result; + void *result; int type; - __malloc_size_t block, blocks, oldlimit; + size_t block, blocks, oldlimit; if (size == 0) { @@ -1497,7 +1410,7 @@ (void) _malloc_internal_nolock (blocks * BLOCKSIZE); else { - __ptr_t previous + void *previous = _malloc_internal_nolock ((block - _heapindex) * BLOCKSIZE); (void) _malloc_internal_nolock (blocks * BLOCKSIZE); _free_internal_nolock (previous); @@ -1512,8 +1425,8 @@ default: /* Old size is a fragment; type is logarithm to base two of the fragment size. */ - if (size > (__malloc_size_t) (1 << (type - 1)) && - size <= (__malloc_size_t) (1 << type)) + if (size > (size_t) (1 << (type - 1)) && + size <= (size_t) (1 << type)) /* The new size is the same kind of fragment. */ result = ptr; else @@ -1523,7 +1436,7 @@ result = _malloc_internal_nolock (size); if (result == NULL) goto out; - memcpy (result, ptr, min (size, (__malloc_size_t) 1 << type)); + memcpy (result, ptr, min (size, (size_t) 1 << type)); _free_internal_nolock (ptr); } break; @@ -1534,12 +1447,10 @@ return result; } -__ptr_t -_realloc_internal (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +void * +_realloc_internal (void *ptr, size_t size) { - __ptr_t result; + void *result; LOCK (); result = _realloc_internal_nolock (ptr, size); @@ -1548,12 +1459,10 @@ return result; } -__ptr_t -realloc (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +void * +realloc (void *ptr, size_t size) { - __ptr_t (*hook) (__ptr_t, __malloc_size_t); + void *(*hook) (void *, size_t); if (!__malloc_initialized && !__malloc_initialize ()) return NULL; @@ -1581,19 +1490,12 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - /* Allocate an array of NMEMB elements each SIZE bytes long. The entire array is initialized to zeros. */ -__ptr_t -calloc (nmemb, size) - register __malloc_size_t nmemb; - register __malloc_size_t size; +void * +calloc (register size_t nmemb, register size_t size) { - register __ptr_t result = malloc (nmemb * size); + register void *result = malloc (nmemb * size); if (result != NULL) (void) memset (result, 0, nmemb * size); @@ -1618,11 +1520,6 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - /* uClibc defines __GNU_LIBRARY__, but it is not completely compatible. */ #if !defined (__GNU_LIBRARY__) || defined (__UCLIBC__) @@ -1631,8 +1528,7 @@ /* It is best not to declare this and cast its result on foreign operating systems with potentially hostile include files. */ -#include -extern __ptr_t __sbrk PP ((ptrdiff_t increment)); +extern void *__sbrk (ptrdiff_t increment); #endif /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */ #ifndef NULL @@ -1642,19 +1538,18 @@ /* Allocate INCREMENT more bytes of data space, and return the start of data space, or NULL on errors. If INCREMENT is negative, shrink data space. */ -__ptr_t -__default_morecore (increment) - __malloc_ptrdiff_t increment; +void * +__default_morecore (ptrdiff_t increment) { - __ptr_t result; + void *result; #if defined (CYGWIN) if (!bss_sbrk_did_unexec) { return bss_sbrk (increment); } #endif - result = (__ptr_t) __sbrk (increment); - if (result == (__ptr_t) -1) + result = (void *) __sbrk (increment); + if (result == (void *) -1) return NULL; return result; } @@ -1675,22 +1570,14 @@ not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - -__ptr_t (*__memalign_hook) PP ((__malloc_size_t __size, - __malloc_size_t __alignment)); - -__ptr_t -memalign (alignment, size) - __malloc_size_t alignment; - __malloc_size_t size; +void *(*__memalign_hook) (size_t size, size_t alignment); + +void * +memalign (size_t alignment, size_t size) { - __ptr_t result; - unsigned long int adj, lastadj; - __ptr_t (*hook) (__malloc_size_t, __malloc_size_t) = __memalign_hook; + void *result; + size_t adj, lastadj; + void *(*hook) (size_t, size_t) = __memalign_hook; if (hook) return (*hook) (alignment, size); @@ -1703,7 +1590,7 @@ /* Figure out how much we will need to pad this particular block to achieve the required alignment. */ - adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment; + adj = (uintptr_t) result % alignment; do { @@ -1714,7 +1601,7 @@ return NULL; lastadj = adj; - adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment; + adj = (uintptr_t) result % alignment; /* It's conceivable we might have been so unlucky as to get a different block with weaker alignment. If so, this block is too short to contain SIZE after alignment correction. So we must @@ -1735,7 +1622,7 @@ break; if (l == NULL) { - l = (struct alignlist *) malloc (sizeof (struct alignlist)); + l = malloc (sizeof (struct alignlist)); if (l != NULL) { l->next = _aligned_blocks; @@ -1767,15 +1654,12 @@ #endif int -posix_memalign (memptr, alignment, size) - __ptr_t *memptr; - __malloc_size_t alignment; - __malloc_size_t size; +posix_memalign (void **memptr, size_t alignment, size_t size) { - __ptr_t mem; + void *mem; if (alignment == 0 - || alignment % sizeof (__ptr_t) != 0 + || alignment % sizeof (void *) != 0 || (alignment & (alignment - 1)) != 0) return EINVAL; @@ -1809,43 +1693,27 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#if defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC) - /* Emacs defines GMALLOC_INHIBIT_VALLOC to avoid this definition on MSDOS, where it conflicts with a system header file. */ -#define ELIDE_VALLOC - -#endif - -#ifndef ELIDE_VALLOC - -#if defined (__GNU_LIBRARY__) || defined (_LIBC) -#include -#include -#if defined (__GLIBC__) && __GLIBC__ >= 2 -/* __getpagesize is already declared in with return type int */ -#else -extern size_t __getpagesize PP ((void)); -#endif -#else -#include "getpagesize.h" -#define __getpagesize() getpagesize () -#endif - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#endif - -static __malloc_size_t pagesize; - -__ptr_t -valloc (size) - __malloc_size_t size; +#ifndef GMALLOC_INHIBIT_VALLOC + +/* Allocate SIZE bytes on a page boundary. */ +extern void *valloc (size_t); + +#if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE +# include "getpagesize.h" +#elif !defined getpagesize +extern int getpagesize (void); +#endif + +static size_t pagesize; + +void * +valloc (size_t size) { if (pagesize == 0) - pagesize = __getpagesize (); + pagesize = getpagesize (); return memalign (pagesize, size); } @@ -1876,41 +1744,31 @@ The author may be reached (Email) at the address mike@ai.mit.edu, or (US mail) as Mike Haertel c/o Free Software Foundation. */ -#ifdef emacs -#include -#else -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include -#include -#endif -#endif +#include /* Old hook values. */ -static void (*old_free_hook) (__ptr_t ptr); -static __ptr_t (*old_malloc_hook) (__malloc_size_t size); -static __ptr_t (*old_realloc_hook) (__ptr_t ptr, __malloc_size_t size); +static void (*old_free_hook) (void *ptr); +static void *(*old_malloc_hook) (size_t size); +static void *(*old_realloc_hook) (void *ptr, size_t size); /* Function to call when something awful happens. */ static void (*abortfunc) (enum mcheck_status); /* Arbitrary magical numbers. */ -#define MAGICWORD 0xfedabeeb -#define MAGICFREE 0xd8675309 +#define MAGICWORD (SIZE_MAX / 11 ^ SIZE_MAX / 13 << 3) +#define MAGICFREE (SIZE_MAX / 17 ^ SIZE_MAX / 19 << 4) #define MAGICBYTE ((char) 0xd7) #define MALLOCFLOOD ((char) 0x93) #define FREEFLOOD ((char) 0x95) struct hdr { - __malloc_size_t size; /* Exact size requested by user. */ - unsigned long int magic; /* Magic number to check header integrity. */ + size_t size; /* Exact size requested by user. */ + size_t magic; /* Magic number to check header integrity. */ }; -static enum mcheck_status checkhdr (const struct hdr *); static enum mcheck_status -checkhdr (hdr) - const struct hdr *hdr; +checkhdr (const struct hdr *hdr) { enum mcheck_status status; switch (hdr->magic) @@ -1933,10 +1791,8 @@ return status; } -static void freehook (__ptr_t); static void -freehook (ptr) - __ptr_t ptr; +freehook (void *ptr) { struct hdr *hdr; @@ -1955,15 +1811,13 @@ __free_hook = freehook; } -static __ptr_t mallochook (__malloc_size_t); -static __ptr_t -mallochook (size) - __malloc_size_t size; +static void * +mallochook (size_t size) { struct hdr *hdr; __malloc_hook = old_malloc_hook; - hdr = (struct hdr *) malloc (sizeof (struct hdr) + size + 1); + hdr = malloc (sizeof (struct hdr) + size + 1); __malloc_hook = mallochook; if (hdr == NULL) return NULL; @@ -1971,18 +1825,15 @@ hdr->size = size; hdr->magic = MAGICWORD; ((char *) &hdr[1])[size] = MAGICBYTE; - memset ((__ptr_t) (hdr + 1), MALLOCFLOOD, size); - return (__ptr_t) (hdr + 1); + memset (hdr + 1, MALLOCFLOOD, size); + return hdr + 1; } -static __ptr_t reallochook (__ptr_t, __malloc_size_t); -static __ptr_t -reallochook (ptr, size) - __ptr_t ptr; - __malloc_size_t size; +static void * +reallochook (void *ptr, size_t size) { struct hdr *hdr = NULL; - __malloc_size_t osize = 0; + size_t osize = 0; if (ptr) { @@ -1997,7 +1848,7 @@ __free_hook = old_free_hook; __malloc_hook = old_malloc_hook; __realloc_hook = old_realloc_hook; - hdr = (struct hdr *) realloc ((__ptr_t) hdr, sizeof (struct hdr) + size + 1); + hdr = realloc (hdr, sizeof (struct hdr) + size + 1); __free_hook = freehook; __malloc_hook = mallochook; __realloc_hook = reallochook; @@ -2009,12 +1860,11 @@ ((char *) &hdr[1])[size] = MAGICBYTE; if (size > osize) memset ((char *) (hdr + 1) + osize, MALLOCFLOOD, size - osize); - return (__ptr_t) (hdr + 1); + return hdr + 1; } static void -mabort (status) - enum mcheck_status status; +mabort (enum mcheck_status status) { const char *msg; switch (status) @@ -2047,8 +1897,7 @@ static int mcheck_used = 0; int -mcheck (func) - void (*func) (enum mcheck_status); +mcheck (void (*func) (enum mcheck_status)) { abortfunc = (func != NULL) ? func : &mabort; @@ -2068,7 +1917,7 @@ } enum mcheck_status -mprobe (__ptr_t ptr) +mprobe (void *ptr) { return mcheck_used ? checkhdr (ptr) : MCHECK_DISABLED; } ------------------------------------------------------------ revno: 107998 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-04-23 02:04:54 +0800 message: * faces.el (face-spec-set): Stop supporting deprecated form of third arg. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-04-22 14:11:43 +0000 +++ etc/NEWS 2012-04-22 18:04:54 +0000 @@ -138,6 +138,9 @@ The function `user-variable-p' is now an obsolete alias for `custom-variable-p'. +** `face-spec-set' no longer sets frame-specific attributes when the +third argument is a frame (that usage was obsolete since Emacs 22.2). + * Lisp changes in Emacs 24.2 === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-04-22 17:58:14 +0000 +++ lisp/ChangeLog 2012-04-22 18:04:54 +0000 @@ -6,6 +6,9 @@ "reset-saved" operation bring back the default (Bug#9509). (custom-face-state): Properly detect themed faces. + * faces.el (face-spec-set): Stop supporting deprecated form of + third arg. + 2012-04-22 Michael Albinus Move functions from C to Lisp. Make non-blocking method calls === modified file 'lisp/faces.el' --- lisp/faces.el 2012-04-09 13:05:48 +0000 +++ lisp/faces.el 2012-04-22 18:04:54 +0000 @@ -1532,35 +1532,29 @@ face-attribute-name-alist))))) (defun face-spec-set (face spec &optional for-defface) - "Set FACE's face spec, which controls its appearance, to SPEC. -If FOR-DEFFACE is t, set the base spec, the one that `defface' - and Custom set. (In that case, the caller must put it in the - appropriate property, because that depends on the caller.) -If FOR-DEFFACE is nil, set the overriding spec (and store it - in the `face-override-spec' property of FACE). - -The appearance of FACE is controlled by the base spec, -by any custom theme specs on top of that, and by the -overriding spec on top of all the rest. - -FOR-DEFFACE can also be a frame, in which case we set the -frame-specific attributes of FACE for that frame based on SPEC. -That usage is deprecated. - -See `defface' for information about the format and meaning of SPEC." - (if (framep for-defface) - ;; Handle the deprecated case where third arg is a frame. - (face-spec-set-2 face for-defface spec) - (if for-defface - ;; When we reset the face based on its custom spec, then it is - ;; unmodified as far as Custom is concerned. - (put (or (get face 'face-alias) face) 'face-modified nil) - ;; When we change a face based on a spec from outside custom, - ;; record it for future frames. - (put (or (get face 'face-alias) face) 'face-override-spec spec)) - ;; Reset each frame according to the rules implied by all its specs. - (dolist (frame (frame-list)) - (face-spec-recalc face frame)))) + "Set and apply the face spec for FACE. +If the optional argument FOR-DEFFACE is omitted or nil, set the +overriding spec to SPEC, recording it in the `face-override-spec' +property of FACE. See `defface' for the format of SPEC. + +If FOR-DEFFACE is non-nil, set the base spec (the one set by +`defface' and Custom). In this case, SPEC is ignored; the caller +is responsible for putting the face spec in the `saved-face', +`customized-face', or `face-defface-spec', as appropriate. + +The appearance of FACE is controlled by the base spec, by any +custom theme specs on top of that, and by the overriding spec on +top of all the rest." + (if for-defface + ;; When we reset the face based on its custom spec, then it is + ;; unmodified as far as Custom is concerned. + (put (or (get face 'face-alias) face) 'face-modified nil) + ;; When we change a face based on a spec from outside custom, + ;; record it for future frames. + (put (or (get face 'face-alias) face) 'face-override-spec spec)) + ;; Reset each frame according to the rules implied by all its specs. + (dolist (frame (frame-list)) + (face-spec-recalc face frame))) (defun face-spec-recalc (face frame) "Reset the face attributes of FACE on FRAME according to its specs. ------------------------------------------------------------ revno: 107997 fixes bug(s): http://debbugs.gnu.org/9509 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-04-23 01:58:14 +0800 message: Make the "reset-saved" Custom operation reset to default if there is no saved value. * lisp/cus-edit.el (custom-variable-menu) (custom-variable-reset-saved, custom-face-menu) (custom-face-reset-saved): If there is no saved value, make the "reset-saved" operation bring back the default. (custom-face-state): Properly detect themed faces. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-04-22 14:11:43 +0000 +++ lisp/ChangeLog 2012-04-22 17:58:14 +0000 @@ -1,3 +1,11 @@ +2012-04-22 Chong Yidong + + * cus-edit.el (custom-variable-menu) + (custom-variable-reset-saved, custom-face-menu) + (custom-face-reset-saved): If there is no saved value, make the + "reset-saved" operation bring back the default (Bug#9509). + (custom-face-state): Properly detect themed faces. + 2012-04-22 Michael Albinus Move functions from C to Lisp. Make non-blocking method calls === modified file 'lisp/cus-edit.el' --- lisp/cus-edit.el 2012-04-22 13:58:00 +0000 +++ lisp/cus-edit.el 2012-04-22 17:58:14 +0000 @@ -2823,10 +2823,8 @@ (memq (widget-get widget :custom-state) '(modified changed))))) ("Revert This Session's Customization" custom-variable-reset-saved (lambda (widget) - (and (or (get (widget-value widget) 'saved-value) - (get (widget-value widget) 'saved-variable-comment)) - (memq (widget-get widget :custom-state) - '(modified set changed rogue))))) + (memq (widget-get widget :custom-state) + '(modified set changed rogue)))) ,@(when (or custom-file init-file-user) '(("Erase Customization" custom-variable-reset-standard (lambda (widget) @@ -2977,23 +2975,25 @@ (custom-variable-state-set-and-redraw widget)) (defun custom-variable-reset-saved (widget) - "Restore the saved value for the variable being edited by WIDGET. -This also updates the buffer to show that value. -The value that was current before this operation -becomes the backup value, so you can get it again." + "Restore the value of the variable being edited by WIDGET. +If there is a saved value, restore it; otherwise reset to the +uncustomized (themed or standard) value. + +Update the widget to show that value. The value that was current +before this operation becomes the backup value." (let* ((symbol (widget-value widget)) - (set (or (get symbol 'custom-set) 'set-default)) - (value (get symbol 'saved-value)) + (saved-value (get symbol 'saved-value)) (comment (get symbol 'saved-variable-comment))) - (cond ((or value comment) - (put symbol 'variable-comment comment) - (custom-variable-backup-value widget) - (custom-push-theme 'theme-value symbol 'user 'set (car-safe value)) - (condition-case nil - (funcall set symbol (eval (car value))) - (error nil))) - (t - (error "No saved value for %s" symbol))) + (custom-variable-backup-value widget) + (if (not (or saved-value comment)) + ;; If there is no saved value, remove the setting. + (custom-push-theme 'theme-value symbol 'user 'reset) + ;; Otherwise, apply the saved value. + (put symbol 'variable-comment comment) + (custom-push-theme 'theme-value symbol 'user 'set (car-safe saved-value)) + (ignore-errors + (funcall (or (get symbol 'custom-set) 'set-default) + symbol (eval (car saved-value))))) (put symbol 'customized-value nil) (put symbol 'customized-variable-comment nil) (widget-put widget :custom-state 'unknown) @@ -3619,8 +3619,7 @@ (memq (widget-get widget :custom-state) '(modified changed)))) ("Revert This Session's Customization" custom-face-reset-saved (lambda (widget) - (or (get (widget-value widget) 'saved-face) - (get (widget-value widget) 'saved-face-comment)))) + (memq (widget-get widget :custom-state) '(modified set changed)))) ,@(when (or custom-file init-file-user) '(("Erase Customization" custom-face-reset-standard (lambda (widget) @@ -3675,18 +3674,17 @@ 'changed)) ((or (get face 'saved-face) (get face 'saved-face-comment)) - (if (equal (get face 'saved-face-comment) comment) - (cond - ((eq 'user (caar (get face 'theme-face))) - 'saved) - ((eq 'changed (caar (get face 'theme-face))) - 'changed) - (t 'themed)) - 'changed)) + (cond ((not (equal (get face 'saved-face-comment) comment)) + 'changed) + ((eq 'user (caar (get face 'theme-face))) + 'saved) + ((eq 'changed (caar (get face 'theme-face))) + 'changed) + (t 'themed))) ((get face 'face-defface-spec) - (if (equal comment nil) - 'standard - 'changed)) + (cond (comment 'changed) + ((get face 'theme-face) 'themed) + (t 'standard))) (t 'rogue)))) ;; If the user called set-face-attribute to change the default for ;; new frames, this face is "set outside of Customize". @@ -3776,24 +3774,26 @@ "22.1") (defun custom-face-reset-saved (widget) - "Restore WIDGET to the face's default attributes." - (let* ((symbol (widget-value widget)) + "Restore WIDGET to the face's default attributes. +If there is a saved face, restore it; otherwise reset to the +uncustomized (themed or standard) face." + (let* ((face (widget-value widget)) (child (car (widget-get widget :children))) - (value (get symbol 'saved-face)) - (comment (get symbol 'saved-face-comment)) + (saved-face (get face 'saved-face)) + (comment (get face 'saved-face-comment)) (comment-widget (widget-get widget :comment-widget))) - (unless (or value comment) - (error "No saved value for this face")) - (put symbol 'customized-face nil) - (put symbol 'customized-face-comment nil) - (custom-push-theme 'theme-face symbol 'user 'set value) - (face-spec-set symbol value t) - (put symbol 'face-comment comment) - (widget-value-set child value) + (put face 'customized-face nil) + (put face 'customized-face-comment nil) + (custom-push-theme 'theme-face face 'user + (if saved-face 'set 'reset) + saved-face) + (face-spec-set face saved-face t) + (put face 'face-comment comment) + (widget-value-set child saved-face) ;; This call manages the comment visibility (widget-value-set comment-widget (or comment "")) (custom-face-state-set widget) - (custom-redraw-magic widget))) + (custom-redraw widget))) (defun custom-face-standard-value (widget) (get (widget-value widget) 'face-defface-spec)) ------------------------------------------------------------ revno: 107996 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 10:46:49 -0700 message: * dbusbind.c (XD_DBUS_VALIDATE_OBJECT): Define only if needed. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 14:11:43 +0000 +++ src/ChangeLog 2012-04-22 17:46:49 +0000 @@ -1,3 +1,7 @@ +2012-04-22 Paul Eggert + + * dbusbind.c (XD_DBUS_VALIDATE_OBJECT): Define only if needed. + 2012-04-22 Michael Albinus Move functions from C to Lisp. Make non-blocking method calls === modified file 'src/dbusbind.c' --- src/dbusbind.c 2012-04-22 14:11:43 +0000 +++ src/dbusbind.c 2012-04-22 17:46:49 +0000 @@ -291,6 +291,8 @@ } \ } while (0) +#if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH \ + || XD_DBUS_VALIDATE_OBJECT || HAVE_DBUS_VALIDATE_MEMBER) #define XD_DBUS_VALIDATE_OBJECT(object, func) \ do { \ if (!NILP (object)) \ @@ -304,6 +306,7 @@ dbus_error_free (&derror); \ } \ } while (0) +#endif #if HAVE_DBUS_VALIDATE_BUS_NAME #define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \ @@ -864,7 +867,7 @@ 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. */ ------------------------------------------------------------ revno: 107995 committer: Michael Albinus branch nick: trunk timestamp: Sun 2012-04-22 16:11:43 +0200 message: Move functions from C to Lisp. Make non-blocking method calls the default. Implement further D-Bus standard interfaces. * configure.in (dbus_validate_bus_name, dbus_validate_path) (dbus_validate_interface, dbus_validate_member): Check also for these library functions * dbusbind.c (DBUS_NUM_MESSAGE_TYPES): Declare. (QCdbus_request_name_allow_replacement) (QCdbus_request_name_replace_existing) (QCdbus_request_name_do_not_queue) (QCdbus_request_name_reply_primary_owner) (QCdbus_request_name_reply_in_queue) (QCdbus_request_name_reply_exists) (QCdbus_request_name_reply_already_owner): Move to dbus.el. (QCdbus_registered_serial, QCdbus_registered_method) (QCdbus_registered_signal): New Lisp objects. (XD_DEBUG_MESSAGE): Use sizeof. (XD_MESSAGE_TYPE_TO_STRING, XD_OBJECT_TO_STRING) (XD_DBUS_VALIDATE_BUS_ADDRESS, XD_DBUS_VALIDATE_OBJECT) (XD_DBUS_VALIDATE_BUS_NAME, XD_DBUS_VALIDATE_PATH) (XD_DBUS_VALIDATE_INTERFACE, XD_DBUS_VALIDATE_MEMBER): New macros. (XD_CHECK_DBUS_SERIAL): Rename from CHECK_DBUS_SERIAL_GET_SERIAL. (xd_signature, xd_append_arg): Allow float for integer types. (xd_get_connection_references): New function. (xd_get_connection_address): Rename from xd_initialize. Return cached address. (xd_remove_watch): Do not unset $DBUS_SESSION_BUS_ADDRESS. (xd_close_bus): Rename from Fdbus_close_bus. Not needed on Lisp level. (Fdbus_init_bus): New optional arg PRIVATE. Cache address. Return number of recounts. (Fdbus_get_unique_name): Make stronger parameter check. (Fdbus_message_internal): New defun. (Fdbus_call_method, Fdbus_call_method_asynchronously) (Fdbus_method_return_internal, Fdbus_method_error_internal) (Fdbus_send_signal, Fdbus_register_service) (Fdbus_register_signal, Fdbus_register_method): Move to dbus.el. (xd_read_message_1): Obey new structure of Vdbus_registered_objects. (xd_read_queued_messages): Obey new structure of Vdbus_registered_buses. (Vdbus_compiled_version, Vdbus_runtime_version) (Vdbus_message_type_invalid, Vdbus_message_type_method_call) (Vdbus_message_type_method_return, Vdbus_message_type_error) (Vdbus_message_type_signal): New defvars. (Vdbus_registered_buses, Vdbus_registered_objects_table): Adapt docstring. * net/dbus.el (dbus-message-internal): Declare function. Remove unneeded function declarations. (defvar dbus-message-type-invalid, dbus-message-type-method-call) (dbus-message-type-method-return, dbus-message-type-error) (dbus-message-type-signal): Declare variables. Remove local definitions. (dbus-interface-dbus, dbus-interface-peer) (dbus-interface-introspectable, dbus-interface-properties) (dbus-path-emacs, dbus-interface-emacs, dbus-return-values-table): Adapt docstring. (dbus-interface-objectmanager): New defconst. (dbus-call-method, dbus-call-method-asynchronously) (dbus-send-signal, dbus-method-return-internal) (dbus-method-error-internal, dbus-register-service) (dbus-register-signal, dbus-register-method): New defuns, moved from dbusbind.c (dbus-call-method-handler, dbus-setenv) (dbus-get-all-managed-objects, dbus-managed-objects-handler): New defuns. (dbus-call-method-non-blocking): Make it an obsolete function. (dbus-unregister-object, dbus-unregister-service) (dbus-handle-event, dbus-register-property) (dbus-property-handler): Obey the new structure of `bus-registered-objects'. (dbus-introspect): Use `dbus-call-method'. Use a timeout. (dbus-get-property, dbus-set-property, dbus-get-all-properties): Use `dbus-call-method'. * dbus.texi (Version): New node. (Properties and Annotations): Mention the object manager interface. Describe dbus-get-all-managed-objects. (Type Conversion): Floating point numbers are allowed, if an anteger does not fit Emacs's integer range. (Synchronous Methods): Remove obsolete dbus-call-method-non-blocking. (Asynchronous Methods): Fix description of dbus-call-method-asynchronously. (Receiving Method Calls): Fix some minor errors. Add dbus-interface-emacs. (Signals): Describe unicast signals and the new match rules. (Alternative Buses): Add the PRIVATE optional argument to dbus-init-bus. Describe its new return value. Add dbus-setenv. diff: === modified file 'ChangeLog' --- ChangeLog 2012-04-22 06:56:42 +0000 +++ ChangeLog 2012-04-22 14:11:43 +0000 @@ -1,3 +1,9 @@ +2012-04-22 Michael Albinus + + * configure.in (dbus_validate_bus_name, dbus_validate_path) + (dbus_validate_interface, dbus_validate_member): Check also for + these library functions + 2012-04-22 Paul Eggert * configure.in (doug_lea_malloc): Check for __malloc_initialize_hook. === modified file 'configure.in' --- configure.in 2012-04-22 06:56:42 +0000 +++ configure.in 2012-04-22 14:11:43 +0000 @@ -2079,8 +2079,7 @@ fi dnl D-Bus has been tested under GNU/Linux only. Must be adapted for -dnl other platforms. Support for higher D-Bus versions than 1.0 is -dnl also not configured. +dnl other platforms. HAVE_DBUS=no DBUS_OBJ= if test "${with_dbus}" = "yes"; then @@ -2088,7 +2087,13 @@ if test "$HAVE_DBUS" = yes; then LIBS="$LIBS $DBUS_LIBS" AC_DEFINE(HAVE_DBUS, 1, [Define to 1 if using D-Bus.]) - AC_CHECK_FUNCS([dbus_watch_get_unix_fd]) + dnl dbus_watch_get_unix_fd has been introduced in D-Bus 1.1.1. + dnl dbus_validate_* have been introduced in D-Bus 1.5.12. + AC_CHECK_FUNCS(dbus_watch_get_unix_fd \ + dbus_validate_bus_name \ + dbus_validate_path \ + dbus_validate_interface \ + dbus_validate_member) DBUS_OBJ=dbusbind.o fi fi === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2012-04-20 16:27:52 +0000 +++ doc/misc/ChangeLog 2012-04-22 14:11:43 +0000 @@ -1,3 +1,19 @@ +2012-04-22 Michael Albinus + + * dbus.texi (Version): New node. + (Properties and Annotations): Mention the object manager + interface. Describe dbus-get-all-managed-objects. + (Type Conversion): Floating point numbers are allowed, if an + anteger does not fit Emacs's integer range. + (Synchronous Methods): Remove obsolete dbus-call-method-non-blocking. + (Asynchronous Methods): Fix description of + dbus-call-method-asynchronously. + (Receiving Method Calls): Fix some minor errors. Add + dbus-interface-emacs. + (Signals): Describe unicast signals and the new match rules. + (Alternative Buses): Add the PRIVATE optional argument to + dbus-init-bus. Describe its new return value. Add dbus-setenv. + 2012-04-20 Glenn Morris * faq.texi (New in Emacs 24): New section. === modified file 'doc/misc/dbus.texi' --- doc/misc/dbus.texi 2012-03-02 09:40:05 +0000 +++ doc/misc/dbus.texi 2012-04-22 14:11:43 +0000 @@ -53,7 +53,7 @@ * Asynchronous Methods:: Calling methods non-blocking. * Receiving Method Calls:: Offering own methods. * Signals:: Sending and receiving signals. -* Alternative Buses:: Alternative buses. +* Alternative Buses:: Alternative buses and environments. * Errors and Events:: Errors and events. * Index:: Index including concepts, functions, variables. @@ -116,6 +116,7 @@ @cindex inspection @menu +* Version:: Determining the D-Bus version. * Bus names:: Discovering D-Bus names. * Introspection:: Knowing the details of D-Bus services. * Nodes and Interfaces:: Detecting object paths and interfaces. @@ -125,6 +126,25 @@ @end menu +@node Version +@section D-Bus version. + +D-Bus has evolved over the years. New features have been added with +new D-Bus versions. There are two variables, which allow to determine +the used D-Bus version. + +@defvar dbus-compiled-version +This variable, a string, determines the version of D-Bus Emacs is +compiled against. If it cannot be determined the value is @code{nil}. +@end defvar + +@defvar dbus-runtime-version +The other D-Bus version to be checked is the version of D-Bus Emacs +runs with. This string can be different from @code{dbus-compiled-version}. +It is also @code{nil}, if it cannot be determined at runtime. +@end defvar + + @node Bus names @section Bus names. @@ -149,7 +169,6 @@ (member "org.gnome.evince.Daemon" (dbus-list-activatable-names :session)) @end lisp - @end defun @defun dbus-list-names bus @@ -637,6 +656,12 @@ That is, properties can be retrieved and changed during lifetime of an element. +A generalized interface is +@samp{org.freedesktop.DBus.Objectmanager}@footnote{See +@uref{http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager}}, +which returns objects, their interfaces and properties for a given +service in just one call. + Annotations, on the other hand, are static values for an element. Often, they are used to instruct generators, how to generate code from the interface for a given language binding. @@ -732,6 +757,61 @@ @end lisp @end defun +@defun dbus-get-all-managed-objects bus service path +This functions returns all objects at @var{bus}, @var{service}, +@var{path}, and the children of @var{path}. The result is a list of +objects. Every object is a cons of an existing path name, and the +list of available interface objects. An interface object is another +cons, which car is the interface name, and the cdr is the list of +properties as returned by @code{dbus-get-all-properties} for that path +and interface. Example: + +@lisp +(dbus-get-all-managed-objects + :session "org.gnome.SettingsDaemon" "/") + +@result{} (("/org/gnome/SettingsDaemon/MediaKeys" + ("org.gnome.SettingsDaemon.MediaKeys") + ("org.freedesktop.DBus.Peer") + ("org.freedesktop.DBus.Introspectable") + ("org.freedesktop.DBus.Properties") + ("org.freedesktop.DBus.ObjectManager")) + ("/org/gnome/SettingsDaemon/Power" + ("org.gnome.SettingsDaemon.Power.Keyboard") + ("org.gnome.SettingsDaemon.Power.Screen") + ("org.gnome.SettingsDaemon.Power" + ("Icon" . ". GThemedIcon battery-full-charged-symbolic ") + ("Tooltip" . "Laptop battery is charged")) + ("org.freedesktop.DBus.Peer") + ("org.freedesktop.DBus.Introspectable") + ("org.freedesktop.DBus.Properties") + ("org.freedesktop.DBus.ObjectManager")) + @dots{}) +@end lisp + +If possible, @samp{org.freedesktop.DBus.ObjectManager.GetManagedObjects} +is used for retrieving the information. Otherwise, the information +is collected via @samp{org.freedesktop.DBus.Introspectable.Introspect} +and @samp{org.freedesktop.DBus.Properties.GetAll}, which is slow. + +An overview of all existing object paths, their interfaces and +properties could be retrieved by the following code: + +@lisp +(with-current-buffer (switch-to-buffer "*objectmanager*") + (erase-buffer) + (let (result) + (dolist (service (dbus-list-known-names :session) result) + (message "%s" service) + (add-to-list + 'result + (cons service + (dbus-get-all-managed-objects :session service "/")))) + (insert (message "%s" (pp result))) + (redisplay t))) +@end lisp +@end defun + @defun dbus-introspect-get-annotation-names bus service path interface &optional name Return a list of all annotation names as list of strings. If @var{name} is @code{nil}, the annotations are children of @@ -928,6 +1008,10 @@ @code{:byte ?x} is equal to @code{:byte ?\M-x}, but it is not equal to @code{:byte ?\C-x} or @code{:byte ?\M-\C-x}. +Signed and unsigned integer D-Bus types expect a corresponding integer +value. If the value does not fit Emacs's integer range, it is also +possible to use an equivalent floating point number. + A D-Bus compound type is always represented as a list. The @sc{car} of this list can be the type symbol @code{:array}, @code{:variant}, @code{:struct} or @code{:dict-entry}, which would result in a @@ -1182,24 +1266,6 @@ @end lisp @end defun -@defun dbus-call-method-non-blocking bus service path interface method &optional :timeout timeout &rest args -Call @var{method} on the D-Bus @var{bus}, but don't block the event queue. -This is necessary for communicating to registered D-Bus methods, -which are running in the same Emacs process. - -The arguments are the same as in @code{dbus-call-method}. Example: - -@lisp -(dbus-call-method-non-blocking - :system "org.freedesktop.Hal" - "/org/freedesktop/Hal/devices/computer" - "org.freedesktop.Hal.Device" "GetPropertyString" - "system.kernel.machine") - -@result{} "i686" -@end lisp -@end defun - @node Asynchronous Methods @chapter Calling methods non-blocking. @@ -1229,7 +1295,7 @@ They are converted into D-Bus types as described in @ref{Type Conversion}. -Unless @var{handler} is @code{nil}, the function returns a key into +If @var{handler} is a Lisp function, the function returns a key into the hash table @code{dbus-registered-objects-table}. The corresponding entry in the hash table is removed, when the return message has been arrived, and @var{handler} is called. Example: @@ -1241,7 +1307,7 @@ "org.freedesktop.Hal.Device" "GetPropertyString" 'message "system.kernel.machine") -@result{} (:system 2) +@result{} (:serial :system 2) @print{} i686 @end lisp @@ -1323,19 +1389,21 @@ It could be also an implementation of an own interface. In this case, the service name must be @samp{org.gnu.Emacs}. The object path shall -begin with @samp{/org/gnu/Emacs/@strong{Application}/}, and the +begin with @samp{/org/gnu/Emacs/@strong{Application}}, and the interface name shall be @code{org.gnu.Emacs.@strong{Application}}. @samp{@strong{Application}} is the name of the application which provides the interface. @deffn Constant dbus-service-emacs -The well known service name of Emacs. +The well known service name @samp{org.gnu.Emacs} of Emacs. @end deffn @deffn Constant dbus-path-emacs -The object path head "/org/gnu/Emacs" used by Emacs. All object -paths, used by offered methods or signals, shall start with this -string. +The object path namespace @samp{/org/gnu/Emacs} used by Emacs. +@end deffn + +@deffn Constant dbus-interface-emacs +The interface namespace @code{org.gnu.Emacs} used by Emacs. @end deffn @defun dbus-register-method bus service path interface method handler dont-register-service @@ -1400,7 +1468,7 @@ "org.freedesktop.TextEditor" "OpenFile" 'my-dbus-method-handler) -@result{} ((:session "org.freedesktop.TextEditor" "OpenFile") +@result{} ((:method :session "org.freedesktop.TextEditor" "OpenFile") ("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor" my-dbus-method-handler)) @end lisp @@ -1497,14 +1565,14 @@ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor" "org.freedesktop.TextEditor" "name" :read "GNU Emacs") -@result{} ((:session "org.freedesktop.TextEditor" "name") +@result{} ((:property :session "org.freedesktop.TextEditor" "name") ("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor")) (dbus-register-property :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor" "org.freedesktop.TextEditor" "version" :readwrite emacs-version t) -@result{} ((:session "org.freedesktop.TextEditor" "version") +@result{} ((:property :session "org.freedesktop.TextEditor" "version") ("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor")) @end lisp @@ -1569,8 +1637,8 @@ @chapter Sending and receiving signals. @cindex signals -Signals are broadcast messages. They carry input parameters, which -are received by all objects which have registered for such a signal. +Signals are one way messages. They carry input parameters, which are +received by all objects which have registered for such a signal. @defun dbus-send-signal bus service path interface signal &rest args This function is similar to @code{dbus-call-method}. The difference @@ -1580,10 +1648,14 @@ either the symbol @code{:system} or the symbol @code{:session}. It doesn't matter whether another object has registered for @var{signal}. -@var{service} is the D-Bus service name of the object the signal is -emitted from. @var{path} is the corresponding D-Bus object path, -@var{service} is registered at. @var{interface} is an interface -offered by @var{service}. It must provide @var{signal}. +Signals can be unicast or broadcast messages. For broadcast messages, +@var{service} must be @code{nil}. Otherwise, @var{service} is the +D-Bus service name the signal is sent to as unicast +message.@footnote{For backward compatibility, a broadcast message is +also emitted if @var{service} is the known or unique name Emacs is +registered at D-Bus @var{bus}.} @var{path} is the D-Bus object path +@var{signal} is sent from. @var{interface} is an interface available +at @var{path}. It must provide @var{signal}. All other arguments args are passed to @var{signal} as arguments. They are converted into D-Bus types as described in @ref{Type @@ -1591,15 +1663,15 @@ @lisp (dbus-send-signal - :session dbus-service-emacs dbus-path-emacs - (concat dbus-service-emacs ".FileManager") "FileModified" + :session nil dbus-path-emacs + (concat dbus-interface-emacs ".FileManager") "FileModified" "/home/albinus/.emacs") @end lisp @end defun @defun dbus-register-signal bus service path interface signal handler &rest args -With this function, an application registers for @var{signal} on the -D-Bus @var{bus}. +With this function, an application registers for a signal on the D-Bus +@var{bus}. @var{bus} is either the symbol @code{:system} or the symbol @code{:session}. @@ -1611,24 +1683,46 @@ When the corresponding D-Bus object disappears, signals won't be received any longer. -When @var{service} is @code{nil}, related signals from all D-Bus -objects shall be accepted. - @var{path} is the corresponding D-Bus object path, @var{service} is -registered at. It can also be @code{nil} if the path name of incoming -signals shall not be checked. +registered at. @var{interface} is an interface offered by +@var{service}. It must provide @var{signal}. -@var{interface} is an interface offered by @var{service}. It must -provide @var{signal}. +@var{service}, @var{path}, @var{interface} and @var{signal} can be +@code{nil}. This is interpreted as a wildcard for the respective +argument. @var{handler} is a Lisp function to be called when the @var{signal} is received. It must accept as arguments the output parameters @var{signal} is sending. -All other arguments @var{args}, if specified, must be strings. They -stand for the respective arguments of @var{signal} in their order, and -are used for filtering as well. A @code{nil} argument might be used -to preserve the order. +The remaining arguments @var{args} can be keywords or keyword string +pairs.@footnote{For backward compatibility, the arguments @var{args} +can also be just strings. They stand for the respective arguments of +@var{signal} in their order, and are used for filtering as well. A +@code{nil} argument might be used to preserve the order.} The meaning +is as follows: + +@itemize +@item @code{:argN} @var{string}:@* +@code{:pathN} @var{string}:@* +This stands for the Nth argument of the signal. @code{:pathN} +arguments can be used for object path wildcard matches as specified by +D-Bus, whilest an @code{:argN} argument requires an exact match. + +@item @code{:arg-namespace} @var{string}:@* +Register for the signals, which first argument defines the service or +interface namespace @var{string}. + +@item @code{:path-namespace} @var{string}:@* +Register for the object path namespace @var{string}. All signals sent +from an object path, which has @var{string} as the preceding string, +are matched. This requires @var{path} to be @code{nil}. + +@item @code{:eavesdrop}:@* +Register for unicast signals which are not directed to the D-Bus +object Emacs is registered at D-Bus BUS, if the security policy of BUS +allows this. Otherwise, this argument is ignored. +@end itemize @code{dbus-register-signal} returns a Lisp object, which can be used as argument in @code{dbus-unregister-object} for removing the @@ -1645,7 +1739,7 @@ "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-dbus-signal-handler) -@result{} ((:system "org.freedesktop.Hal.Manager" "DeviceAdded") +@result{} ((:signal :system "org.freedesktop.Hal.Manager" "DeviceAdded") ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler)) @end lisp @@ -1657,23 +1751,36 @@ single string argument therefore. Plugging an USB device to your machine, when registered for signal @samp{DeviceAdded}, will show you which objects the GNU/Linux @code{hal} daemon adds. + +Some of the match rules have been added to a later version of D-Bus. +In order to test the availability of such features, you could register +for a dummy signal, and check the result: + +@lisp +(dbus-ignore-errors + (dbus-register-signal + :system nil nil nil nil 'ignore :path-namespace "/invalid/path")) + +@result{} nil +@end lisp @end defun @node Alternative Buses -@chapter Alternative buses. +@chapter Alternative buses and environments. @cindex bus names @cindex UNIX domain socket +@cindex TCP/IP socket Until now, we have spoken about the system and the session buses, which are the default buses to be connected to. However, it is possible to connect to any bus, from which the address is known. This -is a UNIX domain socket. Everywhere, where a @var{bus} is mentioned -as argument of a function (the symbol @code{:system} or the symbol -@code{:session}), this address can be used instead. The connection to -this bus must be initialized first. +is a UNIX domain or TCP/IP socket. Everywhere, where a @var{bus} is +mentioned as argument of a function (the symbol @code{:system} or the +symbol @code{:session}), this address can be used instead. The +connection to this bus must be initialized first. -@defun dbus-init-bus bus +@defun dbus-init-bus bus &optional private Establish the connection to D-Bus @var{bus}. @var{bus} can be either the symbol @code{:system} or the symbol @@ -1682,30 +1789,90 @@ is called when loading @file{dbus.el}, there is no need to call it again. -Example: You open another session bus in a terminal window on your host: - -@example -# eval `dbus-launch --auto-syntax` -# echo $DBUS_SESSION_BUS_ADDRESS - -@print{} unix:abstract=/tmp/dbus-JoFtAVG92w,guid=2f320a1ebe50b7ef58e -@end example - -In Emacs, you can access to this bus via its address: +The function returns a number, which counts the connections this Emacs +session has established to the @var{bus} under the same unique name +(see @code{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 @var{private} is non-@code{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 +@code{:system} and @code{:session} buses, because other Emacs Lisp +packages might already use this connection to those buses. + +Example: You initialize a connection to the AT-SPI bus on your host: @lisp (setq my-bus - "unix:abstract=/tmp/dbus-JoFtAVG92w,guid=2f320a1ebe50b7ef58e") - -@result{} "unix:abstract=/tmp/dbus-JoFtAVG92w,guid=2f320a1ebe50b7ef58e" - -(dbus-init-bus my-bus) + (dbus-call-method + :session "org.a11y.Bus" "/org/a11y/bus" + "org.a11y.Bus" "GetAddress")) + +@result{} "unix:abstract=/tmp/dbus-2yzWHOCdSD,guid=a490dd26625870ca1298b6e10000fd7f" + +;; If Emacs is built with gtk support, and you run in a GTK enabled +;; environment (like a GNOME session), the initialization reuses the +;; connection established by GTK's atk bindings. +(dbus-init-bus my-bus) + +@result{} 2 + +(dbus-get-unique-name my-bus) + +@result{} ":1.19" + +;; Open a new connection to the same bus. This obsoletes the +;; previous one. +(dbus-init-bus my-bus 'private) + +@result{} 1 + +(dbus-get-unique-name my-bus) + +@result{} ":1.20" +@end lisp + +D-Bus addresses can specify different transport. A possible address +could be based on TCP/IP sockets, see next example. However, it +depends on the bus daemon configuration, which transport is supported. +@end defun + +@defun dbus-setenv bus variable value +Set the value of the @var{bus} environment variable @var{variable} to +@var{value}. + +@var{bus} is either a Lisp symbol, @code{:system} or @code{:session}, +or a string denoting the bus address. Both @var{variable} and +@var{value} should be strings. + +Normally, services inherit the environment of the bus daemon. This +function adds to or modifies that environment when activating services. + +Some bus instances, such as @code{:system}, may disable setting the +environment. In such cases, or if this feature is not available in +older D-Bus versions, a @code{dbus-error} error is raised. + +As an example, it might be desirable to start X11 enabled services on +a remote host's bus on the same X11 server the local Emacs is +running. This could be achieved by + +@lisp +(setq my-bus "unix:host=example.gnu.org,port=4711") + +@result{} "unix:host=example.gnu.org,port=4711" + +(dbus-init-bus my-bus) + +@result{} 1 + +(dbus-setenv my-bus "DISPLAY" (getenv "DISPLAY")) @result{} nil - -(dbus-get-unique-name my-bus) - -@result{} ":1.0" @end lisp @end defun @@ -1723,8 +1890,8 @@ @end defvar Input parameters of @code{dbus-call-method}, -@code{dbus-call-method-non-blocking}, -@code{dbus-call-method-asynchronously}, and +@code{dbus-call-method-asynchronously}, @code{dbus-send-signal}, +@code{dbus-register-method}, @code{dbus-register-property} and @code{dbus-register-signal} are checked for correct D-Bus types. If there is a type mismatch, the Lisp error @code{wrong-type-argument} @code{D-Bus ARG} is raised. @@ -1825,7 +1992,7 @@ @lisp (defun my-dbus-event-error-handler (event error) - (when (string-equal (concat dbus-service-emacs ".FileManager") + (when (string-equal (concat dbus-interface-emacs ".FileManager") (dbus-event-interface-name event)) (message "my-dbus-event-error-handler: %S %S" event error) (signal 'file-error (cdr error)))) === modified file 'etc/NEWS' --- etc/NEWS 2012-04-22 13:58:00 +0000 +++ etc/NEWS 2012-04-22 14:11:43 +0000 @@ -91,6 +91,36 @@ ** which-function-mode now applies to all applicable major modes by default. +** D-Bus + ++++ +*** New variables `dbus-compiled-version' and `dbus-runtime-version'. + ++++ +*** The D-Bus object manager interface is implemented. + ++++ +*** Variables of type :(u)int32 and :(u)int64 accept floating points, +if their value does not fit into Emacs's integer range. + ++++ +*** The function `dbus-call-method' works non-blocking now, it can be +interrupted by C-g. `dbus-call-method-non-blocking' is obsolete. + ++++ +*** Signals can be sent also as unicast message. + ++++ +*** The argument list of `dbus-register-signal' has been extended, +according to the new match rule types of D-Bus. See the manual for +details. + ++++ +*** `dbus-init-bus' supports private connections. + ++++ +*** There is a new function `dbus-setenv'. + ** Obsolete packages: *** mailpost.el === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-04-22 13:58:00 +0000 +++ lisp/ChangeLog 2012-04-22 14:11:43 +0000 @@ -1,3 +1,36 @@ +2012-04-22 Michael Albinus + + Move functions from C to Lisp. Make non-blocking method calls + the default. Implement further D-Bus standard interfaces. + + * net/dbus.el (dbus-message-internal): Declare function. Remove + unneeded function declarations. + (defvar dbus-message-type-invalid, dbus-message-type-method-call) + (dbus-message-type-method-return, dbus-message-type-error) + (dbus-message-type-signal): Declare variables. Remove local + definitions. + (dbus-interface-dbus, dbus-interface-peer) + (dbus-interface-introspectable, dbus-interface-properties) + (dbus-path-emacs, dbus-interface-emacs, dbus-return-values-table): + Adapt docstring. + (dbus-interface-objectmanager): New defconst. + (dbus-call-method, dbus-call-method-asynchronously) + (dbus-send-signal, dbus-method-return-internal) + (dbus-method-error-internal, dbus-register-service) + (dbus-register-signal, dbus-register-method): New defuns, moved + from dbusbind.c + (dbus-call-method-handler, dbus-setenv) + (dbus-get-all-managed-objects, dbus-managed-objects-handler): New + defuns. + (dbus-call-method-non-blocking): Make it an obsolete function. + (dbus-unregister-object, dbus-unregister-service) + (dbus-handle-event, dbus-register-property) + (dbus-property-handler): Obey the new structure of + `bus-registered-objects'. + (dbus-introspect): Use `dbus-call-method'. Use a timeout. + (dbus-get-property, dbus-set-property, dbus-get-all-properties): + Use `dbus-call-method'. + 2012-04-22 Chong Yidong * cus-edit.el (custom-commands, custom-reset-menu) === modified file 'lisp/net/dbus.el' --- lisp/net/dbus.el 2012-04-19 17:20:26 +0000 +++ lisp/net/dbus.el 2012-04-22 14:11:43 +0000 @@ -28,19 +28,19 @@ ;; Low-level language bindings are implemented in src/dbusbind.c. +;; D-Bus support in the Emacs core can be disabled with configuration +;; option "--without-dbus". + ;;; Code: -;; D-Bus support in the Emacs core can be disabled with configuration -;; option "--without-dbus". Declare used subroutines and variables. -(declare-function dbus-call-method "dbusbind.c") -(declare-function dbus-call-method-asynchronously "dbusbind.c") +;; Declare used subroutines and variables. +(declare-function dbus-message-internal "dbusbind.c") (declare-function dbus-init-bus "dbusbind.c") -(declare-function dbus-method-return-internal "dbusbind.c") -(declare-function dbus-method-error-internal "dbusbind.c") -(declare-function dbus-register-service "dbusbind.c") -(declare-function dbus-register-signal "dbusbind.c") -(declare-function dbus-register-method "dbusbind.c") -(declare-function dbus-send-signal "dbusbind.c") +(defvar dbus-message-type-invalid) +(defvar dbus-message-type-method-call) +(defvar dbus-message-type-method-return) +(defvar dbus-message-type-error) +(defvar dbus-message-type-signal) (defvar dbus-debug) (defvar dbus-registered-objects-table) @@ -56,39 +56,93 @@ (defconst dbus-path-dbus "/org/freedesktop/DBus" "The object path used to talk to the bus itself.") +;; Default D-Bus interfaces. + (defconst dbus-interface-dbus "org.freedesktop.DBus" - "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") + "The interface exported by the service `dbus-service-dbus'.") (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer") - "The interface for peer objects.") + "The interface for peer objects. +See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-peer'.") + +;; +;; +;; +;; +;; +;; +;; (defconst dbus-interface-introspectable (concat dbus-interface-dbus ".Introspectable") - "The interface supported by introspectable objects.") + "The interface supported by introspectable objects. +See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-introspectable'.") + +;; +;; +;; +;; +;; (defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties") - "The interface for property objects.") - + "The interface for property objects. +See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-properties'.") + +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; + +(defconst dbus-interface-objectmanager + (concat dbus-interface-dbus ".ObjectManager") + "The object manager interface. +See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager'.") + +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; +;; + +;; Emacs defaults. (defconst dbus-service-emacs "org.gnu.Emacs" "The well known service name of Emacs.") (defconst dbus-path-emacs "/org/gnu/Emacs" - "The object path head used by Emacs.") - -(defconst dbus-message-type-invalid 0 - "This value is never a valid message type.") - -(defconst dbus-message-type-method-call 1 - "Message type of a method call message.") - -(defconst dbus-message-type-method-return 2 - "Message type of a method return message.") - -(defconst dbus-message-type-error 3 - "Message type of an error reply message.") - -(defconst dbus-message-type-signal 4 - "Message type of a signal message.") + "The object path namespace used by Emacs. +All object paths provided by the service `dbus-service-emacs' +shall be subdirectories of this path.") + +(defconst dbus-interface-emacs "org.gnu.Emacs" + "The interface namespace used by Emacs.") + +;; D-Bus constants. (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. @@ -105,15 +159,267 @@ caught in `condition-case' by `dbus-error'.") -;;; Hash table of registered functions. +;;; Basic D-Bus message functions. (defvar dbus-return-values-table (make-hash-table :test 'equal) "Hash table for temporary storing arguments of reply messages. -A key in this hash table is a list (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 reply message. -See `dbus-call-method-non-blocking-handler' and -`dbus-call-method-non-blocking'.") +A key in this hash table is a list (:serial BUS SERIAL), like in +`dbus-registered-objects-table'. BUS is either a Lisp symbol, +`:system' or `:session', or a string denoting the bus address. +SERIAL is the serial number of the reply message.") + +(defun dbus-call-method-handler (&rest args) + "Handler for reply messages of asynchronous D-Bus message calls. +It calls the function stored in `dbus-registered-objects-table'. +The result will be made available in `dbus-return-values-table'." + (puthash (list :serial + (dbus-event-bus-name last-input-event) + (dbus-event-serial-number last-input-event)) + (if (= (length args) 1) (car args) args) + dbus-return-values-table)) + +(defun dbus-call-method (bus service path interface method &rest args) + "Call METHOD on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name to be used. PATH is the D-Bus +object path SERVICE is registered at. INTERFACE is an interface +offered by SERVICE. It must provide METHOD. + +If the parameter `:timeout' is given, the following integer TIMEOUT +specifies the maximum number of milliseconds the method call must +return. The default value is 25,000. If the method call doesn't +return in time, a D-Bus error is raised. + +All other arguments ARGS are passed to METHOD as arguments. They are +converted into D-Bus types via the following rules: + + t and nil => DBUS_TYPE_BOOLEAN + number => DBUS_TYPE_UINT32 + integer => DBUS_TYPE_INT32 + float => DBUS_TYPE_DOUBLE + string => DBUS_TYPE_STRING + list => DBUS_TYPE_ARRAY + +All arguments can be preceded by a type symbol. For details about +type symbols, see Info node `(dbus)Type Conversion'. + +`dbus-call-method' returns the resulting values of METHOD as a list of +Lisp objects. The type conversion happens the other direction as for +input arguments. It follows the mapping rules: + + DBUS_TYPE_BOOLEAN => t or nil + DBUS_TYPE_BYTE => number + DBUS_TYPE_UINT16 => number + DBUS_TYPE_INT16 => integer + DBUS_TYPE_UINT32 => number or float + DBUS_TYPE_UNIX_FD => number or float + DBUS_TYPE_INT32 => integer or float + DBUS_TYPE_UINT64 => number or float + DBUS_TYPE_INT64 => integer or float + DBUS_TYPE_DOUBLE => float + DBUS_TYPE_STRING => string + DBUS_TYPE_OBJECT_PATH => string + DBUS_TYPE_SIGNATURE => string + DBUS_TYPE_ARRAY => list + DBUS_TYPE_VARIANT => list + DBUS_TYPE_STRUCT => list + DBUS_TYPE_DICT_ENTRY => list + +Example: + +\(dbus-call-method + :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\" + \"org.gnome.seahorse.Keys\" \"GetKeyField\" + \"openpgp:657984B8C7A966DD\" \"simple-name\") + + => (t (\"Philip R. Zimmermann\")) + +If the result of the METHOD call is just one value, the converted Lisp +object is returned instead of a list containing this single Lisp object. + +\(dbus-call-method + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" + \"org.freedesktop.Hal.Device\" \"GetPropertyString\" + \"system.kernel.machine\") + + => \"i686\"" + + (or (memq bus '(:system :session)) (stringp bus) + (signal 'wrong-type-argument (list 'keywordp bus))) + (or (stringp service) + (signal 'wrong-type-argument (list 'stringp service))) + (or (stringp path) + (signal 'wrong-type-argument (list 'stringp path))) + (or (stringp interface) + (signal 'wrong-type-argument (list 'stringp interface))) + (or (stringp method) + (signal 'wrong-type-argument (list 'stringp method))) + + (let ((timeout (plist-get args :timeout)) + (key + (apply + 'dbus-message-internal dbus-message-type-method-call + bus service path interface method 'dbus-call-method-handler args))) + ;; Wait until `dbus-call-method-handler' has put the result into + ;; `dbus-return-values-table'. If no timeout is given, use the + ;; default 25". + (with-timeout ((if timeout (/ timeout 1000.0) 25)) + (while (eq (gethash key dbus-return-values-table :ignore) :ignore) + (read-event nil nil 0.1))) + + ;; Cleanup `dbus-return-values-table'. Return the result. + (prog1 + (gethash key dbus-return-values-table) + (remhash key dbus-return-values-table)))) + +;; `dbus-call-method' works non-blocking now. +(defalias 'dbus-call-method-non-blocking 'dbus-call-method) +(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.2") + +(defun dbus-call-method-asynchronously + (bus service path interface method handler &rest args) + "Call METHOD on the D-Bus BUS asynchronously. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name to be used. PATH is the D-Bus +object path SERVICE is registered at. INTERFACE is an interface +offered by SERVICE. It must provide METHOD. + +HANDLER is a Lisp function, which is called when the corresponding +return message has arrived. If HANDLER is nil, no return message +will be expected. + +If the parameter `:timeout' is given, the following integer TIMEOUT +specifies the maximum number of milliseconds the method call must +return. The default value is 25,000. If the method call doesn't +return in time, a D-Bus error is raised. + +All other arguments ARGS are passed to METHOD as arguments. They are +converted into D-Bus types via the following rules: + + t and nil => DBUS_TYPE_BOOLEAN + number => DBUS_TYPE_UINT32 + integer => DBUS_TYPE_INT32 + float => DBUS_TYPE_DOUBLE + string => DBUS_TYPE_STRING + list => DBUS_TYPE_ARRAY + +All arguments can be preceded by a type symbol. For details about +type symbols, see Info node `(dbus)Type Conversion'. + +If HANDLER is a Lisp function, the function returns a key into the +hash table `dbus-registered-objects-table'. The corresponding entry +in the hash table is removed, when the return message has been arrived, +and HANDLER is called. + +Example: + +\(dbus-call-method-asynchronously + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" + \"org.freedesktop.Hal.Device\" \"GetPropertyString\" 'message + \"system.kernel.machine\") + + => \(:serial :system 2) + + -| i686" + + (or (memq bus '(:system :session)) (stringp bus) + (signal 'wrong-type-argument (list 'keywordp bus))) + (or (stringp service) + (signal 'wrong-type-argument (list 'stringp service))) + (or (stringp path) + (signal 'wrong-type-argument (list 'stringp path))) + (or (stringp interface) + (signal 'wrong-type-argument (list 'stringp interface))) + (or (stringp method) + (signal 'wrong-type-argument (list 'stringp method))) + (or (null handler) (functionp handler) + (signal 'wrong-type-argument (list 'functionp handler))) + + (apply 'dbus-message-internal dbus-message-type-method-call + bus service path interface method handler args)) + +(defun dbus-send-signal (bus service path interface signal &rest args) + "Send signal SIGNAL on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. The signal is sent from the D-Bus object +Emacs is registered at BUS. + +SERVICE is the D-Bus name SIGNAL is sent to. It can be either a known +name or a unique name. If SERVICE is nil, the signal is sent as +broadcast message. PATH is the D-Bus object path SIGNAL is sent from. +INTERFACE is an interface available at PATH. It must provide signal +SIGNAL. + +All other arguments ARGS are passed to SIGNAL as arguments. They are +converted into D-Bus types via the following rules: + + t and nil => DBUS_TYPE_BOOLEAN + number => DBUS_TYPE_UINT32 + integer => DBUS_TYPE_INT32 + float => DBUS_TYPE_DOUBLE + string => DBUS_TYPE_STRING + list => DBUS_TYPE_ARRAY + +All arguments can be preceded by a type symbol. For details about +type symbols, see Info node `(dbus)Type Conversion'. + +Example: + +\(dbus-send-signal + :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\" + \"FileModified\" \"/home/albinus/.emacs\")" + + (or (memq bus '(:system :session)) (stringp bus) + (signal 'wrong-type-argument (list 'keywordp bus))) + (or (null service) (stringp service) + (signal 'wrong-type-argument (list 'stringp service))) + (or (stringp path) + (signal 'wrong-type-argument (list 'stringp path))) + (or (stringp interface) + (signal 'wrong-type-argument (list 'stringp interface))) + (or (stringp signal) + (signal 'wrong-type-argument (list 'stringp signal))) + + (apply 'dbus-message-internal dbus-message-type-signal + bus service path interface signal args)) + +(defun dbus-method-return-internal (bus service serial &rest args) + "Return for message SERIAL on the D-Bus BUS. +This is an internal function, it shall not be used outside dbus.el." + + (or (memq bus '(:system :session)) (stringp bus) + (signal 'wrong-type-argument (list 'keywordp bus))) + (or (stringp service) + (signal 'wrong-type-argument (list 'stringp service))) + (or (natnump serial) + (signal 'wrong-type-argument (list 'natnump serial))) + + (apply 'dbus-message-internal dbus-message-type-method-return + bus service serial args)) + +(defun dbus-method-error-internal (bus service serial &rest args) + "Return error message for message SERIAL on the D-Bus BUS. +This is an internal function, it shall not be used outside dbus.el." + + (or (memq bus '(:system :session)) (stringp bus) + (signal 'wrong-type-argument (list 'keywordp bus))) + (or (stringp service) + (signal 'wrong-type-argument (list 'stringp service))) + (or (natnump serial) + (signal 'wrong-type-argument (list 'natnump serial))) + + (apply 'dbus-message-internal dbus-message-type-error + bus service serial args)) + + +;;; Hash table of registered functions. (defun dbus-list-hash-table () "Returns all registered member registrations to D-Bus. @@ -126,6 +432,313 @@ dbus-registered-objects-table) result)) +(defun dbus-setenv (bus variable value) + "Set the value of the BUS environment variable named VARIABLE to VALUE. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. Both VARIABLE and VALUE should be strings. + +Normally, services inherit the environment of the BUS daemon. This +function adds to or modifies that environment when activating services. + +Some bus instances, such as `:system', may disable setting the environment." + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus + dbus-interface-dbus "UpdateActivationEnvironment" + `(:array (:dict-entry ,variable ,value)))) + +(defun dbus-register-service (bus service &rest flags) + "Register known name SERVICE on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name that should be registered. It must +be a known name. + +FLAGS are keywords, which control how the service name is registered. +The following keywords are recognized: + +`:allow-replacement': Allow another service to become the primary +owner if requested. + +`:replace-existing': Request to replace the current primary owner. + +`:do-not-queue': If we can not become the primary owner do not place +us in the queue. + +The function returns a keyword, indicating the result of the +operation. One of the following keywords is returned: + +`:primary-owner': Service has become the primary owner of the +requested name. + +`:in-queue': Service could not become the primary owner and has been +placed in the queue. + +`:exists': Service is already in the queue. + +`:already-owner': Service is already the primary owner." + + ;; Add ObjectManager handler. + (dbus-register-method + bus service nil dbus-interface-objectmanager "GetManagedObjects" + 'dbus-managed-objects-handler 'dont-register) + + (let ((arg 0) + reply) + (dolist (flag flags) + (setq arg + (+ arg + (case flag + (:allow-replacement 1) + (:replace-existing 2) + (:do-not-queue 4) + (t (signal 'wrong-type-argument (list flag))))))) + (setq reply (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "RequestName" service arg)) + (case reply + (1 :primary-owner) + (2 :in-queue) + (3 :exists) + (4 :already-owner) + (t (signal 'dbus-error (list "Could not register service" service)))))) + +(defun dbus-unregister-service (bus service) + "Unregister all objects related to SERVICE from D-Bus BUS. +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. SERVICE must be a known service name. + +The function returns a keyword, indicating the result of the +operation. One of the following keywords is returned: + +`:released': Service has become the primary owner of the name. + +`:non-existent': Service name does not exist on this bus. + +`:not-owner': We are neither the primary owner nor waiting in the +queue of this service." + + (maphash + (lambda (key value) + (dolist (elt value) + (ignore-errors + (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) + (unless + (puthash key (delete elt value) dbus-registered-objects-table) + (remhash key dbus-registered-objects-table)))))) + dbus-registered-objects-table) + (let ((reply (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "ReleaseName" service))) + (case reply + (1 :released) + (2 :non-existent) + (3 :not-owner) + (t (signal 'dbus-error (list "Could not unregister service" service)))))) + +(defun dbus-register-signal + (bus service path interface signal handler &rest args) + "Register for a signal on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name used by the sending D-Bus object. +It can be either a known name or the unique name of the D-Bus object +sending the signal. + +PATH is the D-Bus object path SERVICE is registered. INTERFACE +is an interface offered by SERVICE. It must provide SIGNAL. +HANDLER is a Lisp function to be called when the signal is +received. It must accept as arguments the values SIGNAL is +sending. + +SERVICE, PATH, INTERFACE and SIGNAL can be nil. This is +interpreted as a wildcard for the respective argument. + +The remaining arguments ARGS can be keywords or keyword string pairs. +The meaning is as follows: + +`:argN' STRING: +`:pathN' STRING: This stands for the Nth argument of the +signal. `:pathN' arguments can be used for object path wildcard +matches as specified by D-Bus, whilest an `:argN' argument +requires an exact match. + +`:arg-namespace' STRING: Register for the signals, which first +argument defines the service or interface namespace STRING. + +`:path-namespace' STRING: Register for the object path namespace +STRING. All signals sent from an object path, which has STRING as +the preceding string, are matched. This requires PATH to be nil. + +`:eavesdrop': Register for unicast signals which are not directed +to the D-Bus object Emacs is registered at D-Bus BUS, if the +security policy of BUS allows this. + +Example: + +\(defun my-signal-handler (device) + (message \"Device %s added\" device)) + +\(dbus-register-signal + :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" + \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" 'my-signal-handler) + + => \(\(:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\") + \(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler)) + +`dbus-register-signal' returns an object, which can be used in +`dbus-unregister-object' for removing the registration." + + (let ((counter 0) + (rule "type='signal'") + uname key key1 value) + + ;; Retrieve unique name of service. If service is a known name, + ;; we will register for the corresponding unique name, if any. + ;; Signals are sent always with the unique name as sender. Note: + ;; the unique name of `dbus-service-dbus' is that string itself. + (if (and (stringp service) + (not (zerop (length service))) + (not (string-equal service dbus-service-dbus)) + (not (string-match "^:" service))) + (setq uname (dbus-get-name-owner bus service)) + (setq uname service)) + + (setq rule (concat rule + (when uname (format ",sender='%s'" uname)) + (when interface (format ",interface='%s'" interface)) + (when signal (format ",member='%s'" signal)) + (when path (format ",path='%s'" path)))) + + ;; Add arguments to the rule. + (if (or (stringp (car args)) (null (car args))) + ;; As backward compatibility option, we allow just strings. + (dolist (arg args) + (if (stringp arg) + (setq rule (concat rule (format ",arg%d='%s'" counter arg))) + (if arg (signal 'wrong-type-argument (list "Wrong argument" arg)))) + (setq counter (1+ counter))) + + ;; Parse keywords. + (while args + (setq + key (car args) + rule (concat + rule + (cond + ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. + ((and (keywordp key) + (string-match + "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + (symbol-name key))) + (setq counter (match-string 2 (symbol-name key)) + args (cdr args) + value (car args)) + (unless (and (<= counter 63) (stringp value)) + (signal 'wrong-type-argument + (list "Wrong argument" key value))) + (format + ",arg%s%s='%s'" + counter + (if (string-equal (match-string 1 (symbol-name key)) "path") + "path" "") + value)) + ;; `:arg-namespace', `:path-namespace'. + ((and (keywordp key) + (string-match + "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + (setq args (cdr args) + value (car args)) + (unless (stringp value) + (signal 'wrong-type-argument + (list "Wrong argument" key value))) + (format + ",%s='%s'" + (if (string-equal (match-string 1 (symbol-name key)) "path") + "path_namespace" "arg0namespace") + value)) + ;; `:eavesdrop'. + ((eq key :eavesdrop) + ",eavesdrop='true'") + (t (signal 'wrong-type-argument (list "Wrong argument" key))))) + args (cdr args)))) + + ;; Add the rule to the bus. + (condition-case err + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "AddMatch" rule) + (dbus-error + (if (not (string-match "eavesdrop" rule)) + (signal (car err) (cdr err)) + ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. + (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "AddMatch" rule)))) + + (when dbus-debug (message "Matching rule \"%s\" created" rule)) + + ;; Create a hash table entry. + (setq key (list :signal bus interface signal) + key1 (list uname service path handler rule) + value (gethash key dbus-registered-objects-table)) + (unless (member key1 value) + (puthash key (cons key1 value) dbus-registered-objects-table)) + + ;; Return the object. + (list key (list service path handler)))) + +(defun dbus-register-method + (bus service path interface method handler &optional dont-register-service) + "Register for method METHOD on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name of the D-Bus object METHOD is +registered for. It must be a known name (See discussion of +DONT-REGISTER-SERVICE below). + +PATH is the D-Bus object path SERVICE is registered (See discussion of +DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by +SERVICE. It must provide METHOD. + +HANDLER is a Lisp function to be called when a method call is +received. It must accept the input arguments of METHOD. The return +value of HANDLER is used for composing the returning D-Bus message. +In case HANDLER shall return a reply message with an empty argument +list, HANDLER must return the symbol `:ignore'. + +When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not +registered. This means that other D-Bus clients have no way of +noticing the newly registered method. When interfaces are constructed +incrementally by adding single methods or properties at a time, +DONT-REGISTER-SERVICE can be used to prevent other clients from +discovering the still incomplete interface." + + ;; Register SERVICE. + (unless (or dont-register-service + (member service (dbus-list-names bus))) + (dbus-register-service bus service)) + + ;; Create a hash table entry. We use nil for the unique name, + ;; because the method might be called from anybody. + (let* ((key (list :method bus interface method)) + (key1 (list nil service path handler)) + (value (gethash key dbus-registered-objects-table))) + + (unless (member key1 value) + (puthash key (cons key1 value) dbus-registered-objects-table)) + + ;; Return the object. + (list key (list service path handler)))) + (defun dbus-unregister-object (object) "Unregister OBJECT from D-Bus. OBJECT must be the result of a preceding `dbus-register-method', @@ -141,12 +754,13 @@ ;; Find the corresponding entry in the hash table. (let* ((key (car object)) + (type (car key)) + (bus (cadr key)) (value (cadr object)) - (bus (car key)) (service (car value)) (entry (gethash key dbus-registered-objects-table)) ret) - ;; key has the structure (BUS INTERFACE MEMBER). + ;; key has the structure (TYPE BUS INTERFACE MEMBER). ;; value has the structure (SERVICE PATH [HANDLER]). ;; entry has the structure ((UNAME SERVICE PATH MEMBER [RULE]) ...). ;; MEMBER is either a string (the handler), or a cons cell (a @@ -164,154 +778,35 @@ (unless (puthash key (delete elt entry) dbus-registered-objects-table) (remhash key dbus-registered-objects-table)) ;; Remove match rule of signals. - (let ((rule (nth 4 elt))) - (when (stringp rule) - (setq service nil) ; We do not need to unregister the service. - (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "RemoveMatch" rule))))) + (when (eq type :signal) + (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "RemoveMatch" (nth 4 elt))))) + ;; Check, whether there is still a registered function or property ;; for the given service. If not, unregister the service from the ;; bus. - (when service - (dolist (elt entry) - (let (found) - (maphash - (lambda (k v) - (dolist (e v) - (ignore-errors - (when (and (equal bus (car k)) (string-equal service (cadr e))) - (setq found t))))) - dbus-registered-objects-table) - (unless found - (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "ReleaseName" service))))) + (when (and service (memq type '(:method :property)) + (not (catch :found + (progn + (maphash + (lambda (k v) + (dolist (e v) + (ignore-errors + (and + ;; Bus. + (equal bus (cadr k)) + ;; Service. + (string-equal service (cadr e)) + ;; Non-empty object path. + (caddr e) + (throw :found t))))) + dbus-registered-objects-table) + nil)))) + (dbus-unregister-service bus service)) ;; Return. ret)) -(defun dbus-unregister-service (bus service) - "Unregister all objects related to SERVICE from D-Bus BUS. -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. SERVICE must be a known service name. - -The function returns a keyword, indicating the result of the -operation. One of the following keywords is returned: - -`:released': Service has become the primary owner of the name. - -`:non-existent': Service name does not exist on this bus. - -`:not-owner': We are neither the primary owner nor waiting in the -queue of this service." - - (maphash - (lambda (key value) - (dolist (elt value) - (ignore-errors - (when (and (equal bus (car key)) (string-equal service (cadr elt))) - (unless - (puthash key (delete elt value) dbus-registered-objects-table) - (remhash key dbus-registered-objects-table)))))) - dbus-registered-objects-table) - (let ((reply (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "ReleaseName" service))) - (case reply - (1 :released) - (2 :non-existent) - (3 :not-owner) - (t (signal 'dbus-error (list "Could not unregister service" service)))))) - -(defun dbus-call-method-non-blocking-handler (&rest args) - "Handler for reply messages of asynchronous D-Bus message calls. -It calls the function stored in `dbus-registered-objects-table'. -The result will be made available in `dbus-return-values-table'." - (puthash (list (dbus-event-bus-name last-input-event) - (dbus-event-serial-number last-input-event)) - (if (= (length args) 1) (car args) args) - dbus-return-values-table)) - -(defun dbus-call-method-non-blocking - (bus service path interface method &rest args) - "Call METHOD on the D-Bus BUS, but don't block the event queue. -This is necessary for communicating to registered D-Bus methods, -which are running in the same Emacs process. - -The arguments are the same as in `dbus-call-method'. - -usage: (dbus-call-method-non-blocking - BUS SERVICE PATH INTERFACE METHOD - &optional :timeout TIMEOUT &rest ARGS)" - - (let ((key - (apply - 'dbus-call-method-asynchronously - bus service path interface method - 'dbus-call-method-non-blocking-handler args))) - ;; Wait until `dbus-call-method-non-blocking-handler' has put the - ;; result into `dbus-return-values-table'. - (while (eq (gethash key dbus-return-values-table :ignore) :ignore) - (read-event nil nil 0.1)) - - ;; Cleanup `dbus-return-values-table'. Return the result. - (prog1 - (gethash key dbus-return-values-table nil) - (remhash key dbus-return-values-table)))) - -(defun dbus-name-owner-changed-handler (&rest args) - "Reapplies all member registrations to D-Bus. -This handler is applied when a \"NameOwnerChanged\" signal has -arrived. SERVICE is the object name for which the name owner has -been changed. OLD-OWNER is the previous owner of SERVICE, or the -empty string if SERVICE was not owned yet. NEW-OWNER is the new -owner of SERVICE, or the empty string if SERVICE loses any name owner. - -usage: (dbus-name-owner-changed-handler service old-owner new-owner)" - (save-match-data - ;; Check the arguments. We should silently ignore it when they - ;; are wrong. - (if (and (= (length args) 3) - (stringp (car args)) - (stringp (cadr args)) - (stringp (caddr args))) - (let ((service (car args)) - (old-owner (cadr args))) - ;; Check whether SERVICE is a known name. - (when (not (string-match "^:" service)) - (maphash - (lambda (key value) - (dolist (elt value) - ;; key has the structure (BUS INTERFACE MEMBER). - ;; elt has the structure (UNAME SERVICE PATH HANDLER). - (when (string-equal old-owner (car elt)) - ;; Remove old key, and add new entry with changed name. - (dbus-unregister-object (list key (cdr elt))) - ;; Maybe we could arrange the lists a little bit better - ;; that we don't need to extract every single element? - (dbus-register-signal - ;; BUS SERVICE PATH - (nth 0 key) (nth 1 elt) (nth 2 elt) - ;; INTERFACE MEMBER HANDLER - (nth 1 key) (nth 2 key) (nth 3 elt))))) - (copy-hash-table dbus-registered-objects-table)))) - ;; The error is reported only in debug mode. - (when dbus-debug - (signal - 'dbus-error - (cons - (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus) - args)))))) - -;; Register the handler. -(when nil ;ignore-errors - (dbus-register-signal - :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "NameOwnerChanged" 'dbus-name-owner-changed-handler) - (dbus-register-signal - :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "NameOwnerChanged" 'dbus-name-owner-changed-handler)) - ;;; D-Bus type conversion. @@ -437,9 +932,9 @@ (dbus-ignore-errors (if (eq result :ignore) (dbus-method-return-internal - (nth 1 event) (nth 3 event) (nth 4 event)) + (nth 1 event) (nth 4 event) (nth 3 event)) (apply 'dbus-method-return-internal - (nth 1 event) (nth 3 event) (nth 4 event) + (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. (dbus-error @@ -447,7 +942,7 @@ (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors (dbus-method-error-internal - (nth 1 event) (nth 3 event) (nth 4 event) (cadr err)))) + (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) ;; Propagate D-Bus error messages. (run-hook-with-args 'dbus-event-error-hooks event err) (when (or dbus-debug (= dbus-message-type-error (nth 2 event))) @@ -596,11 +1091,11 @@ XML format." ;; We don't want to raise errors. `dbus-call-method-non-blocking' ;; is used, because the handler can be registered in our Emacs - ;; instance; caller an callee would block each other. + ;; instance; caller and callee would block each other. (dbus-ignore-errors - (funcall - (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) - bus service path dbus-interface-introspectable "Introspect"))) + (dbus-call-method + bus service path dbus-interface-introspectable "Introspect" + :timeout 1000))) (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. @@ -854,12 +1349,11 @@ It will be checked at BUS, SERVICE, PATH. The result can be any valid D-Bus value, or `nil' if there is no PROPERTY." (dbus-ignore-errors - ;; "Get" returns a variant, so we must use the `car'. - (car - (funcall - (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) - bus service path dbus-interface-properties - "Get" :timeout 500 interface property)))) + ;; "Get" returns a variant, so we must use the `car'. + (car + (dbus-call-method + bus service path dbus-interface-properties + "Get" :timeout 500 interface property)))) (defun dbus-set-property (bus service path interface property value) "Set value of PROPERTY of INTERFACE to VALUE. @@ -867,13 +1361,12 @@ been set successful, the result is VALUE. Otherwise, `nil' is returned." (dbus-ignore-errors - ;; "Set" requires a variant. - (funcall - (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) - bus service path dbus-interface-properties - "Set" :timeout 500 interface property (list :variant value)) - ;; Return VALUE. - (dbus-get-property bus service path interface property))) + ;; "Set" requires a variant. + (dbus-call-method + bus service path dbus-interface-properties + "Set" :timeout 500 interface property (list :variant value)) + ;; Return VALUE. + (dbus-get-property bus service path interface property))) (defun dbus-get-all-properties (bus service path interface) "Return all properties of INTERFACE at BUS, SERVICE, PATH. @@ -884,10 +1377,7 @@ ;; "GetAll" returns "a{sv}". (let (result) (dolist (dict - (funcall - (if noninteractive - 'dbus-call-method - 'dbus-call-method-non-blocking) + (dbus-call-method bus service path dbus-interface-properties "GetAll" :timeout 500 interface) result) @@ -931,14 +1421,7 @@ at a time, DONT-REGISTER-SERVICE can be used to prevent other clients from discovering the still incomplete interface." (unless (member access '(:read :readwrite)) - (signal 'dbus-error (list "Access type invalid" access))) - - ;; Register SERVICE. - (unless (or dont-register-service - (member service (dbus-list-names bus))) - (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "RequestName" service 0)) + (signal 'wrong-type-argument (list "Access type invalid" access))) ;; Add handlers for the three property-related methods. (dbus-register-method @@ -951,20 +1434,20 @@ bus service path dbus-interface-properties "Set" 'dbus-property-handler 'dont-register) - ;; Register the name SERVICE with BUS. - (unless dont-register-service + ;; Register SERVICE. + (unless (or dont-register-service (member service (dbus-list-names bus))) (dbus-register-service bus service)) ;; Send the PropertiesChanged signal. (when emits-signal (dbus-send-signal bus service path dbus-interface-properties "PropertiesChanged" - (list (list :dict-entry property (list :variant value))) + `((:dict-entry ,property (:variant ,value))) '(:array))) ;; Create a hash table entry. We use nil for the unique name, ;; because the property might be accessed from anybody. - (let ((key (list bus interface property)) + (let ((key (list :property bus interface property)) (val (list (list @@ -979,7 +1462,7 @@ (defun dbus-property-handler (&rest args) "Default handler for the \"org.freedesktop.DBus.Properties\" interface. -It will be registered for all objects created by `dbus-register-object'." +It will be registered for all objects created by `dbus-register-property'." (let ((bus (dbus-event-bus-name last-input-event)) (service (dbus-event-service-name last-input-event)) (path (dbus-event-path-name last-input-event)) @@ -989,15 +1472,15 @@ (cond ;; "Get" returns a variant. ((string-equal method "Get") - (let ((entry (gethash (list bus interface property) + (let ((entry (gethash (list :property bus interface property) dbus-registered-objects-table))) (when (string-equal path (nth 2 (car entry))) - (list (list :variant (cdar (last (car entry)))))))) + `((:variant ,(cdar (last (car entry)))))))) ;; "Set" expects a variant. ((string-equal method "Set") (let* ((value (caar (cddr args))) - (entry (gethash (list bus interface property) + (entry (gethash (list :property bus interface property) dbus-registered-objects-table)) ;; The value of the hash table is a list; in case of ;; properties it contains just one element (UNAME SERVICE @@ -1012,7 +1495,7 @@ (unless (member :readwrite (car object)) (signal 'dbus-error (list "Property not writable at path" property path))) - (puthash (list bus interface property) + (puthash (list :property bus interface property) (list (append (butlast (car entry)) (list (cons (car object) value)))) dbus-registered-objects-table) @@ -1020,7 +1503,7 @@ (when (member :emits-signal (car object)) (dbus-send-signal bus service path dbus-interface-properties "PropertiesChanged" - (list (list :dict-entry property (list :variant value))) + `((:dict-entry ,property (:variant ,value))) '(:array))) ;; Return empty reply. :ignore)) @@ -1030,7 +1513,7 @@ (let (result) (maphash (lambda (key val) - (when (and (equal (butlast key) (list bus interface)) + (when (and (equal (butlast key) (list :property bus interface)) (string-equal path (nth 2 (car val))) (not (functionp (car (last (car val)))))) (add-to-list @@ -1042,15 +1525,151 @@ ;; Return the result, or an empty array. (list :array (or result '(:signature "{sv}")))))))) + +;;; D-Bus object manager. + +(defun dbus-get-all-managed-objects (bus service path) + "Return all objects at BUS, SERVICE, PATH, and the children of PATH. +The result is a list of objects. Every object is a cons of an +existing path name, and the list of available interface objects. +An interface object is another cons, which car is the interface +name, and the cdr is the list of properties as returned by +`dbus-get-all-properties' for that path and interface. Example: + +\(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\") + + => \(\(\"/org/gnome/SettingsDaemon/MediaKeys\" + \(\"org.gnome.SettingsDaemon.MediaKeys\") + \(\"org.freedesktop.DBus.Peer\") + \(\"org.freedesktop.DBus.Introspectable\") + \(\"org.freedesktop.DBus.Properties\") + \(\"org.freedesktop.DBus.ObjectManager\")) + \(\"/org/gnome/SettingsDaemon/Power\" + \(\"org.gnome.SettingsDaemon.Power.Keyboard\") + \(\"org.gnome.SettingsDaemon.Power.Screen\") + \(\"org.gnome.SettingsDaemon.Power\" + \(\"Icon\" . \". GThemedIcon battery-full-charged-symbolic \") + \(\"Tooltip\" . \"Laptop battery is charged\")) + \(\"org.freedesktop.DBus.Peer\") + \(\"org.freedesktop.DBus.Introspectable\") + \(\"org.freedesktop.DBus.Properties\") + \(\"org.freedesktop.DBus.ObjectManager\")) + ...) + +If possible, \"org.freedesktop.DBus.ObjectManager.GetManagedObjects\" +is used for retrieving the information. Otherwise, the information +is collected via \"org.freedesktop.DBus.Introspectable.Introspect\" +and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." + (let ((result + ;; Direct call. Fails, if the target does not support the + ;; object manager interface. + (dbus-ignore-errors + (dbus-call-method + bus service path dbus-interface-objectmanager + "GetManagedObjects" :timeout 1000)))) + + (if result + ;; Massage the returned structure. + (dolist (entry result result) + ;; "a{oa{sa{sv}}}". + (dolist (entry1 (cdr entry)) + ;; "a{sa{sv}}". + (dolist (entry2 entry1) + ;; "a{sv}". + (if (cadr entry2) + ;; "sv". + (dolist (entry3 (cadr entry2)) + (setcdr entry3 (caadr entry3))) + (setcdr entry2 nil))))) + + ;; Fallback: collect the information. Slooow! + (dolist (object + (dbus-introspect-get-all-nodes bus service path) + result) + (let (result1) + (dolist + (interface + (dbus-introspect-get-interface-names bus service object) + result1) + (add-to-list + 'result1 + (cons interface + (dbus-get-all-properties bus service object interface)))) + (when result1 + (add-to-list 'result (cons object result1)))))))) + +(defun dbus-managed-objects-handler () + "Default handler for the \"org.freedesktop.DBus.ObjectManager\" interface. +It will be registered for all objects created by `dbus-register-method'." + (let* ((last-input-event last-input-event) + (bus (dbus-event-bus-name last-input-event)) + (service (dbus-event-service-name last-input-event)) + (path (dbus-event-path-name last-input-event))) + ;; "GetManagedObjects" returns "a{oa{sa{sv}}}". + (let (interfaces result) + + ;; Check for object path wildcard interfaces. + (maphash + (lambda (key val) + (when (and (equal (butlast key 2) (list :method bus)) + (null (nth 2 (car-safe val)))) + (add-to-list 'interfaces (nth 2 key)))) + dbus-registered-objects-table) + + ;; Check all registered object paths. + (maphash + (lambda (key val) + (let ((object (or (nth 2 (car-safe val)) "")) + (interface (nth 2 key))) + (when (and (equal (butlast key 2) (list :method bus)) + (string-prefix-p path object)) + (dolist (interface (cons (nth 2 key) interfaces)) + (unless (assoc object result) + (add-to-list 'result (list object))) + (unless (assoc interface (cdr (assoc object result))) + (setcdr + (assoc object result) + (append + (list (cons + interface + ;; We simulate "org.freedesktop.DBus.Properties.GetAll" + ;; by using an appropriate D-Bus event. + (let ((last-input-event + (append + (butlast last-input-event 4) + (list object dbus-interface-properties + "GetAll" 'dbus-property-handler)))) + (dbus-property-handler interface)))) + (cdr (assoc object result))))))))) + dbus-registered-objects-table) + + ;; Return the result, or an empty array. + (list + :array + (or + (mapcar + (lambda (x) + (list + :dict-entry :object-path (car x) + (cons :array (mapcar (lambda (y) (cons :dict-entry y)) (cdr x))))) + result) + '(:signature "{oa{sa{sv}}}")))))) + -;; Initialize :system and :session buses. This adds their file +;; Initialize `:system' and `:session' buses. This adds their file ;; descriptors to input_wait_mask, in order to detect incoming ;; messages immediately. (when (featurep 'dbusbind) (dbus-ignore-errors - (dbus-init-bus :system) + (dbus-init-bus :system)) + (dbus-ignore-errors (dbus-init-bus :session))) (provide 'dbus) +;;; TODO: + +;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and +;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. + ;;; dbus.el ends here === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 07:50:17 +0000 +++ src/ChangeLog 2012-04-22 14:11:43 +0000 @@ -1,3 +1,48 @@ +2012-04-22 Michael Albinus + + Move functions from C to Lisp. Make non-blocking method calls + the default. Implement further D-Bus standard interfaces. + + * dbusbind.c (DBUS_NUM_MESSAGE_TYPES): Declare. + (QCdbus_request_name_allow_replacement) + (QCdbus_request_name_replace_existing) + (QCdbus_request_name_do_not_queue) + (QCdbus_request_name_reply_primary_owner) + (QCdbus_request_name_reply_in_queue) + (QCdbus_request_name_reply_exists) + (QCdbus_request_name_reply_already_owner): Move to dbus.el. + (QCdbus_registered_serial, QCdbus_registered_method) + (QCdbus_registered_signal): New Lisp objects. + (XD_DEBUG_MESSAGE): Use sizeof. + (XD_MESSAGE_TYPE_TO_STRING, XD_OBJECT_TO_STRING) + (XD_DBUS_VALIDATE_BUS_ADDRESS, XD_DBUS_VALIDATE_OBJECT) + (XD_DBUS_VALIDATE_BUS_NAME, XD_DBUS_VALIDATE_PATH) + (XD_DBUS_VALIDATE_INTERFACE, XD_DBUS_VALIDATE_MEMBER): New macros. + (XD_CHECK_DBUS_SERIAL): Rename from CHECK_DBUS_SERIAL_GET_SERIAL. + (xd_signature, xd_append_arg): Allow float for integer types. + (xd_get_connection_references): New function. + (xd_get_connection_address): Rename from xd_initialize. Return + cached address. + (xd_remove_watch): Do not unset $DBUS_SESSION_BUS_ADDRESS. + (xd_close_bus): Rename from Fdbus_close_bus. Not needed on Lisp + level. + (Fdbus_init_bus): New optional arg PRIVATE. Cache address. + Return number of recounts. + (Fdbus_get_unique_name): Make stronger parameter check. + (Fdbus_message_internal): New defun. + (Fdbus_call_method, Fdbus_call_method_asynchronously) + (Fdbus_method_return_internal, Fdbus_method_error_internal) + (Fdbus_send_signal, Fdbus_register_service) + (Fdbus_register_signal, Fdbus_register_method): Move to dbus.el. + (xd_read_message_1): Obey new structure of Vdbus_registered_objects. + (xd_read_queued_messages): Obey new structure of Vdbus_registered_buses. + (Vdbus_compiled_version, Vdbus_runtime_version) + (Vdbus_message_type_invalid, Vdbus_message_type_method_call) + (Vdbus_message_type_method_return, Vdbus_message_type_error) + (Vdbus_message_type_signal): New defvars. + (Vdbus_registered_buses, Vdbus_registered_objects_table): Adapt + docstring. + 2012-04-22 Paul Eggert Fix GC_MALLOC_CHECK debugging output on 64-bit hosts. === modified file 'src/dbusbind.c' --- src/dbusbind.c 2012-02-02 12:47:09 +0000 +++ src/dbusbind.c 2012-04-22 14:11:43 +0000 @@ -28,19 +28,15 @@ #include "keyboard.h" #include "process.h" +#ifndef DBUS_NUM_MESSAGE_TYPES +#define DBUS_NUM_MESSAGE_TYPES 5 +#endif + /* Subroutines. */ static Lisp_Object Qdbus_init_bus; -static Lisp_Object Qdbus_close_bus; static Lisp_Object Qdbus_get_unique_name; -static Lisp_Object Qdbus_call_method; -static Lisp_Object Qdbus_call_method_asynchronously; -static Lisp_Object Qdbus_method_return_internal; -static Lisp_Object Qdbus_method_error_internal; -static Lisp_Object Qdbus_send_signal; -static Lisp_Object Qdbus_register_service; -static Lisp_Object Qdbus_register_signal; -static Lisp_Object Qdbus_register_method; +static Lisp_Object Qdbus_message_internal; /* D-Bus error symbol. */ static Lisp_Object Qdbus_error; @@ -51,17 +47,6 @@ /* Lisp symbol for method call timeout. */ static Lisp_Object QCdbus_timeout; -/* Lisp symbols for name request flags. */ -static Lisp_Object QCdbus_request_name_allow_replacement; -static Lisp_Object QCdbus_request_name_replace_existing; -static Lisp_Object QCdbus_request_name_do_not_queue; - -/* Lisp symbols for name request replies. */ -static Lisp_Object QCdbus_request_name_reply_primary_owner; -static Lisp_Object QCdbus_request_name_reply_in_queue; -static Lisp_Object QCdbus_request_name_reply_exists; -static Lisp_Object QCdbus_request_name_reply_already_owner; - /* Lisp symbols of D-Bus types. */ static Lisp_Object QCdbus_type_byte, QCdbus_type_boolean; static Lisp_Object QCdbus_type_int16, QCdbus_type_uint16; @@ -75,6 +60,10 @@ static Lisp_Object QCdbus_type_array, QCdbus_type_variant; static Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry; +/* Lisp symbols of objects in `dbus-registered-objects-table'. */ +static Lisp_Object QCdbus_registered_serial, QCdbus_registered_method; +static Lisp_Object QCdbus_registered_signal; + /* Whether we are reading a D-Bus event. */ static int xd_in_read_queued_messages = 0; @@ -120,14 +109,14 @@ } while (0) /* Macros for debugging. In order to enable them, build with - "MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */ + "env MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */ #ifdef DBUS_DEBUG -#define XD_DEBUG_MESSAGE(...) \ - do { \ - char s[1024]; \ +#define XD_DEBUG_MESSAGE(...) \ + do { \ + char s[1024]; \ snprintf (s, sizeof s, __VA_ARGS__); \ - printf ("%s: %s\n", __func__, s); \ - message ("%s: %s", __func__, s); \ + printf ("%s: %s\n", __func__, s); \ + message ("%s: %s", __func__, s); \ } while (0) #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \ do { \ @@ -144,7 +133,7 @@ if (!NILP (Vdbus_debug)) \ { \ char s[1024]; \ - snprintf (s, 1023, __VA_ARGS__); \ + snprintf (s, sizeof s, __VA_ARGS__); \ message ("%s: %s", __func__, s); \ } \ } while (0) @@ -241,23 +230,112 @@ #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. */ +#define XD_OBJECT_TO_STRING(object) \ + SDATA (format2 ("%s", object, Qnil)) + /* Check whether X is a valid dbus serial number. If valid, set SERIAL to its value. Otherwise, signal an error. */ -#define CHECK_DBUS_SERIAL_GET_SERIAL(x, serial) \ - do \ - { \ - dbus_uint32_t DBUS_SERIAL_MAX = -1; \ - if (NATNUMP (x) && XINT (x) <= DBUS_SERIAL_MAX) \ - serial = XINT (x); \ - else if (MOST_POSITIVE_FIXNUM < DBUS_SERIAL_MAX \ - && FLOATP (x) \ - && 0 <= XFLOAT_DATA (x) \ - && XFLOAT_DATA (x) <= DBUS_SERIAL_MAX) \ - serial = XFLOAT_DATA (x); \ - else \ - XD_SIGNAL2 (build_string ("Invalid dbus serial"), x); \ - } \ - while (0) +#define XD_CHECK_DBUS_SERIAL(x, serial) \ + do { \ + dbus_uint32_t DBUS_SERIAL_MAX = -1; \ + if (NATNUMP (x) && XINT (x) <= DBUS_SERIAL_MAX) \ + serial = XINT (x); \ + else if (MOST_POSITIVE_FIXNUM < DBUS_SERIAL_MAX \ + && FLOATP (x) \ + && 0 <= XFLOAT_DATA (x) \ + && XFLOAT_DATA (x) <= DBUS_SERIAL_MAX) \ + serial = XFLOAT_DATA (x); \ + else \ + XD_SIGNAL2 (build_string ("Invalid dbus serial"), x); \ + } while (0) + +#define XD_DBUS_VALIDATE_BUS_ADDRESS(bus) \ + do { \ + 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); \ + } \ + \ + else \ + { \ + CHECK_SYMBOL (bus); \ + if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) \ + XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \ + /* We do not want to have an autolaunch for the session bus. */ \ + if (EQ (bus, QCdbus_session_bus) \ + && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL) \ + XD_SIGNAL2 (build_string ("No connection to bus"), bus); \ + } \ + } while (0) + +#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) + +#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. */ @@ -293,11 +371,6 @@ { case DBUS_TYPE_BYTE: case DBUS_TYPE_UINT16: - case DBUS_TYPE_UINT32: - case DBUS_TYPE_UINT64: -#ifdef DBUS_TYPE_UNIX_FD - case DBUS_TYPE_UNIX_FD: -#endif CHECK_NATNUM (object); sprintf (signature, "%c", dtype); break; @@ -309,14 +382,19 @@ break; case DBUS_TYPE_INT16: - case DBUS_TYPE_INT32: - case DBUS_TYPE_INT64: CHECK_NUMBER (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_FLOAT (object); + CHECK_NUMBER_OR_FLOAT (object); sprintf (signature, "%c", dtype); break; @@ -352,8 +430,8 @@ } /* If the element type is DBUS_TYPE_SIGNATURE, and this is the - only element, the value of this element is used as he array's - element signature. */ + only element, the value of this element is used as the + array's element signature. */ if ((subtype == DBUS_TYPE_SIGNATURE) && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt))) && NILP (CDR_SAFE (XD_NEXT_VALUE (elt)))) @@ -505,9 +583,8 @@ } case DBUS_TYPE_INT32: - CHECK_NUMBER (object); { - dbus_int32_t val = XINT (object); + dbus_int32_t val = extract_float (object); XD_DEBUG_MESSAGE ("%c %d", dtype, val); if (!dbus_message_iter_append_basic (iter, dtype, &val)) XD_SIGNAL2 (build_string ("Unable to append argument"), object); @@ -518,9 +595,8 @@ #ifdef DBUS_TYPE_UNIX_FD case DBUS_TYPE_UNIX_FD: #endif - CHECK_NATNUM (object); { - dbus_uint32_t val = XFASTINT (object); + dbus_uint32_t val = extract_float (object); 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); @@ -528,9 +604,8 @@ } case DBUS_TYPE_INT64: - CHECK_NUMBER (object); { - dbus_int64_t val = XINT (object); + dbus_int64_t val = extract_float (object); XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val); if (!dbus_message_iter_append_basic (iter, dtype, &val)) XD_SIGNAL2 (build_string ("Unable to append argument"), object); @@ -538,19 +613,17 @@ } case DBUS_TYPE_UINT64: - CHECK_NATNUM (object); { - dbus_uint64_t val = XFASTINT (object); - XD_DEBUG_MESSAGE ("%c %"pI"d", dtype, XFASTINT (object)); + dbus_uint64_t val = extract_float (object); + XD_DEBUG_MESSAGE ("%c %"pI"d", dtype, val); if (!dbus_message_iter_append_basic (iter, dtype, &val)) XD_SIGNAL2 (build_string ("Unable to append argument"), object); return; } case DBUS_TYPE_DOUBLE: - CHECK_FLOAT (object); { - double val = XFLOAT_DATA (object); + 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); @@ -614,7 +687,7 @@ dtype, CAR_SAFE (XD_NEXT_VALUE (object))); XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature, - SDATA (format2 ("%s", object, Qnil))); + XD_OBJECT_TO_STRING (object)); if (!dbus_message_iter_open_container (iter, dtype, signature, &subiter)) XD_SIGNAL3 (build_string ("Cannot open container"), @@ -627,7 +700,7 @@ dtype, CAR_SAFE (XD_NEXT_VALUE (object))); XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature, - SDATA (format2 ("%s", object, Qnil))); + XD_OBJECT_TO_STRING (object)); if (!dbus_message_iter_open_container (iter, dtype, signature, &subiter)) XD_SIGNAL3 (build_string ("Cannot open container"), @@ -637,8 +710,7 @@ case DBUS_TYPE_STRUCT: case DBUS_TYPE_DICT_ENTRY: /* These containers do not require a signature. */ - XD_DEBUG_MESSAGE ("%c %s", dtype, - SDATA (format2 ("%s", object, Qnil))); + 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_number (dtype)); @@ -777,7 +849,7 @@ result = Fcons (xd_retrieve_arg (subtype, &subiter), result); dbus_message_iter_next (&subiter); } - XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil))); + XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result)); RETURN_UNGCPRO (Fnreverse (result)); } @@ -787,85 +859,37 @@ } } -/* Initialize D-Bus connection. BUS is either a Lisp symbol, :system - or :session, or a string denoting the bus address. It tells which - D-Bus to initialize. If RAISE_ERROR is non-zero, signal an error - when the connection cannot be initialized. */ +/* Return the number of references of the shared CONNECTION. */ +static int +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; +} + +/* Return D-Bus connection address. BUS is either a Lisp symbol, + :system or :session, or a string denoting the bus address. */ static DBusConnection * -xd_initialize (Lisp_Object bus, int raise_error) +xd_get_connection_address (Lisp_Object bus) { DBusConnection *connection; - DBusError derror; - - /* Parameter check. */ - if (!STRINGP (bus)) - { - CHECK_SYMBOL (bus); - if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) - { - if (raise_error) - XD_SIGNAL2 (build_string ("Wrong bus name"), bus); - else - return NULL; - } - - /* We do not want to have an autolaunch for the session bus. */ - if (EQ (bus, QCdbus_session_bus) - && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL) - { - if (raise_error) - XD_SIGNAL2 (build_string ("No connection to bus"), bus); - else - return NULL; - } - } - - /* Open a connection to the bus. */ - dbus_error_init (&derror); - - if (STRINGP (bus)) - connection = dbus_connection_open (SSDATA (bus), &derror); + Lisp_Object val; + + val = CDR_SAFE (Fassoc (bus, Vdbus_registered_buses)); + if (NILP (val)) + XD_SIGNAL2 (build_string ("No connection to bus"), bus); else - if (EQ (bus, QCdbus_system_bus)) - connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror); - else - connection = dbus_bus_get (DBUS_BUS_SESSION, &derror); - - if (dbus_error_is_set (&derror)) - { - if (raise_error) - XD_ERROR (derror); - else - connection = NULL; - } - - /* If it is not the system or session bus, we must register - ourselves. Otherwise, we have called dbus_bus_get, which has - configured us to exit if the connection closes - we undo this - setting. */ - if (connection != NULL) - { - if (STRINGP (bus)) - dbus_bus_register (connection, &derror); - else - dbus_connection_set_exit_on_disconnect (connection, FALSE); - } - - if (dbus_error_is_set (&derror)) - { - if (raise_error) - XD_ERROR (derror); - else - connection = NULL; - } - - if (connection == NULL && raise_error) + connection = (DBusConnection *) XFASTINT (val); + + if (!dbus_connection_get_is_connected (connection)) XD_SIGNAL2 (build_string ("No connection to bus"), bus); - /* Cleanup. */ - dbus_error_free (&derror); - - /* Return the result. */ return connection; } @@ -896,8 +920,8 @@ int fd = xd_find_watch_fd (watch); XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d", - fd, flags & DBUS_WATCH_WRITABLE, - dbus_watch_get_enabled (watch)); + fd, flags & DBUS_WATCH_WRITABLE, + dbus_watch_get_enabled (watch)); if (fd == -1) return FALSE; @@ -929,8 +953,8 @@ /* Unset session environment. */ if (XSYMBOL (QCdbus_session_bus) == data) { - XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS"); - unsetenv ("DBUS_SESSION_BUS_ADDRESS"); + // XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS"); + // unsetenv ("DBUS_SESSION_BUS_ADDRESS"); } if (flags & DBUS_WATCH_WRITABLE) @@ -949,23 +973,111 @@ xd_remove_watch (watch, data); } -DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0, - doc: /* Initialize connection to D-Bus BUS. */) - (Lisp_Object bus) -{ - DBusConnection *connection; - void *busp; +/* Close connection to D-Bus BUS. */ +static void +xd_close_bus (Lisp_Object bus) +{ + DBusConnection *connection; + Lisp_Object val; + + /* Check whether we are connected. */ + val = Fassoc (bus, Vdbus_registered_buses); + if (NILP (val)) + return; + + /* Retrieve bus address. */ + connection = xd_get_connection_address (bus); + + /* Close connection, if there isn't another shared application. */ + if (xd_get_connection_references (connection) == 1) + { + XD_DEBUG_MESSAGE ("Close connection to bus %s", + XD_OBJECT_TO_STRING (bus)); + dbus_connection_close (connection); + } + + /* Decrement reference count. */ + dbus_connection_unref (connection); + + /* Remove bus from list of registered buses. */ + Vdbus_registered_buses = Fdelete (val, Vdbus_registered_buses); + + /* Return. */ + return; +} + +DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 2, 0, + doc: /* Establish the connection to D-Bus 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. + +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; + int refcount; /* Check parameter. */ - if (SYMBOLP (bus)) - busp = XSYMBOL (bus); - else if (STRINGP (bus)) - busp = XSTRING (bus); - else - wrong_type_argument (intern ("D-Bus"), bus); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); + XD_DBUS_VALIDATE_BUS_ADDRESS (bus); + + /* Close bus if it is already open. */ + xd_close_bus (bus); + + /* 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 + if (NILP (private)) + connection = dbus_bus_get (EQ (bus, QCdbus_system_bus) + ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION, + &derror); + else + connection = dbus_bus_get_private (EQ (bus, QCdbus_system_bus) + ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION, + &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, 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. */ @@ -973,36 +1085,27 @@ xd_add_watch, xd_remove_watch, xd_toggle_watch, - busp, NULL)) + SYMBOLP (bus) + ? (void *) XSYMBOL (bus) + : (void *) XSTRING (bus), + NULL)) XD_SIGNAL1 (build_string ("Cannot add watch functions")); /* Add bus to list of registered buses. */ - Vdbus_registered_buses = Fcons (bus, Vdbus_registered_buses); + XSETFASTINT (val, connection); + Vdbus_registered_buses = Fcons (Fcons (bus, val), Vdbus_registered_buses); /* We do not want to abort. */ putenv ((char *) "DBUS_FATAL_WARNINGS=0"); - /* Return. */ - return Qnil; -} - -DEFUN ("dbus-close-bus", Fdbus_close_bus, Sdbus_close_bus, 1, 1, 0, - doc: /* Close connection to D-Bus BUS. */) - (Lisp_Object bus) -{ - DBusConnection *connection; - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Decrement reference count to the bus. */ - dbus_connection_unref (connection); - - /* Remove bus from list of registered buses. */ - Vdbus_registered_buses = Fdelete (bus, Vdbus_registered_buses); - - /* Return. */ - return Qnil; + /* Cleanup. */ + dbus_error_free (&derror); + + /* Return reference counter. */ + refcount = xd_get_connection_references (connection); + XD_DEBUG_MESSAGE ("Bus %s, Reference counter %d", + XD_OBJECT_TO_STRING (bus), refcount); + return make_number (refcount); } DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name, @@ -1013,8 +1116,11 @@ DBusConnection *connection; const char *name; - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); + /* 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); @@ -1025,341 +1131,241 @@ return build_string (name); } -DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0, - doc: /* Call METHOD on the D-Bus BUS. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name to be used. PATH is the D-Bus -object path SERVICE is registered at. INTERFACE is an interface -offered by SERVICE. It must provide METHOD. - -If the parameter `:timeout' is given, the following integer TIMEOUT -specifies the maximum number of milliseconds the method call must -return. The default value is 25,000. If the method call doesn't -return in time, a D-Bus error is raised. - -All other arguments ARGS are passed to METHOD as arguments. They are -converted into D-Bus types via the following rules: - - t and nil => DBUS_TYPE_BOOLEAN - number => DBUS_TYPE_UINT32 - integer => DBUS_TYPE_INT32 - float => DBUS_TYPE_DOUBLE - string => DBUS_TYPE_STRING - list => DBUS_TYPE_ARRAY - -All arguments can be preceded by a type symbol. For details about -type symbols, see Info node `(dbus)Type Conversion'. - -`dbus-call-method' returns the resulting values of METHOD as a list of -Lisp objects. The type conversion happens the other direction as for -input arguments. It follows the mapping rules: - - DBUS_TYPE_BOOLEAN => t or nil - DBUS_TYPE_BYTE => number - DBUS_TYPE_UINT16 => number - DBUS_TYPE_INT16 => integer - DBUS_TYPE_UINT32 => number or float - DBUS_TYPE_UNIX_FD => number or float - DBUS_TYPE_INT32 => integer or float - DBUS_TYPE_UINT64 => number or float - DBUS_TYPE_INT64 => integer or float - DBUS_TYPE_DOUBLE => float - DBUS_TYPE_STRING => string - DBUS_TYPE_OBJECT_PATH => string - DBUS_TYPE_SIGNATURE => string - DBUS_TYPE_ARRAY => list - DBUS_TYPE_VARIANT => list - DBUS_TYPE_STRUCT => list - DBUS_TYPE_DICT_ENTRY => list - -Example: - -\(dbus-call-method - :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp" - "org.gnome.seahorse.Keys" "GetKeyField" - "openpgp:657984B8C7A966DD" "simple-name") - - => (t ("Philip R. Zimmermann")) - -If the result of the METHOD call is just one value, the converted Lisp -object is returned instead of a list containing this single Lisp object. - -\(dbus-call-method - :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer" - "org.freedesktop.Hal.Device" "GetPropertyString" - "system.kernel.machine") - - => "i686" - -usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service, path, interface, method; - Lisp_Object result; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; - DBusConnection *connection; - DBusMessage *dmessage; - DBusMessage *reply; - DBusMessageIter iter; - DBusError derror; - unsigned int dtype; - int timeout = -1; - ptrdiff_t i = 5; - char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; - - /* Check parameters. */ - bus = args[0]; - service = args[1]; - path = args[2]; - interface = args[3]; - method = args[4]; - - CHECK_STRING (service); - CHECK_STRING (path); - CHECK_STRING (interface); - CHECK_STRING (method); - GCPRO5 (bus, service, path, interface, method); - - XD_DEBUG_MESSAGE ("%s %s %s %s", - SDATA (service), - SDATA (path), - SDATA (interface), - SDATA (method)); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create the message. */ - dmessage = dbus_message_new_method_call (SSDATA (service), - SSDATA (path), - SSDATA (interface), - SSDATA (method)); - UNGCPRO; - if (dmessage == NULL) - XD_SIGNAL1 (build_string ("Unable to create a new message")); - - /* Check for timeout parameter. */ - if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout))) - { - CHECK_NATNUM (args[i+1]); - timeout = XFASTINT (args[i+1]); - i = i+2; - } - - /* Initialize parameter list of message. */ - dbus_message_iter_init_append (dmessage, &iter); - - /* Append parameters to the message. */ - for (; i < nargs; ++i) - { - dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]); - if (XD_DBUS_TYPE_P (args[i])) - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil)), - SDATA (format2 ("%s", args[i+1], Qnil))); - ++i; - } - else - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil))); - } - - /* 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[i]); - - xd_append_arg (dtype, args[i], &iter); - } - - /* Send the message. */ - dbus_error_init (&derror); - reply = dbus_connection_send_with_reply_and_block (connection, - dmessage, - timeout, - &derror); - - if (dbus_error_is_set (&derror)) - XD_ERROR (derror); - - if (reply == NULL) - XD_SIGNAL1 (build_string ("No reply")); - - XD_DEBUG_MESSAGE ("Message sent"); - - /* Collect the results. */ - result = Qnil; - GCPRO1 (result); - - if (dbus_message_iter_init (reply, &iter)) - { - /* Loop over the parameters of the D-Bus reply message. Construct a - Lisp list, which is returned by `dbus-call-method'. */ - while ((dtype = dbus_message_iter_get_arg_type (&iter)) - != DBUS_TYPE_INVALID) - { - result = Fcons (xd_retrieve_arg (dtype, &iter), result); - dbus_message_iter_next (&iter); - } - } - else - { - /* No arguments: just return nil. */ - } - - /* Cleanup. */ - dbus_error_free (&derror); - dbus_message_unref (dmessage); - dbus_message_unref (reply); - - /* Return the result. If there is only one single Lisp object, - return it as-it-is, otherwise return the reversed list. */ - if (XFASTINT (Flength (result)) == 1) - RETURN_UNGCPRO (CAR_SAFE (result)); - else - RETURN_UNGCPRO (Fnreverse (result)); -} - -DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously, - Sdbus_call_method_asynchronously, 6, MANY, 0, - doc: /* Call METHOD on the D-Bus BUS asynchronously. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name to be used. PATH is the D-Bus -object path SERVICE is registered at. INTERFACE is an interface -offered by SERVICE. It must provide METHOD. - -HANDLER is a Lisp function, which is called when the corresponding -return message has arrived. If HANDLER is nil, no return message will -be expected. - -If the parameter `:timeout' is given, the following integer TIMEOUT -specifies the maximum number of milliseconds the method call must -return. The default value is 25,000. If the method call doesn't -return in time, a D-Bus error is raised. - -All other arguments ARGS are passed to METHOD as arguments. They are -converted into D-Bus types via the following rules: - - t and nil => DBUS_TYPE_BOOLEAN - number => DBUS_TYPE_UINT32 - integer => DBUS_TYPE_INT32 - float => DBUS_TYPE_DOUBLE - string => DBUS_TYPE_STRING - list => DBUS_TYPE_ARRAY - -All arguments can be preceded by a type symbol. For details about -type symbols, see Info node `(dbus)Type Conversion'. - -Unless HANDLER is nil, the function returns a key into the hash table -`dbus-registered-objects-table'. The corresponding entry in the hash -table is removed, when the return message has been arrived, and -HANDLER is called. - -Example: - -\(dbus-call-method-asynchronously - :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer" - "org.freedesktop.Hal.Device" "GetPropertyString" 'message - "system.kernel.machine") - - => (:system 2) - - -| i686 - -usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service, path, interface, method, handler; +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 &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 result; struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6; DBusConnection *connection; DBusMessage *dmessage; DBusMessageIter iter; unsigned int dtype; - dbus_uint32_t serial; + unsigned int mtype; + dbus_uint32_t serial = 0; int timeout = -1; - ptrdiff_t i = 6; + ptrdiff_t count; char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; + /* Initialize parameters. */ + message_type = args[0]; + bus = args[1]; + service = args[2]; + handler = Qnil; + + CHECK_NATNUM (message_type); + mtype = XFASTINT (message_type); + if ((mtype <= DBUS_MESSAGE_TYPE_INVALID) || (mtype >= DBUS_NUM_MESSAGE_TYPES)) + XD_SIGNAL2 (build_string ("Invalid message type"), 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 /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + { + XD_CHECK_DBUS_SERIAL (args[3], serial); + count = 4; + } + /* Check parameters. */ - bus = args[0]; - service = args[1]; - path = args[2]; - interface = args[3]; - method = args[4]; - handler = args[5]; - - CHECK_STRING (service); - CHECK_STRING (path); - CHECK_STRING (interface); - CHECK_STRING (method); - if (!NILP (handler) && !FUNCTIONP (handler)) - wrong_type_argument (Qinvalid_function, handler); - GCPRO6 (bus, service, path, interface, method, handler); - - XD_DEBUG_MESSAGE ("%s %s %s %s", - SDATA (service), - SDATA (path), - SDATA (interface), - SDATA (method)); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create the message. */ - dmessage = dbus_message_new_method_call (SSDATA (service), - SSDATA (path), - SSDATA (interface), - SSDATA (method)); + XD_DBUS_VALIDATE_BUS_ADDRESS (bus); + XD_DBUS_VALIDATE_BUS_NAME (service); + if (nargs < count) + xsignal2 (Qwrong_number_of_arguments, + Qdbus_message_internal, + make_number (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); + } + + /* Protect Lisp variables. */ + GCPRO6 (bus, service, path, interface, member, 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; + default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + XD_DEBUG_MESSAGE ("%s %s %s %u", + XD_MESSAGE_TYPE_TO_STRING (mtype), + XD_OBJECT_TO_STRING (bus), + XD_OBJECT_TO_STRING (service), + serial); + } + + /* Retrieve bus address. */ + connection = xd_get_connection_address (bus); + + /* Create the D-Bus message. */ + dmessage = dbus_message_new (mtype); if (dmessage == NULL) - XD_SIGNAL1 (build_string ("Unable to create a new message")); + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Unable to create a new message")); + } + + if (STRINGP (service)) + { + if (mtype != DBUS_MESSAGE_TYPE_SIGNAL) + /* Set destination. */ + { + if (!dbus_message_set_destination (dmessage, SSDATA (service))) + { + UNGCPRO; + 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 (intern ("dbus-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)))) + { + UNGCPRO; + 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)))) + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Unable to set the message parameter")); + } + } + + else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + { + if (!dbus_message_set_reply_serial (dmessage, serial)) + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Unable to create a return message")); + } + + if ((mtype == DBUS_MESSAGE_TYPE_ERROR) + && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))) + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Unable to create a error message")); + } + } /* Check for timeout parameter. */ - if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout))) + if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout))) { - CHECK_NATNUM (args[i+1]); - timeout = XFASTINT (args[i+1]); - i = i+2; + CHECK_NATNUM (args[count+1]); + timeout = XFASTINT (args[count+1]); + count = count+2; } /* Initialize parameter list of message. */ dbus_message_iter_init_append (dmessage, &iter); /* Append parameters to the message. */ - for (; i < nargs; ++i) + for (; count < nargs; ++count) { - dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]); - if (XD_DBUS_TYPE_P (args[i])) + dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]); + if (XD_DBUS_TYPE_P (args[count])) { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil)), - SDATA (format2 ("%s", args[i+1], Qnil))); - ++i; + XD_DEBUG_VALID_LISP_OBJECT_P (args[count]); + XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]); + XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4, + XD_OBJECT_TO_STRING (args[count]), + XD_OBJECT_TO_STRING (args[count+1])); + ++count; } else { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil))); + XD_DEBUG_VALID_LISP_OBJECT_P (args[count]); + XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4, + 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[i]); + xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]); - xd_append_arg (dtype, args[i], &iter); + xd_append_arg (dtype, args[count], &iter); } if (!NILP (handler)) @@ -1368,11 +1374,15 @@ message queue. */ if (!dbus_connection_send_with_reply (connection, dmessage, NULL, timeout)) - XD_SIGNAL1 (build_string ("Cannot send message")); + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Cannot send message")); + } /* The result is the key in Vdbus_registered_objects_table. */ serial = dbus_message_get_serial (dmessage); - result = list2 (bus, make_fixnum_or_float (serial)); + result = list3 (QCdbus_registered_serial, + bus, make_fixnum_or_float (serial)); /* Create a hash table entry. */ Fputhash (result, handler, Vdbus_registered_objects_table); @@ -1382,12 +1392,15 @@ /* 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")); + { + UNGCPRO; + XD_SIGNAL1 (build_string ("Cannot send message")); + } result = Qnil; } - XD_DEBUG_MESSAGE ("Message sent"); + XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result)); /* Cleanup. */ dbus_message_unref (dmessage); @@ -1396,300 +1409,6 @@ RETURN_UNGCPRO (result); } -DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal, - Sdbus_method_return_internal, - 3, MANY, 0, - doc: /* Return for message SERIAL on the D-Bus BUS. -This is an internal function, it shall not be used outside dbus.el. - -usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service; - struct gcpro gcpro1, gcpro2; - DBusConnection *connection; - DBusMessage *dmessage; - DBusMessageIter iter; - dbus_uint32_t serial; - unsigned int ui_serial, dtype; - ptrdiff_t i; - char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; - - /* Check parameters. */ - bus = args[0]; - service = args[2]; - - CHECK_DBUS_SERIAL_GET_SERIAL (args[1], serial); - CHECK_STRING (service); - GCPRO2 (bus, service); - - ui_serial = serial; - XD_DEBUG_MESSAGE ("%u %s ", ui_serial, SSDATA (service)); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create the message. */ - dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN); - if ((dmessage == NULL) - || (!dbus_message_set_reply_serial (dmessage, serial)) - || (!dbus_message_set_destination (dmessage, SSDATA (service)))) - { - UNGCPRO; - XD_SIGNAL1 (build_string ("Unable to create a return message")); - } - - UNGCPRO; - - /* Initialize parameter list of message. */ - dbus_message_iter_init_append (dmessage, &iter); - - /* Append parameters to the message. */ - for (i = 3; i < nargs; ++i) - { - dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]); - if (XD_DBUS_TYPE_P (args[i])) - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", i - 2, - SDATA (format2 ("%s", args[i], Qnil)), - SDATA (format2 ("%s", args[i+1], Qnil))); - ++i; - } - else - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", i - 2, - SDATA (format2 ("%s", args[i], Qnil))); - } - - /* 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[i]); - - xd_append_arg (dtype, args[i], &iter); - } - - /* 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")); - - XD_DEBUG_MESSAGE ("Message sent"); - - /* Cleanup. */ - dbus_message_unref (dmessage); - - /* Return. */ - return Qt; -} - -DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal, - Sdbus_method_error_internal, - 3, MANY, 0, - doc: /* Return error message for message SERIAL on the D-Bus BUS. -This is an internal function, it shall not be used outside dbus.el. - -usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service; - struct gcpro gcpro1, gcpro2; - DBusConnection *connection; - DBusMessage *dmessage; - DBusMessageIter iter; - dbus_uint32_t serial; - unsigned int ui_serial, dtype; - ptrdiff_t i; - char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; - - /* Check parameters. */ - bus = args[0]; - service = args[2]; - - CHECK_DBUS_SERIAL_GET_SERIAL (args[1], serial); - CHECK_STRING (service); - GCPRO2 (bus, service); - - ui_serial = serial; - XD_DEBUG_MESSAGE ("%u %s ", ui_serial, SSDATA (service)); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create the message. */ - dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR); - if ((dmessage == NULL) - || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)) - || (!dbus_message_set_reply_serial (dmessage, serial)) - || (!dbus_message_set_destination (dmessage, SSDATA (service)))) - { - UNGCPRO; - XD_SIGNAL1 (build_string ("Unable to create a error message")); - } - - UNGCPRO; - - /* Initialize parameter list of message. */ - dbus_message_iter_init_append (dmessage, &iter); - - /* Append parameters to the message. */ - for (i = 3; i < nargs; ++i) - { - dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]); - if (XD_DBUS_TYPE_P (args[i])) - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", i - 2, - SDATA (format2 ("%s", args[i], Qnil)), - SDATA (format2 ("%s", args[i+1], Qnil))); - ++i; - } - else - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", i - 2, - SDATA (format2 ("%s", args[i], Qnil))); - } - - /* 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[i]); - - xd_append_arg (dtype, args[i], &iter); - } - - /* 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")); - - XD_DEBUG_MESSAGE ("Message sent"); - - /* Cleanup. */ - dbus_message_unref (dmessage); - - /* Return. */ - return Qt; -} - -DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0, - doc: /* Send signal SIGNAL on the D-Bus BUS. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the -D-Bus object path SERVICE is registered at. INTERFACE is an interface -offered by SERVICE. It must provide signal SIGNAL. - -All other arguments ARGS are passed to SIGNAL as arguments. They are -converted into D-Bus types via the following rules: - - t and nil => DBUS_TYPE_BOOLEAN - number => DBUS_TYPE_UINT32 - integer => DBUS_TYPE_INT32 - float => DBUS_TYPE_DOUBLE - string => DBUS_TYPE_STRING - list => DBUS_TYPE_ARRAY - -All arguments can be preceded by a type symbol. For details about -type symbols, see Info node `(dbus)Type Conversion'. - -Example: - -\(dbus-send-signal - :session "org.gnu.Emacs" "/org/gnu/Emacs" - "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs") - -usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service, path, interface, signal; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; - DBusConnection *connection; - DBusMessage *dmessage; - DBusMessageIter iter; - unsigned int dtype; - ptrdiff_t i; - char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; - - /* Check parameters. */ - bus = args[0]; - service = args[1]; - path = args[2]; - interface = args[3]; - signal = args[4]; - - CHECK_STRING (service); - CHECK_STRING (path); - CHECK_STRING (interface); - CHECK_STRING (signal); - GCPRO5 (bus, service, path, interface, signal); - - XD_DEBUG_MESSAGE ("%s %s %s %s", - SDATA (service), - SDATA (path), - SDATA (interface), - SDATA (signal)); - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create the message. */ - dmessage = dbus_message_new_signal (SSDATA (path), - SSDATA (interface), - SSDATA (signal)); - UNGCPRO; - if (dmessage == NULL) - XD_SIGNAL1 (build_string ("Unable to create a new message")); - - /* Initialize parameter list of message. */ - dbus_message_iter_init_append (dmessage, &iter); - - /* Append parameters to the message. */ - for (i = 5; i < nargs; ++i) - { - dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]); - if (XD_DBUS_TYPE_P (args[i])) - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil)), - SDATA (format2 ("%s", args[i+1], Qnil))); - ++i; - } - else - { - XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", i - 4, - SDATA (format2 ("%s", args[i], Qnil))); - } - - /* 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[i]); - - xd_append_arg (dtype, args[i], &iter); - } - - /* 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")); - - XD_DEBUG_MESSAGE ("Signal sent"); - - /* Cleanup. */ - dbus_message_unref (dmessage); - - /* Return. */ - return Qt; -} - /* Read one queued incoming message of the D-Bus BUS. BUS is either a Lisp symbol, :system or :session, or a string denoting the bus address. */ @@ -1702,7 +1421,7 @@ DBusMessage *dmessage; DBusMessageIter iter; unsigned int dtype; - int mtype; + unsigned int mtype; dbus_uint32_t serial; unsigned int ui_serial; const char *uname, *path, *interface, *member; @@ -1744,23 +1463,19 @@ member = dbus_message_get_member (dmessage); XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s", - (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", + XD_MESSAGE_TYPE_TO_STRING (mtype), ui_serial, uname, path, interface, member, - SDATA (format2 ("%s", args, Qnil))); - - if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) - || (mtype == DBUS_MESSAGE_TYPE_ERROR)) + 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 = list2 (bus, make_fixnum_or_float (serial)); + key = list3 (QCdbus_registered_serial, bus, + make_fixnum_or_float (serial)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); /* There shall be exactly one entry. Construct an event. */ @@ -1777,7 +1492,7 @@ event.arg = Fcons (value, args); } - else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN) */ + else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ { /* Vdbus_registered_objects_table requires non-nil interface and member. */ @@ -1785,7 +1500,10 @@ goto cleanup; /* Search for a registered function of the message. */ - key = list3 (bus, build_string (interface), build_string (member)); + key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) + ? QCdbus_registered_method + : QCdbus_registered_signal, + bus, build_string (interface), build_string (member)); value = Fgethash (key, Vdbus_registered_objects_table, Qnil); /* Loop over the registered functions. Construct an event. */ @@ -1835,8 +1553,7 @@ /* Store it into the input event queue. */ kbd_buffer_store_event (&event); - XD_DEBUG_MESSAGE ("Event stored: %s", - SDATA (format2 ("%s", event.arg, Qnil))); + XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg)); /* Cleanup. */ cleanup: @@ -1851,8 +1568,8 @@ static Lisp_Object xd_read_message (Lisp_Object bus) { - /* Open a connection to the bus. */ - DBusConnection *connection = xd_initialize (bus, TRUE); + /* Retrieve bus address. */ + DBusConnection *connection = xd_get_connection_address (bus); /* Non blocking read of the next available message. */ dbus_connection_read_write (connection, 0); @@ -1869,14 +1586,16 @@ { Lisp_Object busp = Vdbus_registered_buses; Lisp_Object bus = Qnil; + Lisp_Object key; /* Find bus related to fd. */ if (data != NULL) while (!NILP (busp)) { - if ((SYMBOLP (CAR_SAFE (busp)) && XSYMBOL (CAR_SAFE (busp)) == data) - || (STRINGP (CAR_SAFE (busp)) && XSTRING (CAR_SAFE (busp)) == data)) - bus = CAR_SAFE (busp); + key = CAR_SAFE (CAR_SAFE (busp)); + if ((SYMBOLP (key) && XSYMBOL (key) == data) + || (STRINGP (key) && XSTRING (key) == data)) + bus = key; busp = CDR_SAFE (busp); } @@ -1889,327 +1608,6 @@ xd_in_read_queued_messages = 0; } -DEFUN ("dbus-register-service", Fdbus_register_service, Sdbus_register_service, - 2, MANY, 0, - doc: /* Register known name SERVICE on the D-Bus BUS. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name that should be registered. It must -be a known name. - -FLAGS are keywords, which control how the service name is registered. -The following keywords are recognized: - -`:allow-replacement': Allow another service to become the primary -owner if requested. - -`:replace-existing': Request to replace the current primary owner. - -`:do-not-queue': If we can not become the primary owner do not place -us in the queue. - -The function returns a keyword, indicating the result of the -operation. One of the following keywords is returned: - -`:primary-owner': Service has become the primary owner of the -requested name. - -`:in-queue': Service could not become the primary owner and has been -placed in the queue. - -`:exists': Service is already in the queue. - -`:already-owner': Service is already the primary owner. - -Example: - -\(dbus-register-service :session dbus-service-emacs) - - => :primary-owner. - -\(dbus-register-service - :session "org.freedesktop.TextEditor" - dbus-service-allow-replacement dbus-service-replace-existing) - - => :already-owner. - -usage: (dbus-register-service BUS SERVICE &rest FLAGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service; - DBusConnection *connection; - ptrdiff_t i; - unsigned int value; - unsigned int flags = 0; - int result; - DBusError derror; - - bus = args[0]; - service = args[1]; - - /* Check parameters. */ - CHECK_STRING (service); - - /* Process flags. */ - for (i = 2; i < nargs; ++i) { - value = ((EQ (args[i], QCdbus_request_name_replace_existing)) - ? DBUS_NAME_FLAG_REPLACE_EXISTING - : (EQ (args[i], QCdbus_request_name_allow_replacement)) - ? DBUS_NAME_FLAG_ALLOW_REPLACEMENT - : (EQ (args[i], QCdbus_request_name_do_not_queue)) - ? DBUS_NAME_FLAG_DO_NOT_QUEUE - : -1); - if (value == -1) - XD_SIGNAL2 (build_string ("Unrecognized name request flag"), args[i]); - flags |= value; - } - - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Request the known name from the bus. */ - dbus_error_init (&derror); - result = dbus_bus_request_name (connection, SSDATA (service), flags, - &derror); - if (dbus_error_is_set (&derror)) - XD_ERROR (derror); - - /* Cleanup. */ - dbus_error_free (&derror); - - /* Return object. */ - switch (result) - { - case DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER: - return QCdbus_request_name_reply_primary_owner; - case DBUS_REQUEST_NAME_REPLY_IN_QUEUE: - return QCdbus_request_name_reply_in_queue; - case DBUS_REQUEST_NAME_REPLY_EXISTS: - return QCdbus_request_name_reply_exists; - case DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER: - return QCdbus_request_name_reply_already_owner; - default: - /* This should not happen. */ - XD_SIGNAL2 (build_string ("Could not register service"), service); - } -} - -DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal, - 6, MANY, 0, - doc: /* Register for signal SIGNAL on the D-Bus BUS. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name used by the sending D-Bus object. -It can be either a known name or the unique name of the D-Bus object -sending the signal. When SERVICE is nil, related signals from all -D-Bus objects shall be accepted. - -PATH is the D-Bus object path SERVICE is registered. It can also be -nil if the path name of incoming signals shall not be checked. - -INTERFACE is an interface offered by SERVICE. It must provide SIGNAL. -HANDLER is a Lisp function to be called when the signal is received. -It must accept as arguments the values SIGNAL is sending. - -All other arguments ARGS, if specified, must be strings. They stand -for the respective arguments of the signal in their order, and are -used for filtering as well. A nil argument might be used to preserve -the order. - -INTERFACE, SIGNAL and HANDLER must not be nil. Example: - -\(defun my-signal-handler (device) - (message "Device %s added" device)) - -\(dbus-register-signal - :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" - "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler) - - => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded") - ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler)) - -`dbus-register-signal' returns an object, which can be used in -`dbus-unregister-object' for removing the registration. - -usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */) - (ptrdiff_t nargs, Lisp_Object *args) -{ - Lisp_Object bus, service, path, interface, signal, handler; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6; - Lisp_Object uname, key, key1, value; - DBusConnection *connection; - ptrdiff_t i; - char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; - int rulelen; - DBusError derror; - - /* Check parameters. */ - bus = args[0]; - service = args[1]; - path = args[2]; - interface = args[3]; - signal = args[4]; - handler = args[5]; - - if (!NILP (service)) CHECK_STRING (service); - if (!NILP (path)) CHECK_STRING (path); - CHECK_STRING (interface); - CHECK_STRING (signal); - if (!FUNCTIONP (handler)) - wrong_type_argument (Qinvalid_function, handler); - GCPRO6 (bus, service, path, interface, signal, handler); - - /* Retrieve unique name of service. If service is a known name, we - will register for the corresponding unique name, if any. Signals - are sent always with the unique name as sender. Note: the unique - name of "org.freedesktop.DBus" is that string itself. */ - if ((STRINGP (service)) - && (SBYTES (service) > 0) - && (strcmp (SSDATA (service), DBUS_SERVICE_DBUS) != 0) - && (strncmp (SSDATA (service), ":", 1) != 0)) - uname = call2 (intern ("dbus-get-name-owner"), bus, service); - else - uname = service; - - /* Create a matching rule if the unique name exists (when no - wildcard). */ - if (NILP (uname) || (SBYTES (uname) > 0)) - { - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Create a rule to receive related signals. */ - rulelen = snprintf (rule, sizeof rule, - "type='signal',interface='%s',member='%s'", - SDATA (interface), - SDATA (signal)); - if (! (0 <= rulelen && rulelen < sizeof rule)) - string_overflow (); - - /* Add unique name and path to the rule if they are non-nil. */ - if (!NILP (uname)) - { - int len = snprintf (rule + rulelen, sizeof rule - rulelen, - ",sender='%s'", SDATA (uname)); - if (! (0 <= len && len < sizeof rule - rulelen)) - string_overflow (); - rulelen += len; - } - - if (!NILP (path)) - { - int len = snprintf (rule + rulelen, sizeof rule - rulelen, - ",path='%s'", SDATA (path)); - if (! (0 <= len && len < sizeof rule - rulelen)) - string_overflow (); - rulelen += len; - } - - /* Add arguments to the rule if they are non-nil. */ - for (i = 6; i < nargs; ++i) - if (!NILP (args[i])) - { - int len; - CHECK_STRING (args[i]); - len = snprintf (rule + rulelen, sizeof rule - rulelen, - ",arg%"pD"d='%s'", i - 6, SDATA (args[i])); - if (! (0 <= len && len < sizeof rule - rulelen)) - string_overflow (); - rulelen += len; - } - - /* Add the rule to the bus. */ - dbus_error_init (&derror); - dbus_bus_add_match (connection, rule, &derror); - if (dbus_error_is_set (&derror)) - { - UNGCPRO; - XD_ERROR (derror); - } - - /* Cleanup. */ - dbus_error_free (&derror); - - XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule); - } - - /* Create a hash table entry. */ - key = list3 (bus, interface, signal); - key1 = list5 (uname, service, path, handler, build_string (rule)); - value = Fgethash (key, Vdbus_registered_objects_table, Qnil); - - if (NILP (Fmember (key1, value))) - Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table); - - /* Return object. */ - RETURN_UNGCPRO (list2 (key, list3 (service, path, handler))); -} - -DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method, - 6, 7, 0, - doc: /* Register for method METHOD on the D-Bus BUS. - -BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. - -SERVICE is the D-Bus service name of the D-Bus object METHOD is -registered for. It must be a known name (See discussion of -DONT-REGISTER-SERVICE below). - -PATH is the D-Bus object path SERVICE is registered (See discussion of -DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by -SERVICE. It must provide METHOD. - -HANDLER is a Lisp function to be called when a method call is -received. It must accept the input arguments of METHOD. The return -value of HANDLER is used for composing the returning D-Bus message. -In case HANDLER shall return a reply message with an empty argument -list, HANDLER must return the symbol `:ignore'. - -When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not -registered. This means that other D-Bus clients have no way of -noticing the newly registered method. When interfaces are constructed -incrementally by adding single methods or properties at a time, -DONT-REGISTER-SERVICE can be used to prevent other clients from -discovering the still incomplete interface.*/) - (Lisp_Object bus, Lisp_Object service, Lisp_Object path, - Lisp_Object interface, Lisp_Object method, Lisp_Object handler, - Lisp_Object dont_register_service) -{ - Lisp_Object key, key1, value; - Lisp_Object args[2] = { bus, service }; - - /* Check parameters. */ - CHECK_STRING (service); - CHECK_STRING (path); - CHECK_STRING (interface); - CHECK_STRING (method); - if (!FUNCTIONP (handler)) - wrong_type_argument (Qinvalid_function, handler); - /* TODO: We must check for a valid service name, otherwise there is - a segmentation fault. */ - - /* Request the name. */ - if (NILP (dont_register_service)) - Fdbus_register_service (2, args); - - /* Create a hash table entry. We use nil for the unique name, - because the method might be called from anybody. */ - key = list3 (bus, interface, method); - key1 = list4 (Qnil, service, path, handler); - value = Fgethash (key, Vdbus_registered_objects_table, Qnil); - - if (NILP (Fmember (key1, value))) - Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table); - - /* Return object. */ - return list2 (key, list3 (service, path, handler)); -} - void syms_of_dbusbind (void) @@ -2218,35 +1616,11 @@ DEFSYM (Qdbus_init_bus, "dbus-init-bus"); defsubr (&Sdbus_init_bus); - DEFSYM (Qdbus_close_bus, "dbus-close-bus"); - defsubr (&Sdbus_close_bus); - DEFSYM (Qdbus_get_unique_name, "dbus-get-unique-name"); defsubr (&Sdbus_get_unique_name); - DEFSYM (Qdbus_call_method, "dbus-call-method"); - defsubr (&Sdbus_call_method); - - DEFSYM (Qdbus_call_method_asynchronously, "dbus-call-method-asynchronously"); - defsubr (&Sdbus_call_method_asynchronously); - - DEFSYM (Qdbus_method_return_internal, "dbus-method-return-internal"); - defsubr (&Sdbus_method_return_internal); - - DEFSYM (Qdbus_method_error_internal, "dbus-method-error-internal"); - defsubr (&Sdbus_method_error_internal); - - DEFSYM (Qdbus_send_signal, "dbus-send-signal"); - defsubr (&Sdbus_send_signal); - - DEFSYM (Qdbus_register_service, "dbus-register-service"); - defsubr (&Sdbus_register_service); - - DEFSYM (Qdbus_register_signal, "dbus-register-signal"); - defsubr (&Sdbus_register_signal); - - DEFSYM (Qdbus_register_method, "dbus-register-method"); - defsubr (&Sdbus_register_method); + DEFSYM (Qdbus_message_internal, "dbus-message-internal"); + defsubr (&Sdbus_message_internal); DEFSYM (Qdbus_error, "dbus-error"); Fput (Qdbus_error, Qerror_conditions, @@ -2256,13 +1630,6 @@ DEFSYM (QCdbus_system_bus, ":system"); DEFSYM (QCdbus_session_bus, ":session"); - DEFSYM (QCdbus_request_name_allow_replacement, ":allow-replacement"); - DEFSYM (QCdbus_request_name_replace_existing, ":replace-existing"); - DEFSYM (QCdbus_request_name_do_not_queue, ":do-not-queue"); - DEFSYM (QCdbus_request_name_reply_primary_owner, ":primary-owner"); - DEFSYM (QCdbus_request_name_reply_exists, ":exists"); - DEFSYM (QCdbus_request_name_reply_in_queue, ":in-queue"); - DEFSYM (QCdbus_request_name_reply_already_owner, ":already-owner"); DEFSYM (QCdbus_timeout, ":timeout"); DEFSYM (QCdbus_type_byte, ":byte"); DEFSYM (QCdbus_type_boolean, ":boolean"); @@ -2276,19 +1643,73 @@ DEFSYM (QCdbus_type_string, ":string"); DEFSYM (QCdbus_type_object_path, ":object-path"); DEFSYM (QCdbus_type_signature, ":signature"); - #ifdef DBUS_TYPE_UNIX_FD DEFSYM (QCdbus_type_unix_fd, ":unix-fd"); #endif - DEFSYM (QCdbus_type_array, ":array"); DEFSYM (QCdbus_type_variant, ":variant"); DEFSYM (QCdbus_type_struct, ":struct"); DEFSYM (QCdbus_type_dict_entry, ":dict-entry"); + DEFSYM (QCdbus_registered_serial, ":serial"); + DEFSYM (QCdbus_registered_method, ":method"); + DEFSYM (QCdbus_registered_signal, ":signal"); + + 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 = make_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[1024]; + dbus_get_version (&major, &minor, µ); + snprintf (s, sizeof s, "%d.%d.%d", major, minor, micro); + Vdbus_runtime_version = make_string (s, strlen (s)); +#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_number (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_number (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_number (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_number (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_number (DBUS_MESSAGE_TYPE_SIGNAL); DEFVAR_LISP ("dbus-registered-buses", Vdbus_registered_buses, - doc: /* List of D-Bus buses we are polling for messages. */); + doc: /* 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. */); Vdbus_registered_buses = Qnil; DEFVAR_LISP ("dbus-registered-objects-table", @@ -2299,27 +1720,28 @@ registered interfaces properties, targeted by signals or method calls, 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 (BUS -INTERFACE MEMBER). BUS is either a Lisp symbol, `:system' or +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' or `:property'. BUS is either a Lisp symbol, `:system' or `:session', 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 but BUS must not be nil. -The value in the hash table is a list of quadruple lists -\((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...). -SERVICE is the service name as registered, UNAME is the corresponding -unique name. In case of registered methods and properties, 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 (methods and signals), or a cons cell containing the value of -the property. - -For signals, there is also a fifth element RULE, which keeps the match -string the signal is registered with. - -In the second case, the key in the hash table is the list (BUS +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 and properties, 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' and +`:signal'), or a cons cell containing the value of the property (TYPE +`:property'). + +For entries of type `:signal', there is also a fifth element RULE, +which keeps the match string the signal 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 ------------------------------------------------------------ revno: 107994 committer: Chong Yidong branch nick: trunk timestamp: Sun 2012-04-22 21:58:00 +0800 message: Tweaks to Customize interface. Set custom-reset-button-menu to t. * cus-edit.el (custom-commands, custom-reset-menu) (Custom-reset-standard): Tweak labels. (custom-reset-button-menu): Change default to t. (custom-buffer-create-internal): For the custom-reset-button-menu case, put the revert button first. (custom-group-subtitle): New face. (custom-group-value-create): Align docstring to a specific column. * wid-edit.el (widget-documentation-link-add): Don't handle indentation in this function. (widget-documentation-string-indent-to): New function. (widget-documentation-string-value-create): Use it. * autorevert.el (auto-revert): * epg-config.el (epg): * ibuffer.el (ibuffer): * mpc.el (mpc): * ses.el (ses): * eshell/eshell.el (eshell): * net/ange-ftp.el (ange-ftp): * progmodes/ebnf2ps.el (postscript): * progmodes/flymake.el (flymake): * progmodes/prolog.el (prolog): * progmodes/verilog-mode.el (verilog-mode): * progmodes/which-func.el (which-func): * textmodes/picture.el (picture): * textmodes/tildify.el (tildify): * vc/ediff.el (ediff): Tweak defgroups to improve presentation in customization buffers. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-04-20 10:04:19 +0000 +++ etc/NEWS 2012-04-22 13:58:00 +0000 @@ -74,7 +74,9 @@ * Changes in Specialized Modes and Packages in Emacs 24.2 -** which-function-mode now applies to all applicable major modes by default. +** Customize + +*** `custom-reset-button-menu' now defaults to t. ** erc will look up server/channel names via auth-source and use the channel keys found, if any. @@ -87,6 +89,8 @@ ** FIXME something happened to ses.el, 2012-04-17. +** which-function-mode now applies to all applicable major modes by default. + ** Obsolete packages: *** mailpost.el === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-04-22 11:13:09 +0000 +++ lisp/ChangeLog 2012-04-22 13:58:00 +0000 @@ -1,3 +1,36 @@ +2012-04-22 Chong Yidong + + * cus-edit.el (custom-commands, custom-reset-menu) + (Custom-reset-standard): Tweak labels. + (custom-reset-button-menu): Change default to t. + (custom-buffer-create-internal): For the custom-reset-button-menu + case, put the revert button first. + (custom-group-subtitle): New face. + (custom-group-value-create): Align docstring to a specific column. + + * wid-edit.el (widget-documentation-link-add): Don't handle + indentation in this function. + (widget-documentation-string-indent-to): New function. + (widget-documentation-string-value-create): Use it. + + * autorevert.el (auto-revert): + * epg-config.el (epg): + * ibuffer.el (ibuffer): + * mpc.el (mpc): + * ses.el (ses): + * eshell/eshell.el (eshell): + * net/ange-ftp.el (ange-ftp): + * progmodes/ebnf2ps.el (postscript): + * progmodes/flymake.el (flymake): + * progmodes/prolog.el (prolog): + * progmodes/verilog-mode.el (verilog-mode): + * progmodes/which-func.el (which-func): + * term/xterm.el (xterm): + * textmodes/picture.el (picture): + * textmodes/tildify.el (tildify): + * vc/ediff.el (ediff): Tweak defgroups to improve presentation in + customization buffers. + 2012-04-22 Alan Mackenzie * progmodes/cc-engine.el (c-append-lower-brace-pair-to-state-cache): === modified file 'lisp/autorevert.el' --- lisp/autorevert.el 2012-03-11 18:02:48 +0000 +++ lisp/autorevert.el 2012-04-22 13:58:00 +0000 @@ -104,9 +104,8 @@ (defgroup auto-revert nil "Revert individual buffers when files on disk change. - -Auto-Revert Mode can be activated for individual buffer. -Global Auto-Revert Mode applies to all buffers." +Auto-Revert mode enables auto-revert in individual buffers. +Global Auto-Revert mode does so in all buffers." :group 'files :group 'convenience) === modified file 'lisp/calc/calc.el' --- lisp/calc/calc.el 2012-04-09 13:05:48 +0000 +++ lisp/calc/calc.el 2012-04-22 13:58:00 +0000 @@ -222,7 +222,7 @@ (defgroup calc nil - "GNU Calc." + "Advanced desk calculator and mathematical tool." :prefix "calc-" :tag "Calc" :group 'applications) === modified file 'lisp/cus-edit.el' --- lisp/cus-edit.el 2012-02-05 16:30:51 +0000 +++ lisp/cus-edit.el 2012-04-22 13:58:00 +0000 @@ -223,7 +223,7 @@ :group 'emacs) (defgroup languages nil - "Specialized modes for editing programming languages." + "Modes for editing programming languages." :group 'programming) (defgroup lisp nil @@ -255,7 +255,7 @@ :group 'applications) (defgroup news nil - "Support for netnews reading and posting." + "Reading and posting to newsgroups." :link '(custom-manual "(gnus)") :group 'applications) @@ -297,7 +297,7 @@ :group 'environment) (defgroup unix nil - "Front-ends/assistants for, or emulators of, UNIX features." + "Interfaces, assistants, and emulators for UNIX features." :group 'environment) (defgroup i18n nil @@ -544,12 +544,6 @@ (erase-buffer) (princ symbol (current-buffer)) (goto-char (point-min)) - ;; FIXME: Boolean variables are not predicates, so they shouldn't - ;; end with `-p'. -stef - ;; (when (and (eq (get symbol 'custom-type) 'boolean) - ;; (re-search-forward "-p\\'" nil t)) - ;; (replace-match "" t t) - ;; (goto-char (point-min))) (if custom-unlispify-remove-prefixes (let ((prefixes custom-prefix-list) prefix) @@ -732,26 +726,26 @@ ;; `custom-buffer-create-internal' if `custom-buffer-verbose-help' is non-nil. (defvar custom-commands - '((" Set for current session " Custom-set t - "Apply all settings in this buffer to the current session" + '((" Apply " Custom-set t + "Apply settings (for the current session only)" "index" "Apply") - (" Save for future sessions " Custom-save + (" Apply and Save " Custom-save (or custom-file user-init-file) - "Apply all settings in this buffer and save them for future Emacs sessions." + "Apply settings and save for future sessions." "save" "Save") - (" Undo edits " Custom-reset-current t - "Restore all settings in this buffer to reflect their current values." + (" Undo Edits " Custom-reset-current t + "Restore customization buffer to reflect existing settings." "refresh" "Undo") - (" Reset to saved " Custom-reset-saved t - "Restore all settings in this buffer to their saved values (if any)." + (" Reset Customizations " Custom-reset-saved t + "Undo any settings applied only for the current session." "undo" "Reset") - (" Erase customizations " Custom-reset-standard + (" Erase Customizations " Custom-reset-standard (or custom-file user-init-file) - "Un-customize all settings in this buffer and save them with standard values." + "Un-customize settings in this and future sessions." "delete" "Uncustomize") (" Help for Customize " Custom-help t @@ -766,9 +760,9 @@ (info "(emacs)Easy Customization")) (defvar custom-reset-menu - '(("Undo Edits" . Custom-reset-current) - ("Reset to Saved" . Custom-reset-saved) - ("Erase Customizations (use standard values)" . Custom-reset-standard)) + '(("Undo Edits in Customization Buffer" . Custom-reset-current) + ("Revert This Session's Customizations" . Custom-reset-saved) + ("Erase Customizations" . Custom-reset-standard)) "Alist of actions for the `Reset' button. The key is a string containing the name of the action, the value is a Lisp function taking the widget as an element which will be called @@ -901,7 +895,8 @@ (memq (widget-get widget :custom-state) '(modified set changed saved rogue)) (widget-apply widget :custom-mark-to-reset-standard))) - "Erase all customizations for settings in this buffer? " t) + "The settings will revert to their default values, in this +and future sessions. Really erase customizations? " t) (custom-reset-standard-save-and-update))) ;;; The Customize Commands @@ -1552,11 +1547,12 @@ (switch-to-buffer-other-window (custom-get-fresh-buffer name)) (custom-buffer-create-internal options description)) -(defcustom custom-reset-button-menu nil +(defcustom custom-reset-button-menu t "If non-nil, only show a single reset button in customize buffers. This button will have a menu with all three reset operations." :type 'boolean - :group 'custom-buffer) + :group 'custom-buffer + :version "24.2") (defcustom custom-buffer-verbose-help t "If non-nil, include explanatory text in the customization buffer." @@ -1651,29 +1647,30 @@ ;; So now the buttons are always inserted in the buffer. (Bug#1326) (if custom-buffer-verbose-help (widget-insert " - Operate on all settings in this buffer:\n")) +Operate on all settings in this buffer:\n")) (let ((button (lambda (tag action active help _icon _label) (widget-insert " ") (if (eval active) (widget-create 'push-button :tag tag :help-echo help :action action)))) (commands custom-commands)) - (apply button (pop commands)) ; Set for current session - (apply button (pop commands)) ; Save for future sessions (if custom-reset-button-menu (progn - (widget-insert " ") (widget-create 'push-button - :tag "Reset buffer" + :tag " Revert... " :help-echo "Show a menu with reset operations." :mouse-down-action 'ignore - :action 'custom-reset)) + :action 'custom-reset) + (apply button (pop commands)) ; Apply + (apply button (pop commands))) ; Apply and Save + (apply button (pop commands)) ; Apply + (apply button (pop commands)) ; Apply and Save (widget-insert "\n") - (apply button (pop commands)) ; Undo edits - (apply button (pop commands)) ; Reset to saved - (apply button (pop commands)) ; Erase customization + (apply button (pop commands)) ; Undo + (apply button (pop commands)) ; Reset + (apply button (pop commands)) ; Erase (widget-insert " ") - (pop commands) ; Help (omitted) + (pop commands) ; Help (omitted) (apply button (pop commands)))) ; Exit (widget-insert "\n\n")) @@ -2824,7 +2821,7 @@ (lambda (widget) (and (default-boundp (widget-value widget)) (memq (widget-get widget :custom-state) '(modified changed))))) - ("Reset to Saved" custom-variable-reset-saved + ("Revert This Session's Customization" custom-variable-reset-saved (lambda (widget) (and (or (get (widget-value widget) 'saved-value) (get (widget-value widget) 'saved-variable-comment)) @@ -3620,7 +3617,7 @@ ("Undo Edits" custom-redraw (lambda (widget) (memq (widget-get widget :custom-state) '(modified changed)))) - ("Reset to Saved" custom-face-reset-saved + ("Revert This Session's Customization" custom-face-reset-saved (lambda (widget) (or (get (widget-value widget) 'saved-face) (get (widget-value widget) 'saved-face-comment)))) @@ -3940,8 +3937,6 @@ ;;; The `custom-group' Widget. (defcustom custom-group-tag-faces nil - ;; In XEmacs, this ought to play games with font size. - ;; Fixme: make it do so in Emacs. "Face used for group tags. The first member is used for level 1 groups, the second for level 2, and so forth. The remaining group tags are shown with `custom-group-tag'." @@ -3978,6 +3973,13 @@ :group 'custom-faces) (define-obsolete-face-alias 'custom-group-tag-face 'custom-group-tag "22.1") +(defface custom-group-subtitle + `((t (:weight bold))) + "Face for the \"Subgroups:\" subtitle in Custom buffers." + :group 'custom-faces) + +(defvar custom-group-doc-align-col 20) + (define-widget 'custom-group 'custom "Customize group." :format "%v" @@ -4043,11 +4045,9 @@ (custom-browse-insert-prefix prefix) (push (widget-create-child-and-convert widget 'custom-browse-visibility - ;; :tag-glyph "plus" :tag "+") buttons) (insert "-- ") - ;; (widget-glyph-insert nil "-- " "horizontal") (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) @@ -4057,8 +4057,6 @@ (zerop (length members))) (custom-browse-insert-prefix prefix) (insert "[ ]-- ") - ;; (widget-glyph-insert nil "[ ]" "empty") - ;; (widget-glyph-insert nil "-- " "horizontal") (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) @@ -4136,7 +4134,8 @@ :action 'custom-toggle-parent (not (eq state 'hidden))) buttons)) - (insert " : ") + (if (>= (current-column) custom-group-doc-align-col) + (insert " ")) ;; Create magic button. (let ((magic (widget-create-child-and-convert widget 'custom-magic nil))) @@ -4146,7 +4145,8 @@ (widget-put widget :buttons buttons) ;; Insert documentation. (if (and (eq custom-buffer-style 'links) (> level 1)) - (widget-put widget :documentation-indent 0)) + (widget-put widget :documentation-indent + custom-group-doc-align-col)) (widget-add-documentation-string-button widget :visibility-widget 'custom-visibility)) @@ -4224,25 +4224,34 @@ (count 0) (reporter (make-progress-reporter "Creating group entries..." 0 len)) + (have-subtitle (and (not (eq symbol 'emacs)) + (eq custom-buffer-order-groups 'last))) + prev-type children) - (setq children - (mapcar - (lambda (entry) - (widget-insert "\n") - (progress-reporter-update reporter (setq count (1+ count))) - (let ((sym (nth 0 entry)) - (type (nth 1 entry))) - (prog1 - (widget-create-child-and-convert - widget type - :group widget - :tag (custom-unlispify-tag-name sym) - :custom-prefixes custom-prefix-list - :custom-level (1+ level) - :value sym) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n"))))) - members)) + + (dolist (entry members) + (unless (eq prev-type 'custom-group) + (widget-insert "\n")) + (progress-reporter-update reporter (setq count (1+ count))) + (let ((sym (nth 0 entry)) + (type (nth 1 entry))) + (when (and have-subtitle (eq type 'custom-group)) + (setq have-subtitle nil) + (widget-insert + (propertize "Subgroups:\n" 'face 'custom-group-subtitle))) + (setq prev-type type) + (push (widget-create-child-and-convert + widget type + :group widget + :tag (custom-unlispify-tag-name sym) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value sym) + children) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")))) + + (setq children (nreverse children)) (mapc 'custom-magic-reset children) (widget-put widget :children children) (custom-group-state-update widget) @@ -4267,7 +4276,7 @@ ("Undo Edits" custom-group-reset-current (lambda (widget) (memq (widget-get widget :custom-state) '(modified)))) - ("Reset to Saved" custom-group-reset-saved + ("Revert This Session's Customizations" custom-group-reset-saved (lambda (widget) (memq (widget-get widget :custom-state) '(modified set)))) ,@(when (or custom-file init-file-user) === modified file 'lisp/epg-config.el' --- lisp/epg-config.el 2012-01-19 07:21:25 +0000 +++ lisp/epg-config.el 2012-04-22 13:58:00 +0000 @@ -33,9 +33,11 @@ "Report bugs to this address.") (defgroup epg () - "The EasyPG library." + "Interface to the GNU Privacy Guard (GnuPG)." + :tag "EasyPG" :version "23.1" - :group 'data) + :group 'data + :group 'external) (defcustom epg-gpg-program (or (executable-find "gpg") (executable-find "gpg2") === modified file 'lisp/eshell/eshell.el' --- lisp/eshell/eshell.el 2012-02-28 08:17:21 +0000 +++ lisp/eshell/eshell.el 2012-04-22 13:58:00 +0000 @@ -228,11 +228,10 @@ (require 'esh-mode) (defgroup eshell nil - "A command shell implemented entirely in Emacs Lisp. + "Command shell implemented entirely in Emacs Lisp. It invokes no external processes beyond those requested by the user, and is intended to be a functional replacement for command shells such as bash, zsh, rc, 4dos." - :tag "The Emacs shell" :link '(info-link "(eshell)Top") :version "21.1" :group 'applications) === modified file 'lisp/ibuffer.el' --- lisp/ibuffer.el 2012-03-12 02:41:22 +0000 +++ lisp/ibuffer.el 2012-04-22 13:58:00 +0000 @@ -60,11 +60,10 @@ (declare-function ibuffer-format-filter-group-data "ibuf-ext" (filter)) (defgroup ibuffer nil - "An advanced replacement for `buffer-menu'. - -Ibuffer allows you to operate on buffers in a manner much like Dired. -Operations include sorting, marking by regular expression, and -the ability to filter the displayed buffers by various criteria." + "Advanced replacement for `buffer-menu'. +Ibuffer lets you operate on buffers in a Dired-like way, +with the ability to sort, mark by regular expression, +and filter displayed buffers by various criteria." :version "22.1" :group 'convenience) === modified file 'lisp/mpc.el' --- lisp/mpc.el 2012-04-16 23:57:09 +0000 +++ lisp/mpc.el 2012-04-22 13:58:00 +0000 @@ -95,7 +95,7 @@ (eval-when-compile (require 'cl)) (defgroup mpc () - "A Client for the Music Player Daemon." + "Client for the Music Player Daemon (mpd)." :prefix "mpc-" :group 'multimedia :group 'applications) === modified file 'lisp/net/ange-ftp.el' --- lisp/net/ange-ftp.el 2012-04-09 13:05:48 +0000 +++ lisp/net/ange-ftp.el 2012-04-22 13:58:00 +0000 @@ -671,8 +671,7 @@ ;;;; ------------------------------------------------------------ (defgroup ange-ftp nil - "Accessing remote files and directories using FTP - made as simple and transparent as possible." + "Accessing remote files and directories using FTP." :group 'files :group 'comm :prefix "ange-ftp-") === modified file 'lisp/net/tramp.el' --- lisp/net/tramp.el 2012-04-19 08:37:10 +0000 +++ lisp/net/tramp.el 2012-04-22 13:58:00 +0000 @@ -62,7 +62,7 @@ ;;; User Customizable Internal Variables: (defgroup tramp nil - "Edit remote files with a combination of rsh and rcp or similar programs." + "Edit remote files with a combination of ssh, scp, etc." :group 'files :group 'comm :version "22.1") === modified file 'lisp/progmodes/ebnf2ps.el' --- lisp/progmodes/ebnf2ps.el 2012-04-09 13:05:48 +0000 +++ lisp/progmodes/ebnf2ps.el 2012-04-22 13:58:00 +0000 @@ -1181,10 +1181,10 @@ ;;; Interface to the command system (defgroup postscript nil - "PostScript Group." + "Printing with PostScript" :tag "PostScript" :version "20" - :group 'emacs) + :group 'environment) (defgroup ebnf2ps nil === modified file 'lisp/progmodes/flymake.el' --- lisp/progmodes/flymake.el 2012-04-11 00:21:00 +0000 +++ lisp/progmodes/flymake.el 2012-04-22 13:58:00 +0000 @@ -253,7 +253,7 @@ (make-variable-buffer-local 'flymake-output-residual) (defgroup flymake nil - "A universal on-the-fly syntax checker." + "Universal on-the-fly syntax checker." :version "23.1" :group 'tools) === modified file 'lisp/progmodes/gud.el' --- lisp/progmodes/gud.el 2012-04-18 20:26:57 +0000 +++ lisp/progmodes/gud.el 2012-04-22 13:58:00 +0000 @@ -58,8 +58,9 @@ ;; GUD commands must be visible in C buffers visited by GUD (defgroup gud nil - "Grand Unified Debugger mode for gdb and other debuggers under Emacs. -Supported debuggers include gdb, sdb, dbx, xdb, perldb, pdb (Python) and jdb." + "The \"Grand Unified Debugger\" interface. +Supported debuggers include gdb, sdb, dbx, xdb, perldb, +pdb (Python), and jdb." :group 'processes :group 'tools) === modified file 'lisp/progmodes/prolog.el' --- lisp/progmodes/prolog.el 2012-04-09 13:05:48 +0000 +++ lisp/progmodes/prolog.el 2012-04-22 13:58:00 +0000 @@ -295,7 +295,7 @@ (defgroup prolog nil - "Major modes for editing and running Prolog and Mercury files." + "Editing and running Prolog and Mercury files." :group 'languages) (defgroup prolog-faces nil === modified file 'lisp/progmodes/verilog-mode.el' --- lisp/progmodes/verilog-mode.el 2012-04-21 16:57:49 +0000 +++ lisp/progmodes/verilog-mode.el 2012-04-22 13:58:00 +0000 @@ -393,7 +393,7 @@ (parse-partial-sexp (point-min) (or pos (point))))) (defgroup verilog-mode nil - "Facilitates easy editing of Verilog source text." + "Major mode for Verilog source code." :version "22.2" :group 'languages) === modified file 'lisp/progmodes/which-func.el' --- lisp/progmodes/which-func.el 2012-04-14 17:53:52 +0000 +++ lisp/progmodes/which-func.el 2012-04-22 13:58:00 +0000 @@ -68,7 +68,7 @@ "String to display in the mode line when current function is unknown.") (defgroup which-func nil - "Mode to display the current function name in the modeline." + "Display the current function name in the modeline." :group 'tools :version "20.3") === modified file 'lisp/ses.el' --- lisp/ses.el 2012-03-25 20:37:21 +0000 +++ lisp/ses.el 2012-04-22 13:58:00 +0000 @@ -65,6 +65,7 @@ (defgroup ses nil "Simple Emacs Spreadsheet." + :tag "SES" :group 'applications :prefix "ses-" :version "21.1") === modified file 'lisp/term/xterm.el' --- lisp/term/xterm.el 2012-03-31 20:22:04 +0000 +++ lisp/term/xterm.el 2012-04-22 13:58:00 +0000 @@ -27,7 +27,7 @@ (defgroup xterm nil "XTerm support." :version "24.1" - :group 'emacs) + :group 'environment) (defcustom xterm-extra-capabilities 'check "Whether Xterm supports some additional, more modern, features. === modified file 'lisp/textmodes/picture.el' --- lisp/textmodes/picture.el 2012-04-19 17:20:26 +0000 +++ lisp/textmodes/picture.el 2012-04-22 13:58:00 +0000 @@ -31,7 +31,7 @@ ;;; Code: (defgroup picture nil - "Picture mode --- editing using quarter-plane screen model." + "Editing text-based pictures (\"ASCII art\")." :prefix "picture-" :group 'wp) === modified file 'lisp/textmodes/tildify.el' --- lisp/textmodes/tildify.el 2012-01-19 07:21:25 +0000 +++ lisp/textmodes/tildify.el 2012-04-22 13:58:00 +0000 @@ -51,7 +51,7 @@ (defgroup tildify nil - "Adding missing hard spaces or other text fragments into texts." + "Add hard spaces or other text fragments to text buffers." :version "21.1" :group 'wp) === modified file 'lisp/vc/ediff.el' --- lisp/vc/ediff.el 2012-01-19 07:21:25 +0000 +++ lisp/vc/ediff.el 2012-04-22 13:58:00 +0000 @@ -127,7 +127,7 @@ (require 'ediff-mult) ; required because of the registry stuff (defgroup ediff nil - "A comprehensive visual interface to diff & patch." + "Comprehensive visual interface to `diff' and `patch'." :tag "Ediff" :group 'tools) === modified file 'lisp/vc/vc.el' --- lisp/vc/vc.el 2012-04-16 23:57:09 +0000 +++ lisp/vc/vc.el 2012-04-22 13:58:00 +0000 @@ -667,7 +667,7 @@ ;; General customization (defgroup vc nil - "Version-control system in Emacs." + "Emacs interface to version control systems." :group 'tools) (defcustom vc-initial-comment nil === modified file 'lisp/wid-edit.el' --- lisp/wid-edit.el 2012-03-21 02:13:52 +0000 +++ lisp/wid-edit.el 2012-04-22 13:58:00 +0000 @@ -2907,15 +2907,7 @@ (push (widget-convert-button widget-documentation-link-type begin end :value name) buttons))))) - (widget-put widget :buttons buttons))) - (let ((indent (widget-get widget :indent))) - (when (and indent (not (zerop indent))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (insert-char ?\s indent))))))) + (widget-put widget :buttons buttons)))) ;;; The `documentation-string' Widget. @@ -2934,10 +2926,9 @@ (start (point))) (if (string-match "\n" doc) (let ((before (substring doc 0 (match-beginning 0))) - (after (substring doc (match-beginning 0))) - button) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (after (substring doc (match-end 0))) + button end) + (widget-documentation-string-indent-to indent) (insert before ?\s) (widget-documentation-link-add widget start (point)) (setq button @@ -2950,18 +2941,35 @@ :action 'widget-parent-action shown)) (when shown + (insert ?\n) (setq start (point)) (when (and indent (not (zerop indent))) (insert-char ?\s indent)) (insert after) - (widget-documentation-link-add widget start (point))) + (setq end (point)) + (widget-documentation-link-add widget start end) + ;; Indent the subsequent lines. + (when (and indent (> indent 0)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (widget-documentation-string-indent-to indent)))))) (widget-put widget :buttons (list button))) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (widget-documentation-string-indent-to indent) (insert doc) (widget-documentation-link-add widget start (point)))) (insert ?\n)) +(defun widget-documentation-string-indent-to (col) + (when (and (numberp col) + (> col 0)) + (let ((opoint (point))) + (indent-to col) + (put-text-property opoint (point) + 'display `(space :align-to ,col))))) + (defun widget-documentation-string-action (widget &rest _ignore) ;; Toggle documentation. (let ((parent (widget-get widget :parent))) ------------------------------------------------------------ revno: 107993 committer: Alan Mackenzie branch nick: trunk timestamp: Sun 2012-04-22 11:13:09 +0000 message: CC Mode. Adding a ) can hide the resulting (..) from searches. Fix it. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-04-21 16:57:49 +0000 +++ lisp/ChangeLog 2012-04-22 11:13:09 +0000 @@ -1,3 +1,9 @@ +2012-04-22 Alan Mackenzie + + * progmodes/cc-engine.el (c-append-lower-brace-pair-to-state-cache): + Adding a ) can hide the resulting (..) from searches. Fix it. + Bound the backward search to the position of the existing (. + 2012-04-21 Juanma Barranquero * progmodes/verilog-mode.el (verilog-mode): Check whether === modified file 'lisp/progmodes/cc-engine.el' --- lisp/progmodes/cc-engine.el 2012-04-11 15:32:30 +0000 +++ lisp/progmodes/cc-engine.el 2012-04-22 11:13:09 +0000 @@ -2612,13 +2612,24 @@ (setq c-state-point-min (point-min))) (defun c-append-lower-brace-pair-to-state-cache (from &optional upper-lim) - ;; If there is a brace pair preceding FROM in the buffer (not necessarily - ;; immediately preceding), push a cons onto `c-state-cache' to represent it. - ;; FROM must not be inside a literal. If UPPER-LIM is non-nil, we append - ;; the highest brace pair whose "}" is below UPPER-LIM. + ;; If there is a brace pair preceding FROM in the buffer, at the same level + ;; of nesting (not necessarily immediately preceding), push a cons onto + ;; `c-state-cache' to represent it. FROM must not be inside a literal. If + ;; UPPER-LIM is non-nil, we append the highest brace pair whose "}" is below + ;; UPPER-LIM. ;; ;; Return non-nil when this has been done. ;; + ;; The situation it copes with is this transformation: + ;; + ;; OLD: { (.) {...........} + ;; ^ ^ + ;; FROM HERE + ;; + ;; NEW: { {....} (.) {......... + ;; ^ ^ ^ + ;; LOWER BRACE PAIR HERE or HERE + ;; ;; This routine should be fast. Since it can get called a LOT, we maintain ;; `c-state-brace-pair-desert', a small cache of "failures", such that we ;; reduce the time wasted in repeated fruitless searches in brace deserts. @@ -2637,10 +2648,25 @@ (unless (and c-state-brace-pair-desert (eq cache-pos (car c-state-brace-pair-desert)) (<= from (cdr c-state-brace-pair-desert))) - ;; Only search what we absolutely need to: - (if (and c-state-brace-pair-desert - (eq cache-pos (car c-state-brace-pair-desert))) - (narrow-to-region (cdr c-state-brace-pair-desert) (point-max))) + ;; DESERT-LIM. Only search what we absolutely need to, + (let ((desert-lim + (and c-state-brace-pair-desert + (eq cache-pos (car c-state-brace-pair-desert)) + (cdr c-state-brace-pair-desert))) + ;; CACHE-LIM. This limit will be necessary when an opening + ;; paren at `cache-pos' has just had its matching close paren + ;; inserted. `cache-pos' continues to be a search bound, even + ;; though the algorithm below would skip over the new paren + ;; pair. + (cache-lim (and cache-pos (< cache-pos from) cache-pos))) + (narrow-to-region + (cond + ((and desert-lim cache-lim) + (max desert-lim cache-lim)) + (desert-lim) + (cache-lim) + ((point-min))) + (point-max))) ;; In the next pair of nested loops, the inner one moves back past a ;; pair of (mis-)matching parens or brackets; the outer one moves @@ -2674,7 +2700,7 @@ (cons new-cons (cdr c-state-cache)))) (t (setq c-state-cache (cons new-cons c-state-cache))))) - ;; We haven't found a brace pair. Record this. + ;; We haven't found a brace pair. Record this in the cache. (setq c-state-brace-pair-desert (cons cache-pos from)))))))) (defsubst c-state-push-any-brace-pair (bra+1 macro-start-or-here) ------------------------------------------------------------ revno: 107992 committer: Glenn Morris branch nick: trunk timestamp: Sun 2012-04-22 06:18:54 -0400 message: Auto-commit of generated files. diff: === modified file 'autogen/Makefile.in' --- autogen/Makefile.in 2012-04-19 10:17:36 +0000 +++ autogen/Makefile.in 2012-04-22 10:18:54 +0000 @@ -36,7 +36,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=msvc-inval --avoid=msvc-nothrow --avoid=raise --avoid=threadlib --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt careadlinkat crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dup2 filemode getloadavg getopt-gnu ignore-value intprops lstat mktime pthread_sigmask readlink socklen stdarg stdio strftime strtoimax strtoumax symlink sys_stat +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=msvc-inval --avoid=msvc-nothrow --avoid=raise --avoid=threadlib --makefile-name=gnulib.mk --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt careadlinkat crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 dtoastr dup2 filemode getloadavg getopt-gnu ignore-value intprops lstat manywarnings mktime pthread_sigmask readlink socklen stdarg stdio strftime strtoimax strtoumax symlink sys_stat warnings VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ === modified file 'autogen/configure' --- autogen/configure 2012-04-20 08:48:50 +0000 +++ autogen/configure 2012-04-22 10:18:54 +0000 @@ -628,6 +628,7 @@ gl_GNULIB_ENABLED_dosname_TRUE LTLIBINTL LIBINTL +WARN_CFLAGS HAVE_UNISTD_H NEXT_AS_FIRST_DIRECTIVE_UNISTD_H NEXT_UNISTD_H @@ -1186,7 +1187,6 @@ GZIP_PROG INSTALL_INFO GNULIB_WARN_CFLAGS -WARN_CFLAGS WERROR_CFLAGS RANLIB ARFLAGS @@ -6962,6 +6962,7 @@ # Code from module largefile: # Code from module lstat: + # Code from module manywarnings: # Code from module mktime: # Code from module multiarch: # Code from module nocrash: @@ -6998,6 +6999,7 @@ # Code from module u64: # Code from module unistd: # Code from module verify: + # Code from module warnings: # On Suns, sometimes $CPP names a directory. @@ -7717,8 +7719,6 @@ - - $as_echo "#define lint 1" >>confdefs.h @@ -10527,50 +10527,37 @@ # Do the opsystem or machine files prohibit the use of the GNU malloc? # Assume not, until told otherwise. GNU_MALLOC=yes -doug_lea_malloc=yes -ac_fn_c_check_func "$LINENO" "malloc_get_state" "ac_cv_func_malloc_get_state" -if test "x$ac_cv_func_malloc_get_state" = x""yes; then : - -else - doug_lea_malloc=no -fi - -ac_fn_c_check_func "$LINENO" "malloc_set_state" "ac_cv_func_malloc_set_state" -if test "x$ac_cv_func_malloc_set_state" = x""yes; then : - -else - doug_lea_malloc=no -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether __after_morecore_hook exists" >&5 -$as_echo_n "checking whether __after_morecore_hook exists... " >&6; } -if test "${emacs_cv_var___after_morecore_hook+set}" = set; then : + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether malloc is Doug Lea style" >&5 +$as_echo_n "checking whether malloc is Doug Lea style... " >&6; } +if test "${emacs_cv_var_doug_lea_malloc+set}" = set; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ -extern void (* __after_morecore_hook)(); +#include + static void hook (void) {} int main () { -__after_morecore_hook = 0 +malloc_set_state (malloc_get_state ()); + __after_morecore_hook = hook; + __malloc_initialize_hook = hook; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : - emacs_cv_var___after_morecore_hook=yes + emacs_cv_var_doug_lea_malloc=yes else - emacs_cv_var___after_morecore_hook=no + emacs_cv_var_doug_lea_malloc=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $emacs_cv_var___after_morecore_hook" >&5 -$as_echo "$emacs_cv_var___after_morecore_hook" >&6; } -if test $emacs_cv_var___after_morecore_hook = no; then - doug_lea_malloc=no -fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $emacs_cv_var_doug_lea_malloc" >&5 +$as_echo "$emacs_cv_var_doug_lea_malloc" >&6; } +doug_lea_malloc=$emacs_cv_var_doug_lea_malloc system_malloc=no @@ -22368,6 +22355,7 @@ + gl_gnulib_enabled_dosname=false gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=false gl_gnulib_enabled_pathmax=false ------------------------------------------------------------ revno: 107991 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 00:50:17 -0700 message: Fix GC_MALLOC_CHECK debugging output on 64-bit hosts. * alloc.c (emacs_blocked_malloc) [GC_MALLOC_CHECK]: Do not assume ptrdiff_t is the same width as 'int'. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 07:41:30 +0000 +++ src/ChangeLog 2012-04-22 07:50:17 +0000 @@ -1,5 +1,9 @@ 2012-04-22 Paul Eggert + Fix GC_MALLOC_CHECK debugging output on 64-bit hosts. + * alloc.c (emacs_blocked_malloc) [GC_MALLOC_CHECK]: + Do not assume ptrdiff_t is the same width as 'int'. + * alloc.c: Handle unusual debugging option combinations. (GC_CHECK_MARKED_OBJECTS): Undef if ! GC_MARK_STACK, since the two debugging options are incompatible. === modified file 'src/alloc.c' --- src/alloc.c 2012-04-22 07:41:30 +0000 +++ src/alloc.c 2012-04-22 07:50:17 +0000 @@ -1314,7 +1314,7 @@ { fprintf (stderr, "Malloc returned %p which is already in use\n", value); - fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n", + fprintf (stderr, "Region in use is %p...%p, %td bytes, type %d\n", m->start, m->end, (char *) m->end - (char *) m->start, m->type); abort (); ------------------------------------------------------------ revno: 107990 committer: Paul Eggert branch nick: trunk timestamp: Sun 2012-04-22 00:41:30 -0700 message: * alloc.c: Handle unusual debugging option combinations. (GC_CHECK_MARKED_OBJECTS): Undef if ! GC_MARK_STACK, since the two debugging options are incompatible. (GC_MALLOC_CHECK): Similarly, undef if GC_CHECK_MARKED_OBJECTS is defined. (mem_init, mem_insert, mem_insert_fixup): Define if GC_MARK_STACK || GC_MALLOC_CHECK. (NEED_MEM_INSERT): Remove; no longer needed. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-04-22 02:58:23 +0000 +++ src/ChangeLog 2012-04-22 07:41:30 +0000 @@ -1,3 +1,14 @@ +2012-04-22 Paul Eggert + + * alloc.c: Handle unusual debugging option combinations. + (GC_CHECK_MARKED_OBJECTS): Undef if ! GC_MARK_STACK, + since the two debugging options are incompatible. + (GC_MALLOC_CHECK): Similarly, undef if GC_CHECK_MARKED_OBJECTS + is defined. + (mem_init, mem_insert, mem_insert_fixup): + Define if GC_MARK_STACK || GC_MALLOC_CHECK. + (NEED_MEM_INSERT): Remove; no longer needed. + 2012-04-22 Leo Liu * sysdep.c (list_system_processes): Support Darwin (Bug#5725). === modified file 'src/alloc.c' --- src/alloc.c 2012-04-16 06:39:21 +0000 +++ src/alloc.c 2012-04-22 07:41:30 +0000 @@ -49,10 +49,18 @@ #include #include +/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. + Doable only if GC_MARK_STACK. */ +#if ! GC_MARK_STACK +# undef GC_CHECK_MARKED_OBJECTS +#endif + /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd - memory. Can do this only if using gmalloc.c. */ + memory. Can do this only if using gmalloc.c and if not checking + marked objects. */ -#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC +#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \ + || defined GC_CHECK_MARKED_OBJECTS) #undef GC_MALLOC_CHECK #endif @@ -391,11 +399,8 @@ static int live_misc_p (struct mem_node *, void *); static void mark_maybe_object (Lisp_Object); static void mark_memory (void *, void *); +#if GC_MARK_STACK || defined GC_MALLOC_CHECK static void mem_init (void); -#if (defined GC_MALLOC_CHECK \ - ? !defined SYSTEM_MALLOC && !defined SYNC_INPUT \ - : GC_MARK_STACK) -# define NEED_MEM_INSERT static struct mem_node *mem_insert (void *, void *, enum mem_type); static void mem_insert_fixup (struct mem_node *); #endif @@ -3578,8 +3583,6 @@ } -#ifdef NEED_MEM_INSERT - /* Insert a new node into the tree for a block of memory with start address START, end address END, and type TYPE. Value is a pointer to the node that was inserted. */ @@ -3727,8 +3730,6 @@ mem_root->color = MEM_BLACK; } -#endif /* NEED_MEM_INSERT */ - /* (x) (y) / \ / \ ------------------------------------------------------------ revno: 107989 committer: Paul Eggert branch nick: trunk timestamp: Sat 2012-04-21 23:56:42 -0700 message: * configure.in (doug_lea_malloc): Check for __malloc_initialize_hook. With glibc 2.14 or later, when compiled with GCC 4.7.0's -Werror=deprecated-declarations flag, use of hooks like __malloc_initialize_hook causes compilation to fail because these hooks are deprecated. Modify 'configure' to check for these hooks too. Simplify the 'configure' code to test for all the hooks at once. (emacs_cv_var___after_morecore_hook): Remove, replacing with ... (emacs_cv_var_doug_lea_malloc): ... this new var. diff: === modified file 'ChangeLog' --- ChangeLog 2012-04-21 17:15:03 +0000 +++ ChangeLog 2012-04-22 06:56:42 +0000 @@ -1,3 +1,14 @@ +2012-04-22 Paul Eggert + + * configure.in (doug_lea_malloc): Check for __malloc_initialize_hook. + With glibc 2.14 or later, when compiled with GCC 4.7.0's + -Werror=deprecated-declarations flag, use of hooks like + __malloc_initialize_hook causes compilation to fail because these + hooks are deprecated. Modify 'configure' to check for these hooks too. + Simplify the 'configure' code to test for all the hooks at once. + (emacs_cv_var___after_morecore_hook): Remove, replacing with ... + (emacs_cv_var_doug_lea_malloc): ... this new var. + 2012-04-21 Paul Eggert Sync from gnulib version 4f11d6bebc3098c64ffde27079ab0d0cecfd0cdc === modified file 'configure.in' --- configure.in 2012-04-21 17:15:03 +0000 +++ configure.in 2012-04-22 06:56:42 +0000 @@ -1708,17 +1708,20 @@ # Do the opsystem or machine files prohibit the use of the GNU malloc? # Assume not, until told otherwise. GNU_MALLOC=yes -doug_lea_malloc=yes -AC_CHECK_FUNC(malloc_get_state, ,doug_lea_malloc=no) -AC_CHECK_FUNC(malloc_set_state, ,doug_lea_malloc=no) -AC_CACHE_CHECK(whether __after_morecore_hook exists, - emacs_cv_var___after_morecore_hook, -[AC_LINK_IFELSE([AC_LANG_PROGRAM([[extern void (* __after_morecore_hook)();]],[[__after_morecore_hook = 0]])], - emacs_cv_var___after_morecore_hook=yes, - emacs_cv_var___after_morecore_hook=no)]) -if test $emacs_cv_var___after_morecore_hook = no; then - doug_lea_malloc=no -fi + +AC_CACHE_CHECK( + [whether malloc is Doug Lea style], + [emacs_cv_var_doug_lea_malloc], + [AC_LINK_IFELSE( + [AC_LANG_PROGRAM( + [[#include + static void hook (void) {}]], + [[malloc_set_state (malloc_get_state ()); + __after_morecore_hook = hook; + __malloc_initialize_hook = hook;]])], + [emacs_cv_var_doug_lea_malloc=yes], + [emacs_cv_var_doug_lea_malloc=no])]) +doug_lea_malloc=$emacs_cv_var_doug_lea_malloc dnl See comments in aix4-2.h about maybe using system malloc there.