This is event-stream.c in view mode; [Download] [Up]
/* The portable interface to event streams.
Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
Copyright (C) 1994, 1995 Amdahl Corporation.
Copyright (C) 1995 Board of Trustees, University of Illinois
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
/* This file has been Mule-ized. */
/*
* DANGER!!
*
* If you ever change ANYTHING in this file, you MUST run the
* testcases at the end to make sure that you haven't changed
* the semantics of recent-keys, last-input-char, or keyboard
* macros. You'd be surprised how easy it is to break this.
*
*/
#include <config.h>
#include "lisp.h"
#include "buffer.h"
#include "commands.h"
#include "device.h"
#include "device-tty.h"
#include "events.h"
#include "frame.h"
#include "insdel.h" /* for buffer_reset_changes */
#include "keymap.h"
#include "macros.h" /* for defining_keyboard_macro */
#include "opaque.h"
#include "process.h"
#include "sysdep.h"
#include "window.h"
#include "sysproc.h" /* select stuff */
#include "systime.h" /* to set Vlast_input_time */
#include <errno.h>
/* The number of keystrokes between auto-saves. */
static int auto_save_interval;
Lisp_Object Qundefined; /* The symbol undefined; good a place as any... */
Lisp_Object Qundefined_keystroke_sequence;
Lisp_Object Qcommand_execute;
Lisp_Object Qemacs_handle_focus_change;
Lisp_Object Vpre_command_hook, Vpost_command_hook;
Lisp_Object Qpre_command_hook, Qpost_command_hook;
Lisp_Object Vlocal_pre_command_hook, Vlocal_post_command_hook;
Lisp_Object Qlocal_pre_command_hook, Qlocal_post_command_hook;
/* Non-nil disable property on a command means
do not execute it; call disabled-command-hook's value instead. */
Lisp_Object Qdisabled, Vdisabled_command_hook;
static void pre_command_hook (void);
static void post_command_hook (void);
/* Last keyboard or mouse input event read as a command. */
Lisp_Object Vlast_command_event;
/* The nearest ASCII equivalent of the above. */
Lisp_Object Vlast_command_char;
/* Last keyboard or mouse event read for any purpose. */
Lisp_Object Vlast_input_event;
/* The nearest ASCII equivalent of the above. */
Lisp_Object Vlast_input_char;
/* If not Qnil, event objects to be read as the next command input */
Lisp_Object Vunread_command_events;
Lisp_Object Vunread_command_event; /* obsoleteness support */
static Lisp_Object Qunread_command_events, Qunread_command_event;
/* Previous command, represented by a Lisp object.
Does not include prefix commands and arg setting commands */
Lisp_Object Vlast_command;
/* If a command sets this, the value goes into
previous-command for the next command. */
Lisp_Object Vthis_command;
/* The value of point when the last command was executed. */
Bufpos last_point_position;
/* The frame that was current when the last command was started. */
Lisp_Object Vlast_selected_frame;
/* The buffer that was current when the last command was started. */
Lisp_Object last_point_position_buffer;
/* A (16bit . 16bit) representation of the time of the last-command-event.
*/
Lisp_Object Vlast_input_time;
/* Character to recognize as the help char. */
Lisp_Object Vhelp_char;
/* Form to execute when help char is typed. */
Lisp_Object Vhelp_form;
/* Flag to tell QUIT that some interesting occurrence (e.g. a keypress)
may have happened. */
volatile int something_happened;
/* Command to run when the help character follows a prefix key. */
Lisp_Object Vprefix_help_command;
/* User-supplied string to translate input characters through */
Lisp_Object Vkeyboard_translate_table;
/* If control-meta-super-shift-X is undefined, try control-meta-super-x */
Lisp_Object Vretry_undefined_key_binding_unshifted;
/* Mask of bits indicating the descriptors that we wait for input on.
These work as follows: */
SELECT_TYPE input_wait_mask, non_fake_input_wait_mask;
SELECT_TYPE process_only_mask, device_only_mask;
/* Device that corresponds to our controlling terminal */
Lisp_Object Vcontrolling_terminal;
/* The callback routines for the window system or terminal driver */
struct event_stream *event_stream;
/* This structure is what we use to excapsulate the state of a command sequence
being composed; key events are executed by adding themselves to the command
builder; if the command builder is then complete (does not still represent
a prefix key sequence) it executes the corresponding command.
*/
struct command_builder
{
/* Qnil, or a Lisp_Event representing the first event event read
* after the last command completed. Threaded. */
/* #### NYI */
Lisp_Object prefix_events;
/* Qnil, or a Lisp_Event representing event in the current
* keymap-lookup sequence. Subsequent events are threaded via
* the event's next slot */
Lisp_Object current_events;
/* Last elt of above */
Lisp_Object most_current_event;
/* Last elt before function map code took over. */
Lisp_Object last_non_function_event;
Bufbyte *echo_buf;
Bytecount echo_buf_length; /* size of echo_buf */
Bytecount echo_buf_index; /* index into echo_buf
* -1 before doing echoing for new cmd */
int echo_esc_index; /* for disgusting ESC => meta kludge */
/* Self-insert-command is magic in that it doesn't always push an undo-
boundary: up to 20 consecutive self-inserts can happen before an undo-
boundary is pushed. This variable is that counter.
*/
int self_insert_countdown;
};
static struct command_builder *the_command_builder;
static void echo_key_event (struct command_builder *, Lisp_Object event);
static void maybe_kbd_translate (Lisp_Object event);
/* This structure is basically a typeahead queue: things like
wait-reading-process-output will delay the execution of
keyboard and mouse events by pushing them here.
Chained through event_next()
command_event_queue_tail is a pointer to the last-added element.
*/
static Lisp_Object command_event_queue;
static struct Lisp_Event *command_event_queue_tail;
/* Nonzero means echo unfinished commands after this many seconds of pause. */
static int echo_keystrokes;
/* The number of keystrokes since the last auto-save. */
static int keystrokes_since_auto_save;
/* This is used to terminate the select(), when an event came in
through a signal (e.g. window-change or C-g on controlling TTY). */
int signal_event_pipe[2];
/* Used by the C-g signal handler so that it will never "hard quit"
when waiting for an event. Otherwise holding down C-g could
cause a suspension back to the shell, which is generally
undesirable. (#### This doesn't fully work.) */
int emacs_is_blocking;
/**********************************************************************/
/* Low-level interfaces onto event methods */
/**********************************************************************/
enum event_stream_operation
{
EVENT_STREAM_PROCESS,
EVENT_STREAM_TIMEOUT,
EVENT_STREAM_ADD_DEVICE,
EVENT_STREAM_READ
};
static void
check_event_stream_ok (enum event_stream_operation op)
{
if (!event_stream && noninteractive)
{
switch (op)
{
case EVENT_STREAM_PROCESS:
error ("Can't start subprocesses in -batch mode");
case EVENT_STREAM_TIMEOUT:
error ("Can't add timeouts in -batch mode");
case EVENT_STREAM_ADD_DEVICE:
error ("Can't add devices in -batch mode");
case EVENT_STREAM_READ:
error ("Can't read events in -batch mode");
default:
abort ();
}
}
else if (!event_stream)
{
error ("event-stream callbacks not initialized (internal error?)");
}
}
int
event_stream_event_pending_p (int user)
{
if (!event_stream)
return 0;
return event_stream->event_pending_p (user);
}
void
event_stream_next_event (struct Lisp_Event *event)
{
Lisp_Object event_obj = Qnil;
check_event_stream_ok (EVENT_STREAM_READ);
/* If C-g was pressed, treat it as a character to be read.
Note that if C-g was pressed while we were blocking,
the SIGINT signal handler will be called. It will
set Vquit_flag and write a byte on our "fake pipe",
which will unblock us. */
if (maybe_read_quit_event (event))
return;
emacs_is_blocking = 1;
event_stream->next_event_cb (event);
emacs_is_blocking = 0;
XSETEVENT (event_obj, event);
maybe_kbd_translate (event_obj);
}
void
event_stream_handle_magic_event (struct Lisp_Event *event)
{
check_event_stream_ok (EVENT_STREAM_READ);
event_stream->handle_magic_event_cb (event);
}
static int
event_stream_add_timeout (EMACS_TIME timeout)
{
check_event_stream_ok (EVENT_STREAM_TIMEOUT);
return event_stream->add_timeout_cb (timeout);
}
static void
event_stream_remove_timeout (int id)
{
check_event_stream_ok (EVENT_STREAM_TIMEOUT);
event_stream->remove_timeout_cb (id);
}
void
event_stream_select_device (struct device *d)
{
int infd = DEVICE_INFD (d);
if (d->input_enabled)
{
Lisp_Object device;
XSETDEVICE (device, d);
signal_simple_error ("device already enabled for input", device);
}
check_event_stream_ok (EVENT_STREAM_ADD_DEVICE);
FD_SET (infd, &input_wait_mask);
FD_SET (infd, &non_fake_input_wait_mask);
FD_SET (infd, &device_only_mask);
event_stream->select_device_cb (d);
d->input_enabled = 1;
}
void
event_stream_unselect_device (struct device *d)
{
int infd = DEVICE_INFD (d);
if (!d->input_enabled)
{
Lisp_Object device;
XSETDEVICE (device, d);
signal_simple_error ("device already disabled for input", device);
}
check_event_stream_ok (EVENT_STREAM_ADD_DEVICE);
FD_CLR (infd, &input_wait_mask);
FD_CLR (infd, &non_fake_input_wait_mask);
FD_CLR (infd, &device_only_mask);
event_stream->unselect_device_cb (d);
d->input_enabled = 0;
}
void
event_stream_select_process (struct Lisp_Process *proc)
{
int infd, outfd;
check_event_stream_ok (EVENT_STREAM_PROCESS);
get_process_file_descriptors (proc, &infd, &outfd);
FD_SET (infd, &input_wait_mask);
FD_SET (infd, &non_fake_input_wait_mask);
FD_SET (infd, &process_only_mask);
event_stream->select_process_cb (proc);
}
void
event_stream_unselect_process (struct Lisp_Process *proc)
{
int infd, outfd;
check_event_stream_ok (EVENT_STREAM_PROCESS);
get_process_file_descriptors (proc, &infd, &outfd);
FD_CLR (infd, &input_wait_mask);
FD_CLR (infd, &non_fake_input_wait_mask);
FD_CLR (infd, &process_only_mask);
event_stream->unselect_process_cb (proc);
}
void
event_stream_quit_p (void)
{
if (event_stream)
event_stream->quit_p_cb ();
}
/**********************************************************************/
/* Character prompting */
/**********************************************************************/
static void
echo_key_event (struct command_builder *command_builder,
Lisp_Object event)
{
/* This function can GC */
char buf[255];
Bytecount buf_index = command_builder->echo_buf_index;
Bufbyte *e;
Bytecount len;
if (buf_index < 0)
{
buf_index = 0; /* We're echoing now */
clear_echo_area (selected_frame (), Qnil, 0);
}
if (command_builder->echo_esc_index < 0
&& event_matches_key_specifier_p (XEVENT (event), Vmeta_prefix_char))
/* Icky-poo */
command_builder->echo_esc_index = buf_index;
format_event_object (buf, XEVENT (event), 1);
len = strlen (buf);
if (len + buf_index + 4 > command_builder->echo_buf_length)
return;
e = command_builder->echo_buf + buf_index;
memcpy (e, buf, len);
e += len;
e[0] = ' ';
e[1] = '-';
e[2] = ' ';
e[3] = 0;
command_builder->echo_buf_index = buf_index + len + 1;
}
static void
maybe_echo_keys (struct command_builder *command_builder, int no_snooze)
{
/* This function can GC */
struct frame *f = selected_frame ();
/* Message turns off echoing unless more keystrokes turn it on again. */
if (echo_area_active (f) && !EQ (Qcommand, echo_area_status (f)))
return;
if (minibuf_level == 0
&& echo_keystrokes > 0
&& (no_snooze ||
!NILP (Fsit_for (make_number (echo_keystrokes), Qnil))))
{
echo_area_message (f, command_builder->echo_buf, Qnil, 0,
/* not echo_buf_index. That doesn't include
the terminating " - ". */
strlen ((char *) command_builder->echo_buf),
Qcommand);
}
}
static void
reset_key_echo (struct command_builder *command_builder,
int remove_echo_area_echo)
{
/* This function can GC */
struct frame *f = selected_frame ();
command_builder->echo_buf_index = -1;
if (remove_echo_area_echo)
clear_echo_area (f, Qcommand, 0);
}
/**********************************************************************/
/* random junk */
/**********************************************************************/
static void
maybe_kbd_translate (Lisp_Object event)
{
struct Lisp_Event ev2;
Emchar c;
if (!STRINGP (Vkeyboard_translate_table))
return;
c = event_to_character (XEVENT (event), 0, 0, 0);
if (c == -1)
return;
if (string_char_length (XSTRING (Vkeyboard_translate_table)) <= c)
return;
c = string_char (XSTRING (Vkeyboard_translate_table), c);
/* This used to call Fcharacter_to_event() directly into EVENT,
but that can eradicate timestamps and other such stuff.
This way is safer. */
ev2.event_type = empty_event;
character_to_event (c, &ev2, XDEVICE (XEVENT (event)->device));
XEVENT (event)->event.key.keysym = ev2.event.key.keysym;
XEVENT (event)->event.key.modifiers = ev2.event.key.modifiers;
}
/* NB: The following auto-save stuff is in keyboard.c in FSFmacs, and
keystrokes_since_auto_save is equivalent to the difference between
num_nonmacro_input_chars and last_auto_save. */
/* When an auto-save happens, record the "time", and don't do again soon. */
void
record_auto_save (void)
{
keystrokes_since_auto_save = 0;
}
/* Make an auto save happen as soon as possible at command level. */
void
force_auto_save_soon (void)
{
keystrokes_since_auto_save = 1 + max (auto_save_interval, 20);
#if 0 /* FSFmacs */
record_asynch_buffer_change ();
#endif
}
static void
maybe_do_auto_save (void)
{
/* This function can GC */
keystrokes_since_auto_save++;
if (auto_save_interval > 0 &&
keystrokes_since_auto_save > max (auto_save_interval, 20) &&
!detect_input_pending ())
{
Fdo_auto_save (Qnil, Qnil);
record_auto_save ();
}
}
static Lisp_Object
print_help (Lisp_Object object)
{
Fprinc (object, Qnil);
return Qnil;
}
static void
execute_help_form (struct command_builder *command_builder,
Lisp_Object event)
{
/* This function can GC */
Lisp_Object help = Qnil;
int speccount = specpdl_depth ();
Bytecount esc_index = command_builder->echo_esc_index;
Bytecount buf_index = command_builder->echo_buf_index;
Lisp_Object echo = ((buf_index <= 0)
? Qnil
: make_string (command_builder->echo_buf,
buf_index));
struct gcpro gcpro1, gcpro2;
GCPRO2 (echo, help);
record_unwind_protect (Fset_window_configuration,
Fcurrent_window_configuration (Qnil));
reset_key_echo (command_builder, 1);
help = Feval (Vhelp_form);
if (STRINGP (help))
internal_with_output_to_temp_buffer ("*Help*",
print_help, help, Qnil);
Fnext_command_event (event, Qnil);
/* Remove the help from the frame */
unbind_to (speccount, Qnil);
/* Hmmmm. Tricky. The unbind restores an old window configuration,
apparently bypassing any setting of windows_structure_changed.
So we need to set it so that things get redrawn properly. */
/* #### This is massive overkill. Look at doing it better once the
new redisplay is fully in place. */
{
Lisp_Object dev;
DEVICE_LOOP (dev)
{
Lisp_Object frame;
for (frame = DEVICE_FRAME_LIST (XDEVICE (XCAR (dev)));
!NILP (frame);
frame = XCDR (frame))
{
MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (XFRAME (XCAR (frame)));
}
}
}
redisplay ();
if (event_matches_key_specifier_p (XEVENT (event), make_number (' ')))
{
/* Discard next key if is is a space */
reset_key_echo (command_builder, 1);
Fnext_command_event (event, Qnil);
}
command_builder->echo_esc_index = esc_index;
command_builder->echo_buf_index = buf_index;
if (buf_index > 0)
memcpy (command_builder->echo_buf,
string_data (XSTRING (echo)), buf_index + 1); /* terminating 0 */
UNGCPRO;
}
/**********************************************************************/
/* input pending */
/**********************************************************************/
int
detect_input_pending (void)
{
/* Always call the event_pending_p hook even if there's an unread
character, because that might do some needed ^G detection (on
systems without SIGIO, for example).
*/
if (event_stream_event_pending_p (1))
return 1;
if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event))
return 1;
if (!NILP (command_event_queue))
{
struct Lisp_Event *e;
for (e = XEVENT (command_event_queue);
e;
e = event_next (e))
{
if (e->event_type != eval_event)
return (1);
}
}
return 0;
}
DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 0, 0,
"T if command input is currently available with no waiting.\n\
Actually, the value is nil only if we can be sure that no input is available.")
()
{
return ((detect_input_pending ()) ? Qt : Qnil);
}
/**********************************************************************/
/* timeouts */
/**********************************************************************/
/**** Low-level timeout functions. ****
These functions maintain a sorted list of one-shot timeouts (where
the timeouts are in absolute time). They are intended for use by
functions that need to convert a list of absolute timeouts into a
series of intervals to wait for. */
static int low_level_timeout_id_tick;
struct low_level_timeout_blocktype
{
Blocktype_declare (struct low_level_timeout);
} *the_low_level_timeout_blocktype;
/* Add a one-shot timeout at time TIME to TIMEOUT_LIST. Return
a unique ID identifying the timeout. */
int
add_low_level_timeout (struct low_level_timeout **timeout_list,
EMACS_TIME time)
{
struct low_level_timeout *tm;
struct low_level_timeout *t, **tt;
/* Allocate a new time struct. */
tm = Blocktype_alloc (the_low_level_timeout_blocktype);
tm->next = NULL;
tm->id = low_level_timeout_id_tick++;
tm->time = time;
/* Add it to the queue. */
tt = timeout_list;
t = *tt;
while (t && EMACS_TIME_EQUAL_OR_GREATER (tm->time, t->time))
{
tt = &t->next;
t = *tt;
}
tm->next = t;
*tt = tm;
return tm->id;
}
/* Remove the low-level timeout identified by ID from TIMEOUT_LIST.
If the timeout is not there, do nothing. */
void
remove_low_level_timeout (struct low_level_timeout **timeout_list, int id)
{
struct low_level_timeout *t, *prev;
/* find it */
for (t = *timeout_list, prev = NULL; t && t->id != id; t = t->next)
prev = t;
if (!t)
return; /* couldn't find it */
if (!prev)
*timeout_list = t->next;
else prev->next = t->next;
Blocktype_free (the_low_level_timeout_blocktype, t);
}
/* If there are timeouts on TIMEOUT_LIST, store the relative time
interval to the first timeout on the list into INTERVAL and
return 1. Otherwise, return 0. */
int
get_low_level_timeout_interval (struct low_level_timeout *timeout_list,
EMACS_TIME *interval)
{
if (!timeout_list) /* no timer events; block indefinitely */
return 0;
else
{
EMACS_TIME current_time;
/* The time to block is the difference between the first
(earliest) timer on the queue and the current time.
If that is negative, then the timer will fire immediately
but we still have to call select(), with a zero-valued
timeout: user events must have precedence over timer events. */
EMACS_GET_TIME (current_time);
if (EMACS_TIME_GREATER (timeout_list->time, current_time))
EMACS_SUB_TIME (*interval, timeout_list->time,
current_time);
else
EMACS_SET_SECS_USECS (*interval, 0, 0);
return 1;
}
}
/* Pop the first (i.e. soonest) timeout off of TIMEOUT_LIST and return
its ID. Also, if TIME_OUT is not 0, store the absolute time of the
timeout into TIME_OUT. */
int
pop_low_level_timeout (struct low_level_timeout **timeout_list,
EMACS_TIME *time_out)
{
struct low_level_timeout *tm = *timeout_list;
int id;
assert (tm);
id = tm->id;
if (time_out)
*time_out = tm->time;
*timeout_list = tm->next;
Blocktype_free (the_low_level_timeout_blocktype, tm);
return id;
}
/**** High-level timeout functions. ****/
static int timeout_id_tick;
/* Since timeout structures contain Lisp_Objects, they need to be GC'd
properly. The opaque data type provides a convenient way of doing
this without having to create a new Lisp object, since we can
provide our own mark function. */
struct timeout
{
int id; /* Id we use to identify the timeout over its lifetime */
int interval_id; /* Id for this particular interval; this may
be different each time the timeout is
signalled.*/
Lisp_Object function, object; /* Function and object associated
with timeout. */
EMACS_TIME next_signal_time; /* Absolute time when the timeout
is next going to be signalled. */
unsigned int resignal_msecs; /* How far after the next timeout
should the one after that
occur? */
};
static Lisp_Object pending_timeout_list, pending_async_timeout_list;
static Lisp_Object
mark_timeout (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct timeout *tm = (struct timeout *) XOPAQUE_DATA (obj);
(markobj) (tm->function);
return tm->object;
}
int
event_stream_generate_wakeup (unsigned int milliseconds,
unsigned int vanilliseconds,
Lisp_Object function, Lisp_Object object,
int async_p)
{
Lisp_Object op = make_opaque (sizeof (struct timeout), 0);
struct timeout *timeout = (struct timeout *) XOPAQUE_DATA (op);
EMACS_TIME current_time;
EMACS_TIME interval;
set_opaque_markfun (op, mark_timeout);
timeout->id = timeout_id_tick++;
timeout->resignal_msecs = vanilliseconds;
timeout->function = function;
timeout->object = object;
EMACS_GET_TIME (current_time);
EMACS_SET_SECS_USECS (interval, milliseconds / 1000,
1000 * (milliseconds % 1000));
EMACS_ADD_TIME (timeout->next_signal_time, current_time, interval);
if (async_p)
{
timeout->interval_id =
event_stream_add_async_timeout (timeout->next_signal_time);
pending_async_timeout_list = Fcons (op, pending_async_timeout_list);
}
else
{
timeout->interval_id =
event_stream_add_timeout (timeout->next_signal_time);
pending_timeout_list = Fcons (op, pending_timeout_list);
}
return timeout->id;
}
static struct timeout *
event_stream_resignal_wakeup (int interval_id, int async_p)
{
Lisp_Object op = Qnil, rest;
struct timeout *timeout;
Lisp_Object *timeout_list;
struct gcpro gcpro1;
GCPRO1 (op); /* just in case ... because it's removed from the list
for awhile. */
if (async_p)
timeout_list = &pending_async_timeout_list;
else
timeout_list = &pending_timeout_list;
/* Find the timeout on the list of pending ones. */
LIST_LOOP (rest, *timeout_list)
{
timeout = (struct timeout *) XOPAQUE_DATA (XCAR (rest));
if (timeout->interval_id == interval_id)
break;
}
assert (!NILP (rest));
op = XCAR (rest);
timeout = (struct timeout *) XOPAQUE_DATA (op);
/* Remove this one from the list of pending timeouts */
*timeout_list = delq_no_quit (op, *timeout_list);
/* If this timeout wants to be resignalled, do it now. */
if (timeout->resignal_msecs)
{
EMACS_TIME current_time;
EMACS_TIME interval;
/* Determine the time that the next resignalling should occur.
We do that by adding the interval time to the last signalled
time until we get a time that's current.
(This way, it doesn't matter if the timeout was signalled
exactly when we asked for it, or at some time later.)
*/
EMACS_GET_TIME (current_time);
EMACS_SET_SECS_USECS (interval, timeout->resignal_msecs / 1000,
1000 * (timeout->resignal_msecs % 1000));
do
{
EMACS_ADD_TIME (timeout->next_signal_time, timeout->next_signal_time,
interval);
} while (EMACS_TIME_GREATER (current_time, timeout->next_signal_time));
if (async_p)
timeout->interval_id =
event_stream_add_async_timeout (timeout->next_signal_time);
else
timeout->interval_id =
event_stream_add_timeout (timeout->next_signal_time);
/* Add back onto the list. Note that the effect of this
is to move frequently-hit timeouts to the front of the
list, which is a good thing. */
*timeout_list = Fcons (op, *timeout_list);
}
UNGCPRO;
return timeout;
}
static void
event_stream_disable_wakeup (int id, int async_p)
{
struct timeout *timeout = 0;
Lisp_Object rest = Qnil;
Lisp_Object *timeout_list;
if (async_p)
timeout_list = &pending_async_timeout_list;
else
timeout_list = &pending_timeout_list;
/* Find the timeout on the list of pending ones, if it's still there. */
LIST_LOOP (rest, *timeout_list)
{
timeout = (struct timeout *) XOPAQUE_DATA (XCAR (rest));
if (timeout->id == id)
break;
}
/* If we found it, remove it from the list and disable the pending
one-shot. */
if (!NILP (rest))
{
*timeout_list =
delq_no_quit (XCAR (rest), *timeout_list);
if (async_p)
event_stream_remove_async_timeout (timeout->interval_id);
else
event_stream_remove_timeout (timeout->interval_id);
}
}
/**** Asynch. timeout functions (see also signal.c) ****/
#if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)
extern int poll_for_quit_id;
#endif
#ifndef SIGCHLD
extern int poll_for_sigchld_id;
#endif
void
event_stream_deal_with_async_timeout (int interval_id)
{
/* This function can GC */
struct timeout *timeout =
event_stream_resignal_wakeup (interval_id, 1);
#if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)
if (timeout->id == poll_for_quit_id)
{
quit_check_signal_happened = 1;
quit_check_signal_tick_count++;
return;
}
#endif
#ifndef SIGCHLD
if (timeout->id == poll_for_sigchld_id)
{
kick_status_notify ();
return;
}
#endif
call1_trapping_errors ("Error in asynchronous timeout callback",
timeout->function, timeout->object);
}
/**** Lisp-level timeout functions. ****/
static unsigned long
lisp_number_to_milliseconds (Lisp_Object secs, int allow_0)
{
unsigned long msecs;
#ifdef LISP_FLOAT_TYPE
double fsecs;
CHECK_INT_OR_FLOAT (secs, 0);
fsecs = XFLOATINT (secs);
#else
long fsecs;
CHECK_INT_OR_FLOAT (secs, 0);
fsecs = XINT (secs);
#endif
msecs = 1000 * fsecs;
if (fsecs < 0)
signal_simple_error ("timeout is negative", secs);
if (!allow_0 && fsecs == 0)
signal_simple_error ("timeout is non-positive", secs);
if (fsecs >= (((unsigned int) 0xFFFFFFFF) / 1000))
signal_simple_error
("timeout would exceed 32 bits when represented in milliseconds", secs);
return msecs;
}
DEFUN ("add-timeout", Fadd_timeout, Sadd_timeout, 3, 4, 0,
"Add a timeout, to be signaled after the timeout period has elapsed.\n\
SECS is a number of seconds, expressed as an integer or a float.\n\
FUNCTION will be called after that many seconds have elapsed, with one\n\
argument, the given OBJECT. If the optional RESIGNAL argument is provided,\n\
then after this timeout expires, `add-timeout' will automatically be called\n\
again with RESIGNAL as the first argument.\n\
\n\
This function returns an object which is the id number of this particular\n\
timeout. You can pass that object to `disable-timeout' to turn off the\n\
timeout before it has been signalled.\n\
\n\
NOTE: Id numbers as returned by this function are in a distinct namespace\n\
from those returned by `add-async-timeout'. This means that the same id\n\
number could refer to a pending synchronous timeout and a different pending\n\
asynchronous timeout, and that you cannot pass an id from `add-timeout'\n\
to `disable-async-timeout', or vice-versa.\n\
\n\
The number of seconds may be expressed as a floating-point number, in which\n\
case some fractional part of a second will be used. Caveat: the usable\n\
timeout granularity will vary from system to system.\n\
\n\
Adding a timeout causes a timeout event to be returned by `next-event', and\n\
the function will be invoked by `dispatch-event,' so if emacs is in a tight\n\
loop, the function will not be invoked until the next call to sit-for or\n\
until the return to top-level (the same is true of process filters).\n\
\n\
If you need to have a timeout executed even when XEmacs is in the midst of\n\
running Lisp code, use `add-async-timeout'.\n\
\n\
WARNING: if you are thinking of calling add-timeout from inside of a\n\
callback function as a way of resignalling a timeout, think again. There\n\
is a race condition. That's why the RESIGNAL argument exists.")
(secs, function, object, resignal)
Lisp_Object secs, function, object, resignal;
{
unsigned long msecs = lisp_number_to_milliseconds (secs, 0);
unsigned long msecs2 = (NILP (resignal) ? 0 :
lisp_number_to_milliseconds (resignal, 0));
int id;
Lisp_Object lid;
id = event_stream_generate_wakeup (msecs, msecs2, function, object, 0);
lid = make_number (id);
if (id != XINT (lid)) abort ();
return lid;
}
DEFUN ("disable-timeout", Fdisable_timeout, Sdisable_timeout, 1, 1, 0,
"Disable a timeout from signalling any more.\n\
ID should be a timeout id number as returned by `add-timeout'. If ID\n\
corresponds to a one-shot timeout that has already signalled, nothing\n\
will happen.\n\
\n\
It will not work to call this function on an id number returned by\n\
`add-async-timeout'. Use `disable-async-timeout' for that.")
(id)
Lisp_Object id;
{
CHECK_INT (id, 0);
event_stream_disable_wakeup (XINT (id), 0);
return Qnil;
}
DEFUN ("add-async-timeout", Fadd_async_timeout, Sadd_async_timeout, 3, 4, 0,
"Add an asynchronous timeout, to be signaled after an interval has elapsed.\n\
SECS is a number of seconds, expressed as an integer or a float.\n\
FUNCTION will be called after that many seconds have elapsed, with one\n\
argument, the given OBJECT. If the optional RESIGNAL argument is provided,\n\
then after this timeout expires, `add-async-timeout' will automatically be\n\
called again with RESIGNAL as the first argument.\n\
\n\
This function returns an object which is the id number of this particular\n\
timeout. You can pass that object to `disable-async-timeout' to turn off\n\
the timeout before it has been signalled.\n\
\n\
NOTE: Id numbers as returned by this function are in a distinct namespace\n\
from those returned by `add-timeout'. This means that the same id number\n\
could refer to a pending synchronous timeout and a different pending\n\
asynchronous timeout, and that you cannot pass an id from\n\
`add-async-timeout' to `disable-timeout', or vice-versa.\n\
\n\
The number of seconds may be expressed as a floating-point number, in which\n\
case some fractional part of a second will be used. Caveat: the usable\n\
timeout granularity will vary from system to system.\n\
\n\
Adding an asynchronous timeout causes the function to be invoked as soon\n\
as the timeout occurs, even if XEmacs is in the midst of executing some\n\
other code. (This is unlike the synchronous timeouts added with\n\
`add-timeout', where the timeout will only be signalled when XEmacs is\n\
waiting for events, i.e. the next return to top-level or invocation of\n\
`sit-for' or related functions.) This means that the function that is\n\
called *must* not signal an error or change any global state (e.g. switch\n\
buffers or windows) except when locking code is in place to make sure\n\
that race conditions don't occur in the interaction between the\n\
asynchronous timeout function and other code.\n\
\n\
Under most circumstances, you should use `add-timeout' instead, as it is\n\
much safer. Asynchronous timeouts should only be used when such behavior\n\
is really necessary.\n\
\n\
Asynchronous timeouts are blocked and will not occur when `inhibit-quit'\n\
is non-nil. As soon as `inhibit-quit' becomes nil again, any pending\n\
asynchronous timeouts will get called immediately. (Multiple occurrences\n\
of the same asynchronous timeout are not queued, however.) While the\n\
callback function of an asynchronous timeout is invoked, `inhibit-quit'\n\
is automatically bound to non-nil, and thus other asynchronous timeouts\n\
will be blocked unless the callback function explicitly sets `inhibit-quit'\n\
to nil.\n\
\n\
WARNING: if you are thinking of calling `add-async-timeout' from inside of a\n\
callback function as a way of resignalling a timeout, think again. There\n\
is a race condition. That's why the RESIGNAL argument exists.")
(secs, function, object, resignal)
Lisp_Object secs, function, object, resignal;
{
unsigned long msecs = lisp_number_to_milliseconds (secs, 0);
unsigned long msecs2 = (NILP (resignal) ? 0 :
lisp_number_to_milliseconds (resignal, 0));
int id;
Lisp_Object lid;
id = event_stream_generate_wakeup (msecs, msecs2, function, object, 1);
lid = make_number (id);
if (id != XINT (lid)) abort ();
return lid;
}
DEFUN ("disable-async-timeout", Fdisable_async_timeout,
Sdisable_async_timeout, 1, 1, 0,
"Disable an asynchronous timeout from signalling any more.\n\
ID should be a timeout id number as returned by `add-async-timeout'. If ID\n\
corresponds to a one-shot timeout that has already signalled, nothing\n\
will happen.\n\
\n\
It will not work to call this function on an id number returned by\n\
`add-timeout'. Use `disable-timeout' for that.")
(id)
Lisp_Object id;
{
CHECK_INT (id, 0);
event_stream_disable_wakeup (XINT (id), 1);
return Qnil;
}
/**********************************************************************/
/* enqueuing and dequeuing events */
/**********************************************************************/
/* used both by enqueue_command_event() and enqueue_Xt_dispatch_event() */
void
enqueue_event (Lisp_Object event, Lisp_Object *head, struct Lisp_Event **tail)
{
struct Lisp_Event *e = XEVENT (event);
if (event_next (e))
abort ();
if (*tail && *tail == e)
abort ();
if (*tail)
set_event_next (*tail, e);
else
*head = event;
*tail = e;
if (e == event_next (e))
abort ();
}
Lisp_Object
dequeue_event (Lisp_Object *head, struct Lisp_Event **tail)
{
Lisp_Object event = Qnil;
struct Lisp_Event *e;
e = XEVENT (*head);
XSETEVENT (event, e);
if (!event_next (e))
{
*tail = 0;
*head = Qnil;
}
else
{
XSETEVENT (*head, event_next (e));
}
set_event_next (e, 0);
return event;
}
/* Add an event to the back of the command-event queue: it will be the next
event read after all pending events. This only works on keyboard,
mouse-click, misc-user, and eval events.
*/
void
enqueue_command_event (Lisp_Object event)
{
enqueue_event (event, &command_event_queue, &command_event_queue_tail);
}
Lisp_Object
dequeue_command_event (void)
{
return dequeue_event (&command_event_queue, &command_event_queue_tail);
}
/* put the event on the typeahead queue, unless
the event is the quit char, in which case the `QUIT'
which will occur on the next trip through this loop is
all the processing we should do - leaving it on the queue
would cause the quit to be processed twice.
*/
static void
enqueue_command_event_1 (Lisp_Object event_to_copy)
{
/* do not call check_quit() here. Vquit_flag was set in
next_event_internal. */
if (NILP (Vquit_flag))
enqueue_command_event (Fcopy_event (event_to_copy, Qnil));
}
DEFUN ("enqueue-eval-event", Fenqueue_eval_event, Senqueue_eval_event,
2, 2, 0,
"Add an eval event to the back of the eval event queue.\n\
When this event is dispatched, FUNCTION (which should be a function\n\
of one argument) will be called with OBJECT as its argument.\n\
See `next-event' for a description of event types and how events\n\
are received.")
(function, object)
Lisp_Object function, object;
{
Lisp_Object event;
event = Fallocate_event ();
XEVENT (event)->event_type = eval_event;
XEVENT (event)->event.eval.function = function;
XEVENT (event)->event.eval.object = object;
enqueue_command_event (event);
return event;
}
Lisp_Object
enqueue_misc_user_event (Lisp_Object function, Lisp_Object object)
{
Lisp_Object event;
event = Fallocate_event ();
XEVENT (event)->event_type = misc_user_event;
XEVENT (event)->event.eval.function = function;
XEVENT (event)->event.eval.object = object;
enqueue_command_event (event);
return event;
}
/**********************************************************************/
/* focus-event handling */
/**********************************************************************/
static void
run_select_frame_hook (void)
{
if (!NILP (Vrun_hooks))
call1 (Vrun_hooks, Qselect_frame_hook);
}
static void
run_deselect_frame_hook (void)
{
if (!NILP (Vrun_hooks))
call1 (Vrun_hooks, Qdeselect_frame_hook);
}
/* When select-frame is called, we want to tell the window system that
the focus should be changed to point to the new frame. However,
sometimes Lisp functions will temporarily change the selected frame
(e.g. to call a function that operates on the selected frame),
and it's annoying if this focus-change happens exactly when
select-frame is called, because then you get some flickering of the
window-manager border and perhaps other undesirable results. We
really only want to change the focus when we're about to retrieve
an event from the user. To do this, we keep track of the frame
where the window-manager focus lies on, and just before waiting
for user events, check the currently selected frame and change
the focus as necessary. */
static void
investigate_frame_change (void)
{
Lisp_Object dev;
/* if the selected frame was changed, change the window-system
focus to the new frame. We don't do it when select-frame was
called, to avoid flickering and other unwanted side effects when
the frame is just changed temporarily. */
DEVICE_LOOP (dev)
{
struct device *d = XDEVICE (XCAR (dev));
Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d);
if (!NILP (sel_frame) &&
!EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) &&
!NILP (DEVICE_FRAME_WITH_FOCUS (d)) &&
!EQ (DEVICE_FRAME_WITH_FOCUS (d), sel_frame))
{
/* prevent us from issuing the same request more than once */
DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = sel_frame;
MAYBE_DEVMETH (d, focus_on_frame, (XFRAME (sel_frame)));
}
}
}
static Lisp_Object
cleanup_after_defocusing (Lisp_Object frm_and_dev)
{
Lisp_Object frame = Fcar (frm_and_dev);
Lisp_Object device = Fcdr (frm_and_dev);
if (!DEVICE_LIVE_P (XDEVICE (device)))
return Qnil;
else
{
DEVICE_FRAME_WITH_FOCUS (XDEVICE (device)) = Qnil;
if (FRAME_LIVE_P (XFRAME (frame)))
redisplay_redraw_cursor (XFRAME (frame), 1);
}
return Qnil;
}
static Lisp_Object
cleanup_after_missed_defocusing (Lisp_Object frms_and_dev)
{
Lisp_Object missed_frame = Fcar (frms_and_dev);
Lisp_Object device = Fcar (Fcdr (frms_and_dev));
Lisp_Object new_frame = Fcdr (Fcdr (frms_and_dev));
struct device *d = XDEVICE (device);
if (!DEVICE_LIVE_P (d))
return Qnil;
DEVICE_FRAME_WITH_FOCUS (d) = Qnil;
redisplay_redraw_cursor (XFRAME (missed_frame), 1);
if (!NILP (new_frame))
{
Fselect_frame (new_frame);
DEVICE_FRAME_WITH_FOCUS (d) = new_frame;
redisplay_redraw_cursor (XFRAME (new_frame), 1);
}
return Qnil;
}
/* Called from the window-system-specific code when we receive a
notification that the focus lies on a particular frame.
Argument is a cons: (frame . in-p) where in-p is non-nil for focus-in.
*/
DEFUN ("emacs-handle-focus-change", Femacs_handle_focus_change,
Semacs_handle_focus_change, 1, 1, 0,
"internal function--don't call this.")
(frame_inp_and_dev)
Lisp_Object frame_inp_and_dev;
{
Lisp_Object frame = Fcar (frame_inp_and_dev);
Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev));
int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev)));
struct device *d;
int count;
if (!DEVICE_LIVE_P (XDEVICE (device)))
return Qnil;
else
d = XDEVICE (device);
/* Any received focus-change notifications render invalid any
pending focus-change requests. */
DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = Qnil;
if (in_p)
{
Lisp_Object focus_frame;
if (!FRAME_LIVE_P (XFRAME (frame)))
return Qnil;
else
focus_frame = DEVICE_FRAME_WITH_FOCUS (d);
/* Mark the minibuffer as changed to make sure it gets updated
properly if the echo area is active. */
MARK_WINDOWS_CHANGED (XWINDOW (FRAME_MINIBUF_WINDOW (XFRAME (frame))));
if (FRAMEP (focus_frame) && !EQ (frame, focus_frame))
{
Lisp_Object conser = Qnil;
Lisp_Object conser2 = Qnil;
struct gcpro gcpro1, gcpro2;
GCPRO2 (conser, conser2);
/* Oops, we missed a focus-out event. */
Fselect_frame (focus_frame);
/* Do an unwind-protect in case an error occurs in
the deselect-frame-hook */
count = specpdl_depth ();
conser2 = Fcons (device, frame);
conser = Fcons (focus_frame, conser2);
record_unwind_protect (cleanup_after_missed_defocusing, conser);
run_deselect_frame_hook ();
/* No errors, so tell the cleanup method not to do the stuff
we're going to do below anyway. */
Fsetcdr (conser2, Qnil);
unbind_to (count, Qnil);
/* the cleanup method changed the focus frame to nil, so
we need to reflect this */
focus_frame = Qnil;
UNGCPRO;
}
Fselect_frame (frame);
DEVICE_FRAME_WITH_FOCUS (d) = frame;
if (!EQ (frame, focus_frame))
{
redisplay_redraw_cursor (XFRAME (frame), 1);
run_select_frame_hook ();
}
}
else
{
/* We ignore the frame reported in the event. If it's different
from where we think the focus was, oh well -- we messed up.
Nonetheless, we pretend we were right, for sensible behavior. */
frame = DEVICE_FRAME_WITH_FOCUS (d);
if (!NILP (frame))
{
Lisp_Object conser = Qnil;
struct gcpro gcpro1;
GCPRO1 (conser);
/* Do an unwind-protect in case an error occurs in
the deselect-frame-hook */
count = specpdl_depth ();
conser = Fcons (frame, device);
record_unwind_protect (cleanup_after_defocusing, conser);
run_deselect_frame_hook ();
unbind_to (count, Qnil);
UNGCPRO;
}
}
return Qnil;
}
/**********************************************************************/
/* retrieving the next event */
/**********************************************************************/
/* the number of keyboard characters read. callint.c wants this.
*/
Charcount num_input_chars;
static void
next_event_internal (Lisp_Object target_event, int allow_queued)
{
/* QUIT; This is incorrect - the caller must do this because some
callers (ie, Fnext_event()) do not want to QUIT. */
assert (!event_next (XEVENT (target_event)));
investigate_frame_change ();
if (allow_queued && !NILP (command_event_queue))
{
Lisp_Object event = dequeue_command_event ();
Fcopy_event (event, target_event);
Fdeallocate_event (event);
}
else
{
struct Lisp_Event *e = XEVENT (target_event);
/* The command_event_queue was empty. Wait for an event. */
event_stream_next_event (e);
/* If this was a timeout, then we need to extract some data
out of the returned closure and might need to resignal
it. */
if (e->event_type == timeout_event)
{
struct timeout *timeout =
event_stream_resignal_wakeup (e->event.timeout.interval_id, 0);
e->event.timeout.id_number = timeout->id;
e->event.timeout.function = timeout->function;
e->event.timeout.object = timeout->object;
}
/* If we read a ^G, then set quit-flag but do not discard the ^G.
The callers of next_event_internal() will do one of two things:
-- set Vquit_flag to Qnil. (next-event does this.) This will
cause the ^G to be treated as a normal keystroke.
-- not change Vquit_flag but attempt to enqueue the ^G, at
which point it will be discarded. The next time QUIT is
called, it will notice that Vquit_flag was set.
*/
if (e->event_type == key_press_event &&
event_matches_key_specifier_p
(e, make_number (DEVICE_QUIT_CHAR (XDEVICE (e->device)))))
{
Vquit_flag = Qt;
}
}
}
static void push_this_command_keys (Lisp_Object event);
static void push_recent_keys (Lisp_Object event);
static void execute_internal_event (Lisp_Object event);
static void execute_command_event (struct command_builder *,
Lisp_Object event);
DEFUN ("next-event", Fnext_event, Snext_event, 0, 2, 0,
"Return the next available event.\n\
Pass this object to `dispatch-event' to handle it.\n\
In most cases, you will want to use `next-command-event', which returns\n\
the next available \"user\" event (i.e. keypress, button-press,\n\
button-release, or menu selection) instead of this function.\n\
\n\
If EVENT is non-nil, it should be an event object and will be filled in\n\
and returned; otherwise a new event object will be created and returned.\n\
If PROMPT is non-nil, it should be a string and will be displayed in the\n\
echo area while this function is waiting for an event.\n\
\n\
The next available event will be\n\
\n\
-- any events in `unread-command-events' or `unread-command-event'; else\n\
-- the next event in the currently executing keyboard macro, if any; else\n\
-- an event queued by `enqueue-eval-event', if any; else\n\
-- the next available event from the window system or terminal driver.\n\
\n\
In the last case, this function will block until an event is available.\n\
\n\
The returned event will be one of the following types:\n\
\n\
-- a key-press event.\n\
-- a button-press or button-release event.\n\
-- a misc-user-event, meaning the user selected an item on a menu or used\n\
the scrollbar.\n\
-- a process event, meaning that output from a subprocess is available.\n\
-- a timeout event, meaning that a timeout has elapsed.\n\
-- an eval event, which simply causes a function to be executed when the\n\
event is dispatched. Eval events are generated by `enqueue-eval-event'\n\
or by certain other conditions happening.\n\
-- a magic event, indicating that some window-system-specific event\n\
happened (such as an focus-change notification) that must be handled\n\
synchronously with other events. `dispatch-event' knows what to do with\n\
these events.")
(event, prompt)
Lisp_Object event, prompt;
{
/* This function can GC */
struct command_builder *command_builder = the_command_builder;
int store_this_key = 0;
struct gcpro gcpro1;
GCPRO1 (event);
/* DO NOT do QUIT anywhere within this function or the functions it calls.
We want to read the ^G as an event. */
if (NILP (event))
event = Fallocate_event ();
else
CHECK_LIVE_EVENT (event, 0);
if (!NILP (prompt))
{
Bytecount len;
CHECK_STRING (prompt, 1);
len = string_length (XSTRING (prompt));
if (command_builder->echo_buf_length < len)
len = command_builder->echo_buf_length - 1;
memcpy (command_builder->echo_buf, string_data (XSTRING (prompt)), len);
command_builder->echo_buf[len] = 0;
command_builder->echo_buf_index = len;
command_builder->echo_esc_index = -1;
echo_area_message (selected_frame (), the_command_builder->echo_buf,
Qnil, 0,
the_command_builder->echo_buf_index,
Qcommand);
}
redisplay ();
/* If there is something in unread-command-events, simply return it.
But do some error checking to make sure the user hasn't put something
in the unread-command-events that they shouldn't have.
This does not update this-command-keys and recent-keys.
*/
if (!NILP (Vunread_command_events))
{
if (!CONSP (Vunread_command_events))
{
Vunread_command_events = Qnil;
signal_error (Qwrong_type_argument,
list3 (Qconsp, Vunread_command_events,
Qunread_command_events));
}
else
{
Lisp_Object e = XCAR (Vunread_command_events);
Vunread_command_events = XCDR (Vunread_command_events);
if (!EVENTP (e) || !command_event_p (XEVENT (e)))
signal_error (Qwrong_type_argument,
list3 (Qeventp, e, Qunread_command_events));
if (!EQ (e, event))
Fcopy_event (e, event);
}
}
/* Do similar for unread-command-event (obsoleteness support).
*/
else if (!NILP (Vunread_command_event))
{
Lisp_Object e = Vunread_command_event;
Vunread_command_event = Qnil;
if (!EVENTP (e) || !command_event_p (XEVENT (e)))
{
signal_error (Qwrong_type_argument,
list3 (Qeventp, e, Qunread_command_event));
}
if (!EQ (e, event))
Fcopy_event (e, event);
}
/* If we're executing a keyboard macro, take the next event from that,
and update this-command-keys and recent-keys.
Note that the unread-command-events take precedence over kbd macros.
*/
else if (!NILP (Vexecuting_macro))
{
pop_kbd_macro_event (event); /* This throws past us at end-of-macro. */
store_this_key = 1;
}
/* Otherwise, read a real event, possibly from the command_event_queue,
and update this-command-keys and recent-keys.
*/
else
{
next_event_internal (event, 1);
Vquit_flag = Qnil; /* Read C-g as an event. */
store_this_key = 1;
}
status_notify (); /* Notice process change */
#ifdef C_ALLOCA
alloca (0); /* Cause a garbage collection now */
/* Since we can free the most stuff here
* (since this is typically called from
* the command-loop top-level). */
#endif /* C_ALLOCA */
switch (XEVENT (event)->event_type)
{
default:
goto RETURN;
case button_release_event:
case misc_user_event:
goto EXECUTE_KEY;
case button_press_event: /* key or mouse input can trigger prompting */
goto STORE_AND_EXECUTE_KEY;
case key_press_event: /* any key input can trigger autosave */
break;
}
maybe_do_auto_save ();
num_input_chars++;
STORE_AND_EXECUTE_KEY:
if (store_this_key)
echo_key_event (command_builder, event);
EXECUTE_KEY:
/* Store the last-input-event. The semantics of this is that it is
the thing most recently returned by next-command-event. It need
not have come from the keyboard or a keyboard macro, it may have
come from unread-command-events. It's always a command-event (a
key, click, or menu selection), never a motion or process event.
*/
if (!EVENTP (Vlast_input_event))
Vlast_input_event = Fallocate_event ();
if (XEVENT (Vlast_input_event)->event_type == dead_event)
{
Vlast_input_event = Fallocate_event ();
error ("Someone deallocated last-input-event!");
}
if (! EQ (event, Vlast_input_event))
Fcopy_event (event, Vlast_input_event);
/* last-input-char and last-input-time are derived from
last-input-event.
Note that last-input-char will never have its high-bit set, in an
effort to sidestep the ambiguity between M-x and oslash.
*/
Vlast_input_char = Fevent_to_character (Vlast_input_event,
Qnil, Qnil, Qnil);
{
EMACS_TIME t;
EMACS_GET_TIME (t);
if (!CONSP (Vlast_input_time))
Vlast_input_time = Fcons (Qnil, Qnil);
XCAR (Vlast_input_time)
= make_number ((EMACS_SECS (t) >> 16) & 0xffff);
XCDR (Vlast_input_time)
= make_number ((EMACS_SECS (t) >> 0) & 0xffff);
}
/* If this key came from the keyboard or from a keyboard macro, then
it goes into the recent-keys and this-command-keys vectors.
If this key came from the keyboard, and we're defining a keyboard
macro, then it goes into the macro.
*/
if (store_this_key)
{
push_this_command_keys (event);
push_recent_keys (event);
if (defining_kbd_macro && NILP (Vexecuting_macro))
{
if (!EVENTP (command_builder->current_events))
finalize_kbd_macro_chars ();
store_kbd_macro_event (event);
}
}
/* If this is the help char and there is a help form, then execute the
help form and swallow this character. This is the only place where
calling Fnext_event() can cause arbitrary lisp code to run. Note
that execute_help_form() calls Fnext_command_event(), which calls
this function, as well as Fdispatch_event.
*/
/* #### could cause QUIT! */
if (!NILP (Vhelp_form) &&
event_matches_key_specifier_p (XEVENT (event), Vhelp_char))
execute_help_form (command_builder, event);
RETURN:
UNGCPRO;
return (event);
}
DEFUN ("next-command-event", Fnext_command_event, Snext_command_event, 0, 2, 0,
"Return the next available \"user\" event.\n\
Pass this object to `dispatch-event' to handle it.\n\
\n\
If EVENT is non-nil, it should be an event object and will be filled in\n\
and returned; otherwise a new event object will be created and returned.\n\
If PROMPT is non-nil, it should be a string and will be displayed in the\n\
echo area while this function is waiting for an event.\n\
\n\
The event returned will be a keyboard, mouse press, or mouse release event.\n\
If there are non-command events available (mouse motion, sub-process output,\n\
etc) then these will be executed (with `dispatch-event') and discarded. This\n\
function is provided as a convenience; it is equivalent to the lisp code\n\
\n\
(while (progn\n\
(next-event event prompt)\n\
(not (or (key-press-event-p event)\n\
(button-press-event-p event)\n\
(button-release-event-p event)\n\
(misc-user-event-p event))))\n\
(dispatch-event event))\n")
(event, prompt)
Lisp_Object event, prompt;
{
/* This function can GC */
struct gcpro gcpro1;
GCPRO1 (event);
maybe_echo_keys (the_command_builder, 0); /* #### This sucks bigtime */
for (;;)
{
event = Fnext_event (event, prompt);
if (command_event_p (XEVENT (event)))
break;
else
execute_internal_event (event);
}
UNGCPRO;
return (event);
}
static void
reset_current_events (struct command_builder *command_builder)
{
Lisp_Object event = command_builder->current_events;
command_builder->current_events = Qnil;
command_builder->most_current_event = Qnil;
command_builder->last_non_function_event = Qnil;
if (EVENTP (event))
{
for (;;)
{
struct Lisp_Event *e = event_next (XEVENT (event));
Fdeallocate_event (event);
if (e == 0)
break;
XSETEVENT (event, e);
}
}
}
DEFUN ("discard-input", Fdiscard_input, Sdiscard_input, 0, 0, 0,
"Discard any pending \"user\" events.\n\
Also cancel any kbd macro being defined.\n\
A user event is a key press, button press, button release, or\n\
\"other-user\" event (menu selection or scrollbar action).")
()
{
/* This throws away user-input on the queue, but doesn't process any
events. Calling dispatch_event() here leads to a race condition.
*/
Lisp_Object event = Fallocate_event ();
struct Lisp_Event *e = XEVENT (event);
struct Lisp_Event *head = 0;
struct Lisp_Event *tail = 0;
Lisp_Object oiq = Vinhibit_quit;
struct gcpro gcpro1, gcpro2;
/* next_event_internal() can cause arbitrary Lisp code to be evalled */
GCPRO2 (event, oiq);
Vinhibit_quit = Qt;
/* If a macro was being defined then we have to mark the modeline
has changed to ensure that it gets updated correctly. */
if (defining_kbd_macro)
MARK_MODELINE_CHANGED;
defining_kbd_macro = 0;
reset_current_events (the_command_builder);
while (!NILP (command_event_queue)
|| event_stream_event_pending_p (1))
{
/* This will take stuff off the command_event_queue, or read it
from the event_stream, but it will not block.
*/
next_event_internal (event, 1);
Vquit_flag = Qnil; /* Treat C-g as a user event (ignore it).
It is vitally important that we reset
Vquit_flag here. Otherwise, if we're
reading from a TTY device,
maybe_read_quit_event() will notice
that C-g has been set and send us
another C-g. That will cause us
to get right back here, and read
another C-g, ad infinitum ... */
/* If the event is a user event, ignore it. */
if (! command_event_p (e))
{
/* Otherwise, chain the event onto our list of events not to ignore,
and keep reading until the queue is empty. This does not mean
that if a subprocess is generating an infinite amount of output,
we will never terminate (*provided* that the behavior of
next_event_cb() is correct -- see the comment in events.h),
because this loop ends as soon as there are no more user events
on the command_event_queue or event_stream.
*/
Lisp_Object event2 = Fcopy_event (event, Qnil);
struct Lisp_Event *e2 = XEVENT (event2);
if (tail)
set_event_next (tail, e2);
else
head = e2;
tail = e2;
}
}
if (!NILP (command_event_queue) || command_event_queue_tail)
abort ();
/* Now tack our chain of events back on to the front of the queue.
Actually, since the queue is now drained, we can just replace it.
The effect of this will be that we have deleted all user events
from the input stream without changing the relative ordering of
any other events. (Some events may have been taken from the
event_stream and added to the command_event_queue, however.)
At this time, the command_event_queue will contain only eval_events.
*/
if (head)
{
XSETEVENT (command_event_queue, head);
command_event_queue_tail = tail;
}
Fdeallocate_event (event);
UNGCPRO;
Vinhibit_quit = oiq;
return Qnil;
}
/**********************************************************************/
/* pausing until an action occurs */
/**********************************************************************/
/* #### Is (accept-process-output nil 3) supposed to be like (sleep-for 3)?
*/
DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output,
0, 3, 0,
"Allow any pending output from subprocesses to be read by Emacs.\n\
It is read into the process' buffers or given to their filter functions.\n\
Non-nil arg PROCESS means do not return until some output has been received\n\
from PROCESS.\n\
If the second arg is non-nil, it is the maximum number of seconds to wait:\n\
this function will return after that much time even if no input has arrived\n\
from PROCESS. This argument may be a float, meaning wait some fractional\n\
part of a second.\n\
If the third arg is non-nil, it is a number of milliseconds that is added\n\
to the second arg. (This exists only for compatibility.)\n\
Return non-nil iff we received any output before the timeout expired.")
(process, timeout_secs, timeout_msecs)
Lisp_Object process, timeout_secs, timeout_msecs;
{
/* This function can GC */
struct gcpro gcpro1, gcpro2;
Lisp_Object event = Qnil;
int timeout_id = 0;
Lisp_Object result = Qnil;
struct buffer *old_buffer = current_buffer;
/* We preserve the current buffer but nothing else. If a focus
change alters the selected window then the top level event loop
will eventually alter current_buffer to match. In the mean time
we don't want to mess up whatever called this function. */
if (!NILP (process))
CHECK_PROCESS (process, 0);
GCPRO2 (event, process);
if (!NILP (process) && (!NILP (timeout_secs) || !NILP (timeout_msecs)))
{
unsigned long msecs = 0;
if (!NILP (timeout_secs))
msecs = lisp_number_to_milliseconds (timeout_secs, 1);
if (!NILP (timeout_msecs))
{
CHECK_NATNUM (timeout_msecs, 0);
msecs += XINT (timeout_msecs);
}
if (msecs)
timeout_id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
}
event = Fallocate_event ();
while (!NILP (process)
/* Calling detect_input_pending() is the wrong thing here, because
that considers the Vunread_command_events and command_event_queue.
We don't need to look at the command_event_queue because we are
only interested in process events, which don't go on that. In
fact, we can't read from it anyway, because we put stuff on it.
Note that event_stream->event_pending_p must be called in such
a way that it says whether any events *of any kind* are ready,
not just user events, or (accept-process-output nil) will fail
to dispatch any process events that may be on the queue. It is
not clear to me that this is important, because the top-level
loop will process it, and I don't think that there is ever a
time when one calls accept-process-output with a nil argument
and really need the processes to be handled.
*/
|| (!EQ (result, Qt) && event_stream_event_pending_p (0)))
{
QUIT; /* next_event_internal() does not QUIT, so check for ^G
before reading output from the process - this makes it
less likely that the filter will actually be aborted.
*/
next_event_internal (event, 0);
/* If C-g was pressed while we were waiting, Vquit_flag got
set and next_event_internal() also returns C-g. When
we enqueue the C-g below, it will get discarded. The
next time through, QUIT will be called and will signal a quit. */
switch (XEVENT (event)->event_type)
{
case process_event:
{
if (EQ (XEVENT (event)->event.process.process, process))
{
process = Qnil;
/* RMS's version always returns nil when proc is nil,
and only returns t if input ever arrived on proc. */
result = Qt;
}
execute_internal_event (event);
break;
}
case timeout_event:
{
if (XEVENT (event)->event.timeout.id_number == timeout_id)
{
timeout_id = 0;
process = Qnil; /* we're done */
}
else /* a timeout that wasn't one we're waiting for */
goto EXECTUTE_INTERNAL;
break;
}
case pointer_motion_event:
case magic_event:
{
EXECTUTE_INTERNAL:
execute_internal_event (event);
break;
}
default:
{
enqueue_command_event_1 (event);
break;
}
}
}
/* If our timeout has not been signalled yet, disable it. */
if (timeout_id)
event_stream_disable_wakeup (timeout_id, 0);
Fdeallocate_event (event);
UNGCPRO;
current_buffer = old_buffer;
return result;
}
DEFUN ("sleep-for", Fsleep_for, Ssleep_for, 1, 1, 0,
"Pause, without updating display, for ARG seconds.\n\
ARG may be a float, meaning pause for some fractional part of a second.")
(seconds)
Lisp_Object seconds;
{
/* This function can GC */
unsigned long msecs = lisp_number_to_milliseconds (seconds, 1);
int id;
Lisp_Object event = Qnil;
struct gcpro gcpro1;
GCPRO1 (event);
id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
event = Fallocate_event ();
while (1)
{
QUIT; /* next_event_internal() does not QUIT, so check for ^G
before reading output from the process - this makes it
less likely that the filter will actually be aborted.
*/
/* We're a generator of the command_event_queue, so we can't be a
consumer as well. We don't care about command and eval-events
anyway.
*/
next_event_internal (event, 0); /* blocks */
/* See the comment in accept-process-output about Vquit_flag */
switch (XEVENT (event)->event_type)
{
case timeout_event:
{
if (XEVENT (event)->event.timeout.id_number == id)
goto DONE_LABEL;
else
goto EXECUTE_INTERNAL;
}
case pointer_motion_event:
case process_event:
case magic_event:
{
EXECUTE_INTERNAL:
execute_internal_event (event);
break;
}
default:
{
enqueue_command_event_1 (event);
break;
}
}
}
DONE_LABEL:
Fdeallocate_event (event);
UNGCPRO;
return Qnil;
}
DEFUN ("sit-for", Fsit_for, Ssit_for, 1, 2, 0,
"Perform redisplay, then wait ARG seconds or until user input is available.\n\
ARG may be a float, meaning a fractional part of a second.\n\
Optional second arg non-nil means don't redisplay, just wait for input.\n\
Redisplay is preempted as always if user input arrives, and does not\n\
happen if input is available before it starts.\n\
Value is t if waited the full time with no input arriving.")
(seconds, nodisplay)
Lisp_Object seconds, nodisplay;
{
/* This function can GC */
unsigned long msecs = lisp_number_to_milliseconds (seconds, 1);
Lisp_Object event, result;
struct Lisp_Event *e;
struct gcpro gcpro1;
int id;
/* The unread-command-events count as pending input */
if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event))
return Qnil;
/* If the command-builder already has user-input on it (not eval events)
then that means we're done too.
*/
if (!NILP (command_event_queue))
{
for (e = XEVENT (command_event_queue); e; e = event_next (e))
{
if (command_event_p (e))
return (Qnil);
}
}
/* If we're in a macro, or noninteractive, or early in temacs, then
don't wait. */
if (noninteractive || !NILP (Vexecuting_macro))
return (Qt);
/* Otherwise, start reading events from the event_stream.
Do this loop at least once even if (sit-for 0) so that we
redisplay when no input pending.
*/
event = Fallocate_event ();
GCPRO1 (event);
/* Generate the wakeup even if MSECS is 0, so that existing timeout/etc.
events get processed. The old (pre-19.12) code special-cased this
and didn't generate a wakeup, but the resulting behavior was less than
ideal; viz. the occurrence of (sit-for 0.001) scattered throughout
the E-Lisp universe. */
id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
while (1)
{
/* If there is no user input pending, then redisplay.
*/
if (!event_stream_event_pending_p (1) && NILP (nodisplay))
redisplay ();
/* If we're no longer waiting for a timeout, bug out. */
if (! id)
{
result = Qt;
goto DONE_LABEL;
}
QUIT; /* next_event_internal() does not QUIT, so check for ^G
before reading output from the process - this makes it
less likely that the filter will actually be aborted.
*/
/* We're a generator of the command_event_queue, so we can't be a
consumer as well. In fact, we know there's nothing on the
command_event_queue that we didn't just put there.
*/
next_event_internal (event, 0); /* blocks */
/* See the comment in accept-process-output about Vquit_flag */
if (command_event_p (XEVENT (event)))
{
result = Qnil;
goto DONE_LABEL;
}
switch (XEVENT (event)->event_type)
{
case eval_event:
{
/* eval-events get delayed until later. */
enqueue_command_event (Fcopy_event (event, Qnil));
break;
}
case timeout_event:
{
if (XEVENT (event)->event.timeout.id_number != id)
/* a timeout that wasn't the one we're waiting for */
goto EXECUTE_INTERNAL;
id = 0; /* assert that we are no longer waiting for it. */
result = Qt;
goto DONE_LABEL;
}
default:
{
EXECUTE_INTERNAL:
execute_internal_event (event);
break;
}
}
}
DONE_LABEL:
/* If our timeout has not been signalled yet, disable it. */
if (id)
event_stream_disable_wakeup (id, 0);
/* Put back the event (if any) that made Fsit_for() exit before the
timeout. Note that it is being added to the back of the queue, which
would be inappropriate if there were any user events on the queue
already: we would be misordering them. But we know that there are
no user-events on the queue, or else we would not have reached this
point at all.
*/
if (NILP (result))
enqueue_command_event (event);
else
Fdeallocate_event (event);
UNGCPRO;
return (result);
}
/* This handy little function is used by xselect.c and energize.c to
wait for replies from processes that aren't really processes (that is,
the X server and the Energize server).
*/
void
wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg)
{
/* This function can GC */
Lisp_Object event = Fallocate_event ();
struct gcpro gcpro1;
GCPRO1 (event);
while (!(*predicate) (predicate_arg))
{
QUIT; /* next_event_internal() does not QUIT. */
/* We're a generator of the command_event_queue, so we can't be a
consumer as well. Also, we have no reason to consult the
command_event_queue; there are only user and eval-events there,
and we'd just have to put them back anyway.
*/
next_event_internal (event, 0);
/* See the comment in accept-process-output about Vquit_flag */
if (command_event_p (XEVENT (event))
|| (XEVENT (event)->event_type == eval_event))
enqueue_command_event_1 (event);
else
execute_internal_event (event);
}
UNGCPRO;
}
/**********************************************************************/
/* dispatching events; command builder */
/**********************************************************************/
static void
execute_internal_event (Lisp_Object event)
{
/* This function can GC */
switch (XEVENT (event)->event_type)
{
case eval_event:
{
call1 (XEVENT (event)->event.eval.function,
XEVENT (event)->event.eval.object);
return;
}
case pointer_motion_event:
{
/* events on dead frames get silently eaten */
if (!FRAME_LIVE_P (XFRAME (XEVENT (event)->channel)))
return;
if (!NILP (Vmouse_motion_handler))
call1 (Vmouse_motion_handler, event);
return;
}
case process_event:
{
Lisp_Object p = XEVENT (event)->event.process.process;
Charcount readstatus;
assert (PROCESSP (p));
while ((readstatus = read_process_output (p)) > 0)
;
if (readstatus > 0)
; /* this clauses never gets executed but allows the #ifdefs
to work cleanly. */
#ifdef EWOULDBLOCK
else if (readstatus == -1 && errno == EWOULDBLOCK)
;
#endif /* EWOULDBLOCK */
#ifdef EAGAIN
else if (readstatus == -1 && errno == EAGAIN)
;
#endif /* EAGAIN */
else if ((readstatus == 0 &&
/* Note that we cannot distinguish between no input
available now and a closed pipe.
With luck, a closed pipe will be accompanied by
subprocess termination and SIGCHLD. */
(!network_connection_p (p) ||
/*
When connected to ToolTalk (i.e.
connected_via_filedesc_p()), it's not possible to
reliably determine whether there is a message
waiting for ToolTalk to receive. ToolTalk expects
to have tt_message_receive() called exactly once
every time the file descriptor becomes active, so
the filter function forces this by returning 0.
Emacs must not interpret this as a closed pipe. */
connected_via_filedesc_p (XPROCESS (p))))
#ifdef HAVE_PTYS
/* On some OSs with ptys, when the process on one end of
a pty exits, the other end gets an error reading with
errno = EIO instead of getting an EOF (0 bytes read).
Therefore, if we get an error reading and errno =
EIO, just continue, because the child process has
exited and should clean itself up soon (e.g. when we
get a SIGCHLD). */
|| (readstatus == -1 && errno == EIO)
#endif
)
{
/* Currently, we rely on SIGCHLD to indicate that
the process has terminated. Unfortunately, it
appears that on some systems the SIGCHLD gets
missed some of the time. So, we put in am
additional check in status_notify() to see
whether a process has terminated. We have to
tell status_notify() to enable that check, and
we do so now. */
kick_status_notify ();
}
else
{
/* Deactivate network connection */
Lisp_Object status = Fprocess_status (p);
if (EQ (status, Qopen)
/* In case somebody changes the theory of whether to
return open as opposed to run for network connection
"processes"... */
|| EQ (status, Qrun))
update_process_status (p, Qexit, 256, 0);
deactivate_process (p);
}
/* We must call status_notify here to allow the
event_stream->unselect_process_cb to be run if appropriate.
Otherwise, dead fds may be selected for, and we will get a
continuous stream of process events for them. Since we don't
return until all process events have been flushed, we would
get stuck here, processing events on a process whose status
was 'exit. Call this after dispatch-event, or the fds will
have been closed before we read the last data from them.
It's safe for the filter to signal an error because
status_notify() will be called on return to top-level.
*/
status_notify ();
return;
}
case timeout_event:
{
struct Lisp_Event *e = XEVENT (event);
if (!NILP (e->event.timeout.function))
call1 (e->event.timeout.function,
e->event.timeout.object);
return;
}
case magic_event:
{
event_stream_handle_magic_event (XEVENT (event));
return;
}
default:
abort ();
}
}
/* If we read extra events attempting to match a function key but end
up failing, then we release those events back to the command loop
and fail on the original lookup. The released events will then be
reprocessed in the context of the first part having failed. */
static void
repush_function_events (struct command_builder *command_builder)
{
Lisp_Object event0;
struct Lisp_Event *event_h, *event_t;
event0 = command_builder->last_non_function_event;
if (NILP (event0))
return;
if (event_next (XEVENT (event0)) == 0)
return;
else
event_h = event_next (XEVENT (event0));
for (event_t = event_h;
event_next (event_t);
event_t = event_next (event_t))
;
/* Put the commands back on the event queue. */
if (NILP (command_event_queue))
{
set_event_next (event_t, 0);
command_event_queue_tail = event_t;
}
else
{
struct Lisp_Event *e = XEVENT (command_event_queue);
set_event_next (event_t, e);
}
XSETEVENT (command_event_queue, event_h);
/* Then remove them from the command builder. */
set_event_next (XEVENT (event0), 0);
command_builder->most_current_event = event0;
command_builder->last_non_function_event = Qnil;
}
/* Compare the current state of the command builder against the local and
global keymaps; if there is no match, try again, case-insensitively.
The binding found (if any) is returned.
It may be a command or a keymap if we're not done yet.
*/
static Lisp_Object
command_builder_find_leaf (struct command_builder *command_builder,
int allow_misc_user_events_p)
{
/* This function can GC */
Lisp_Object event0 = command_builder->current_events;
Lisp_Object result;
struct Lisp_Event *terminal;
if (NILP (event0))
return (Qnil);
if (allow_misc_user_events_p
&& (event_next (XEVENT (event0)) == 0)
&& (XEVENT (event0)->event_type == misc_user_event))
{
Lisp_Object fn = XEVENT (event0)->event.eval.function;
Lisp_Object arg = XEVENT (event0)->event.eval.object;
return (list2 (fn, arg));
}
result = event_binding (event0, 1);
if (!NILP (result))
{
Lisp_Object map;
/* The suppress-keymap function binds keys to 'undefined - special-case
that here, so that being bound to that has the same error-behavior as
not being defined at all.
*/
if (EQ (result, Qundefined))
return (Qnil);
/* Snap out possible keymap indirections */
map = get_keymap (result, 0, 1);
if (!NILP (map))
return (map);
return (result);
}
/* Check to see if we have a potential function key map match. */
/* #### This should really work by scanning backwards to find and
replace suffixes. In practice this might actually be
sufficient. */
{
result = function_key_map_event_binding (event0);
if (NILP (result) || EQ (result, Qundefined))
{
if (!NILP (command_builder->last_non_function_event))
repush_function_events (command_builder);
/* drop through and continue */
}
else
{
Lisp_Object map;
if (NILP (command_builder->last_non_function_event))
{
for (terminal = XEVENT (event0);
event_next (terminal);
terminal = event_next (terminal))
;
XSETEVENT (command_builder->last_non_function_event, terminal);
}
map = get_keymap (result, 0, 1);
if (!NILP (map))
return (map);
/* #### There are other results such as vectors which we
should also be able to deal with. */
if (SYMBOLP (result))
{
Lisp_Object event = Qnil;
struct Lisp_Event *e;
if (event_next (XEVENT (event0)))
XSETEVENT (event, event_next (XEVENT (event0)));
if (!NILP (event) && EVENTP (event))
{
for (;;)
{
e = event_next (XEVENT (event));
Fdeallocate_event (event);
if (e == 0)
break;
XSETEVENT (event, e);
}
}
e = XEVENT (event0);
e->event.key.modifiers = 0;
e->event.key.keysym = result;
e->next = 0;
command_builder->last_non_function_event = Qnil;
return (command_builder_find_leaf (command_builder,
allow_misc_user_events_p));
}
else
{
if (!NILP (command_builder->last_non_function_event))
repush_function_events (command_builder);
/* drop through and continue */
}
}
}
/* If we didn't find a binding, and the last event in the sequence is
a shifted character, then try again with the lowercase version. */
for (terminal = XEVENT (event0);
event_next (terminal);
terminal = event_next (terminal))
;
/* If key-sequence wasn't bound, we'll try some fallbacks. */
if (!NILP (Vretry_undefined_key_binding_unshifted)
&& terminal->event_type == key_press_event
&& ((terminal->event.key.modifiers & MOD_SHIFT)
|| (INTP (terminal->event.key.keysym)
&& XINT (terminal->event.key.keysym) >= 'A'
&& XINT (terminal->event.key.keysym) <= 'Z')))
{
struct Lisp_Event terminal_copy;
terminal_copy = *terminal;
if (terminal->event.key.modifiers & MOD_SHIFT)
terminal->event.key.modifiers &= (~ MOD_SHIFT);
else
terminal->event.key.keysym
= make_number (XINT (terminal->event.key.keysym) + 'a' - 'A');
result = command_builder_find_leaf (command_builder,
allow_misc_user_events_p);
if (!NILP (result))
return (result);
/* If there was no match with the lower-case version either, then
put back the upper-case event for the error message. */
*terminal = terminal_copy;
}
if (!NILP (Vprefix_help_command) &&
event_matches_key_specifier_p (terminal, Vhelp_char))
{
return (Vprefix_help_command);
}
return (Qnil);
}
/* Every time a command-event (a key, button, or menu selection) is read by
Fnext_event(), it is stored in the recent_keys_ring, in Vlast_input_event,
and in Vthis_command_keys. (Eval-events are not stored there.)
Every time a command is invoked, Vlast_command_event is set to the last
event in the sequence.
This means that Vthis_command_keys is really about "input read since the
last command was executed" rather than about "what keys invoked this
command." This is a little counterintuitive, but that's the way it
has always worked.
As an extra kink, the function read-key-sequence resets/updates the
last-command-event and this-command-keys. It doesn't append to the
command-keys as read-char does. Such are the pitfalls of having to
maintain compatibility with a program for which the only specification
is the code itself.
(We could implement recent_keys_ring and Vthis_command_keys as the same
data structure.)
*/
#define RECENT_KEYS_SIZE 100
Lisp_Object recent_keys_ring;
int recent_keys_ring_index;
DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 0, 0,
"Return vector of last 100 or so keyboard or mouse button events read.\n\
This copies the event objects into a new vector; it is safe to keep and\n\
modify them.")
()
{
struct gcpro gcpro1;
Lisp_Object val = Qnil;
int size = XVECTOR (recent_keys_ring)->size;
int start, nkeys, i, j;
GCPRO1 (val);
if (NILP (vector_data (XVECTOR (recent_keys_ring))[recent_keys_ring_index]))
/* This means the vector has not yet wrapped */
{
nkeys = recent_keys_ring_index;
start = 0;
}
else
{
nkeys = size;
start = ((recent_keys_ring_index == size) ? 0 : recent_keys_ring_index);
}
val = make_vector (nkeys, Qnil);
for (i = 0, j = start; i < nkeys; i++)
{
Lisp_Object e = vector_data (XVECTOR (recent_keys_ring))[j];
if (NILP (e))
abort ();
vector_data (XVECTOR (val))[i] = Fcopy_event (e, Qnil);
if (++j >= size)
j = 0;
}
UNGCPRO;
return (val);
}
/* An event (actually an event chain linked through event_next) or Qnil.
This is stored reversed, with the most recent (copied) event as the
head of the chain. */
Lisp_Object Vthis_command_keys;
/* Vthis_command_keys having value Qnil means that the next time
push_this_command_keys is called, it should start over.
The times at which the the command-keys are reset
(instead of merely being augumented) are pretty conterintuitive.
*/
Lisp_Object
reset_this_command_keys (Lisp_Object reset_echo)
{
Lisp_Object e = Vthis_command_keys;
if (!NILP (reset_echo))
reset_key_echo (the_command_builder, 1);
if (NILP (e))
return (Qnil);
for (;;)
{
struct Lisp_Event *n = event_next (XEVENT (e));
Fdeallocate_event (e);
if (!n)
{
Vthis_command_keys = Qnil;
return (Qnil);
}
XSETEVENT (e, n);
}
}
static void
push_this_command_keys (Lisp_Object event)
{
Lisp_Object new = Fallocate_event ();
Fcopy_event (event, new);
set_event_next (XEVENT (new),
((!NILP (Vthis_command_keys))
? XEVENT (Vthis_command_keys)
: 0));
Vthis_command_keys = new;
}
static void
push_recent_keys (Lisp_Object event)
{
Lisp_Object e
= vector_data (XVECTOR (recent_keys_ring)) [recent_keys_ring_index];
if (NILP (e))
{
e = Fallocate_event ();
vector_data (XVECTOR (recent_keys_ring)) [recent_keys_ring_index] = e;
}
Fcopy_event (event, e);
if (++recent_keys_ring_index == XVECTOR (recent_keys_ring)->size)
recent_keys_ring_index = 0;
}
static Lisp_Object
current_events_into_vector (struct command_builder *command_builder)
{
Lisp_Object vector;
struct Lisp_Event *e;
int n;
for (e = XEVENT (command_builder->current_events), n = 0;
e;
e = event_next (e), n++)
;
/* Copy the vector and the events in it. */
/* No need to copy the events, since they're already copies, and
nobody other than the command-builder has pointers to them */
vector = make_vector (n, Qnil);
for (e = XEVENT (command_builder->current_events), n = 0;
e;
e = event_next (e), n++)
XSETEVENT (vector_data (XVECTOR (vector))[n], e);
command_builder->current_events = Qnil;
command_builder->most_current_event = Qnil;
command_builder->last_non_function_event = Qnil;
return (vector);
}
/* Do command-loop book-keeping for keypresses, mouse-buttons
* and menu-events */
static Lisp_Object
lookup_command_event (struct command_builder *command_builder,
Lisp_Object event, int allow_misc_user_events_p)
{
/* This function can GC */
struct frame *f = selected_frame ();
/* Clear output from previous command execution */
if (!EQ (Qcommand, echo_area_status (f))
/* but don't let mouse-up clear what mouse-down just printed */
&& (XEVENT (event)->event_type != button_release_event))
clear_echo_area (f, Qnil, 0);
/* Add the given event to the command builder, enlarging the vector
first if necessary.
Extra hack: this also updates the recent_keys_ring and Vthis_command_keys
vectors to translate "ESC x" to "M-x" (for any "x" of course).
*/
{
Lisp_Object recent = command_builder->most_current_event;
if (EVENTP (recent)
&& event_matches_key_specifier_p (XEVENT (recent), Vmeta_prefix_char))
{
struct Lisp_Event *e;
/* When we see a sequence like "ESC x", pretend we really saw "M-x".
DoubleThink the recent-keys and this-command-keys as well. */
/* Modify the previous most-recently-pushed event on the command
builder to be a copy of this one with the meta-bit set instead of
pushing a new event.
*/
Fcopy_event (event, recent);
e = XEVENT (recent);
if (e->event_type == key_press_event)
e->event.key.modifiers |= MOD_META;
else if (e->event_type == button_press_event
|| e->event_type == button_release_event)
e->event.button.modifiers |= MOD_META;
else
abort ();
if (command_builder->echo_esc_index >= 0)
{
/* regenerate the final echo-glyph */
command_builder->echo_buf_index = command_builder->echo_esc_index;
echo_key_event (command_builder, recent);
command_builder->echo_esc_index = -1;
}
}
else
{
event = Fcopy_event (event, Fallocate_event ());
if (EVENTP (recent))
set_event_next (XEVENT (recent), XEVENT (event));
else
command_builder->current_events = event;
command_builder->most_current_event = event;
}
}
{
Lisp_Object leaf = command_builder_find_leaf (command_builder,
allow_misc_user_events_p);
struct gcpro gcpro1;
GCPRO1 (leaf);
if (KEYMAPP (leaf))
{
Lisp_Object prompt = Fkeymap_prompt (leaf, Qt);
if (STRINGP (prompt))
{
/* Append keymap prompt to key echo buffer */
int buf_index = command_builder->echo_buf_index;
int len = string_length (XSTRING (prompt));
if (len + buf_index + 1 <= command_builder->echo_buf_length)
{
Bufbyte *echo = command_builder->echo_buf + buf_index;
memcpy (echo, string_data (XSTRING (prompt)), len);
echo[len] = 0;
}
maybe_echo_keys (command_builder, 1);
}
else
maybe_echo_keys (command_builder, 0);
}
else if (!NILP (leaf))
{
if (EQ (Qcommand, echo_area_status (f))
&& command_builder->echo_buf_index > 0)
{
/* If we had been echoing keys, echo the last one (without the trailing
dash) and redisplay before executing the command. */
command_builder->echo_buf[command_builder->echo_buf_index] = 0;
maybe_echo_keys (command_builder, 1);
Fsit_for (Qzero, Qt);
}
}
RETURN_UNGCPRO (leaf);
}
}
static Lisp_Object
execute_command_event_unwind (Lisp_Object datum)
{
if (!NILP (XCAR (datum)))
{
/* We're doing an abort unwind */
reset_this_command_keys (Qt);
}
free_cons (XCONS (datum));
return (Qzero);
}
static void
execute_command_event (struct command_builder *command_builder,
Lisp_Object event)
{
/* This function can GC */
/* store last_command_event */
{
reset_current_events (command_builder);
if (XEVENT (event)->event_type == key_press_event)
Vcurrent_mouse_event = Qnil;
else if (XEVENT (event)->event_type == button_press_event
|| XEVENT (event)->event_type == button_release_event)
Vcurrent_mouse_event = Fcopy_event (event, Qnil);
/* Store the last-command-event. The semantics of this is that it is
the last event most recently involved in command-lookup.
*/
if (!EVENTP (Vlast_command_event))
Vlast_command_event = Fallocate_event ();
if (XEVENT (Vlast_command_event)->event_type == dead_event)
{
Vlast_command_event = Fallocate_event ();
error ("Someone deallocated the last-command-event!");
}
if (! EQ (event, Vlast_command_event))
Fcopy_event (event, Vlast_command_event);
/* Note that last-command-char will never have its high-bit set, in
an effort to sidestep the ambiguity between M-x and oslash.
*/
Vlast_command_char = Fevent_to_character (Vlast_command_event,
Qnil, Qnil, Qnil);
}
/* Actually call the command, with all sorts of hair to preserve or clear
the echo-area and region as appropriate and call the pre- and post-
command-hooks.
*/
{
int old_kbd_macro = kbd_macro_end;
int speccount = specpdl_depth ();
Lisp_Object locative = Fcons (Qt, Qnil);
struct window *w;
struct gcpro gcpro1;
GCPRO1 (locative); /* just in case ... */
w = XWINDOW (Fselected_window (Qnil));
/* We're executing a new command, so the old value of is irrelevant. */
zmacs_region_stays = 0;
/* If the previous command tried to force a specific window-start,
reset the flag in case this command moves point far away from
that position. Also, reset the window's buffer's change
information so that we don't trigger an incremental update. */
if (w->force_start)
{
w->force_start = 0;
buffer_reset_changes (XBUFFER (w->buffer));
}
/* Now we actually execute the command.
If the command completes abnormally (signals an error, or does
a throw past us) then we want Vthis_command_keys to get set to Qnil.
Otherwise, we want it unchanged.
*/
record_unwind_protect (execute_command_event_unwind, locative);
pre_command_hook ();
if (XEVENT (event)->event_type == misc_user_event)
{
call1 (XEVENT (event)->event.eval.function,
XEVENT (event)->event.eval.object);
}
else
{
#if 0
call2 (Qcommand_execute, Vthis_command, Qnil);
#else
Fcommand_execute (Vthis_command, Qnil);
#endif
}
/* We completed normally -- don't do reset in unwind-protect */
XCAR (locative) = Qnil;
unbind_to (speccount, Qnil);
post_command_hook ();
if (!NILP (Vprefix_arg))
{
/* Commands that set the prefix arg don't update last-command, don't
reset the echoing state, and don't go into keyboard macros unless
followed by another command.
*/
maybe_echo_keys (command_builder, 0);
/* If we're recording a keyboard macro, and the last command
executed set a prefix argument, then decrement the pointer to
the "last character really in the macro" to be just before this
command. This is so that the ^U in "^U ^X )" doesn't go onto
the end of macro.
*/
if (defining_kbd_macro)
kbd_macro_end = old_kbd_macro;
}
else
{
/* Start a new command next time */
Vlast_command = Vthis_command;
reset_this_command_keys (Qnil);
/* Emacs 18 doesn't unconditionally clear the echoed keystrokes,
so we don't either */
reset_key_echo (command_builder, 0);
}
UNGCPRO;
}
}
static void
pre_command_hook (void)
{
last_point_position = BUF_PT (current_buffer);
XSETBUFFER (last_point_position_buffer, current_buffer);
/* This function can GC */
if (!NILP (Vrun_hooks) && !NILP (Vpre_command_hook))
call1 (Vrun_hooks, Qpre_command_hook);
if (!NILP (Vrun_hooks) && !NILP (Vlocal_pre_command_hook))
call1 (Vrun_hooks, Qlocal_pre_command_hook);
}
static void
post_command_hook (void)
{
/* This function can GC */
/* Turn off region highlighting unless this command requested that
it be left on, or we're in the minibuffer. We don't turn it off
when we're in the minibuffer so that things like M-x write-region
still work!
This could be done via a function on the post-command-hook, but
we don't want the user to accidentally remove it.
*/
if (! zmacs_region_stays
/* #### This has the bug that any region set in the minibuffer is
* #### always sticky! I think the intention was to make selections
* #### in the old buffer stay around whilst the minibuffer was used
* #### but the effect is losing. */
&& !MINI_WINDOW_P (XWINDOW (Fselected_window (Qnil))))
zmacs_deactivate_region ();
else
zmacs_update_region ();
if (!NILP (Vrun_hooks) && !NILP (Vpost_command_hook))
call1 (Vrun_hooks, Qpost_command_hook);
if (!NILP (Vrun_hooks) && !NILP (Vlocal_post_command_hook))
call1 (Vrun_hooks, Qlocal_post_command_hook);
#if 0 /* FSFmacs */
if (!NILP (current_buffer->mark_active))
{
if (!NILP (Vdeactivate_mark) && !NILP (Vtransient_mark_mode))
{
current_buffer->mark_active = Qnil;
call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
}
else if (current_buffer != prev_buffer ||
BUF_MODIFF (current_buffer) != prev_modiff)
call1 (Vrun_hooks, intern ("activate-mark-hook"));
}
#endif /* FSFmacs */
}
DEFUN ("dispatch-event", Fdispatch_event, Sdispatch_event, 1, 1, 0,
"Given an event object as returned by `next-event', execute it.\n\
\n\
Key-press, button-press, and button-release events get accumulated\n\
until a complete key sequence (see `read-key-sequence') is reached,\n\
at which point the sequence is looked up in the current keymaps and\n\
acted upon.\n\
\n\
Mouse motion events cause the low-level handling function stored in\n\
`mouse-motion-handler' to be called. (There are very few circumstances\n\
under which you should change this handler. Use `mode-motion-hook'\n\
instead.)\n\
\n\
Menu, timeout, and eval events cause the associated function or handler\n\
to be called.\n\
\n\
Process events cause the subprocess's output to be read and acted upon\n\
appropriately (see `start-process').\n\
\n\
Magic events are handled as necessary.")
(event)
Lisp_Object event;
{
/* This function can GC */
struct command_builder *command_builder = the_command_builder;
struct Lisp_Event *ev;
Lisp_Object device;
CHECK_LIVE_EVENT (event, 0);
ev = XEVENT (event);
/* Some events don't have devices (e.g. eval events). */
device = EVENT_DEVICE (ev);
if (NILP (device))
device = Fselected_device ();
else
{
/* events on dead devices get silently eaten */
if (!DEVICE_LIVE_P (XDEVICE (device)))
return Qnil;
if (!EQ (device, Fselected_device ()))
Fselect_device (device);
}
switch (XEVENT (event)->event_type)
{
case button_press_event:
case button_release_event:
/* events on dead frames get silently eaten */
if (!FRAME_LIVE_P (XFRAME (XEVENT (event)->channel)))
break;
case key_press_event:
{
Lisp_Object leaf;
leaf = lookup_command_event (command_builder, event, 1);
if (KEYMAPP (leaf))
/* Incomplete key sequence */
break;
if (NILP (leaf))
{
/* At this point, we know that the sequence is not bound to a
command. Normally, we beep and print a message informing the
user of this. But we do not beep or print a message when:
o the last event in this sequence is a mouse-up event; or
o the last event in this sequence is a mouse-down event and
there is a binding for the mouse-up version.
That is, if the sequence ``C-x button1'' is typed, and is not
bound to a command, but the sequence ``C-x button1up'' is bound
to a command, we do not complain about the ``C-x button1''
sequence. If neither ``C-x button1'' nor ``C-x button1up'' is
bound to a command, then we complain about the ``C-x button1''
sequence, but later will *not* complain about the
``C-x button1up'' sequence, which would be redundant.
This is pretty hairy, but I think it's the most intuitive
behavior.
*/
struct Lisp_Event *terminal
= XEVENT (command_builder->most_current_event);
if (terminal->event_type == button_press_event)
{
int no_bitching;
/* Temporarily pretend the last event was an "up" instead of a
"down", and look up its binding. */
terminal->event_type = button_release_event;
/* If the "up" version is bound, don't complain. */
no_bitching
= !NILP (command_builder_find_leaf
(command_builder, 0));
/* Undo the temporary changes we just made. */
terminal->event_type = button_press_event;
if (no_bitching)
{
/* Pretend this press was not seen (treat as a prefix) */
if (XEVENT (command_builder->current_events) == terminal)
{
reset_current_events (command_builder);
}
else
{
struct Lisp_Event *e;
for (e = XEVENT (command_builder->current_events);
event_next (e) != terminal;
e = event_next (e))
;
Fdeallocate_event (command_builder->most_current_event);
set_event_next (e, 0);
XSETEVENT (command_builder->most_current_event, e);
}
maybe_echo_keys (command_builder, 1);
break;
}
}
/* Complain that the typed sequence is not defined, if this is the
kind of sequence that warrants a complaint.
*/
reset_key_echo (command_builder, 0);
defining_kbd_macro = 0;
Vprefix_arg = Qnil;
/* Don't complain about undefined button-release events */
if (terminal->event_type != button_release_event)
{
Lisp_Object keys = current_events_into_vector(command_builder);
/* Reset the command builder for reading the next sequence. */
reset_current_events (command_builder);
/* Run the pre-command-hook before barfing about an undefined
key. */
Vthis_command = Qnil;
pre_command_hook ();
/* The post-command-hook doesn't run. */
Fsignal (Qundefined_keystroke_sequence, list1 (keys));
}
/* Reset the command builder for reading the next sequence. */
reset_current_events (command_builder);
reset_this_command_keys (Qt);
}
else
{
Vthis_command = leaf;
/* Don't push an undo boundary if the command set the prefix arg,
or if we are executing a keyboard macro, or if in the
minibuffer. If the command we are about to execute is
self-insert, it's tricky: up to 20 consecutive self-inserts may
be done without an undo boundary. This counter is reset as
soon as a command other than self-insert-command is executed.
*/
if (! EQ (leaf, Qself_insert_command))
command_builder->self_insert_countdown = 0;
if (NILP (Vprefix_arg)
&& NILP (Vexecuting_macro)
&& !EQ (minibuf_window, Fselected_window (Qnil))
&& command_builder->self_insert_countdown == 0)
Fundo_boundary ();
if (EQ (leaf, Qself_insert_command))
{
if (--command_builder->self_insert_countdown < 0)
command_builder->self_insert_countdown = 20;
}
execute_command_event (command_builder, event);
}
break;
}
case misc_user_event:
{
/* Jamie said:
We could just always use the menu item entry, whatever it is, but
this might break some Lisp code that expects `this-command' to
always contain a symbol. So only store it if this is a simple
`call-interactively' sort of menu item.
But this is bogus. `this-command' could be a string or vector
anyway (for keyboard macros). There's even one instance
(in pending-del.el) of `this-command' getting set to a cons
(a lambda expression). So in the `eval' case I'll just
convert it into a lambda expression.
*/
if (EQ (XEVENT (event)->event.eval.function, Qcall_interactively)
&& SYMBOLP (XEVENT (event)->event.eval.object))
Vthis_command = XEVENT (event)->event.eval.object;
else if (EQ (XEVENT (event)->event.eval.function, Qeval))
Vthis_command =
Fcons (Qlambda, Fcons (Qnil, XEVENT (event)->event.eval.object));
else if (SYMBOLP (XEVENT (event)->event.eval.function))
/* A scrollbar command or the like. */
Vthis_command = XEVENT (event)->event.eval.function;
else
/* Huh? */
Vthis_command = Qnil;
command_builder->self_insert_countdown = 0;
if (NILP (Vprefix_arg)
&& NILP (Vexecuting_macro)
&& !EQ (minibuf_window, Fselected_window (Qnil)))
Fundo_boundary ();
execute_command_event (command_builder, event);
break;
}
default:
{
execute_internal_event (event);
break;
}
}
return (Qnil);
}
DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 1, 0,
"Read a sequence of keystrokes or mouse clicks.\n\
Returns a vector of the event objects read. The vector and the event\n\
objects it contains are freshly created (and will not be side-effected\n\
by subsequent calls to this function).\n\
\n\
The sequence read is sufficient to specify a non-prefix command starting\n\
from the current local and global keymaps. A C-g typed while in this\n\
function is treated like any other character, and `quit-flag' is not set.\n\
\n\
First arg PROMPT is a prompt string. If nil, do not prompt specially.\n\
\n\
If the user selects a menu item while we are prompting for a key-sequence,\n\
the returned value will be a vector of a single menu-selection event.\n\
An error will be signalled if you pass this value to `lookup-key' or a\n\
related function.")
(prompt)
Lisp_Object prompt;
{
/* This function can GC */
struct command_builder *command_builder = the_command_builder;
Lisp_Object result;
Lisp_Object event = Fallocate_event ();
int speccount = specpdl_depth ();
struct gcpro gcpro1;
GCPRO1 (event);
if (!NILP (prompt))
CHECK_STRING (prompt, 0);
/* else prompt = Fkeymap_prompt (current_buffer->keymap); may GC */
QUIT;
reset_this_command_keys (Qnil);
specbind (Qinhibit_quit, Qt);
for (;;)
{
Fnext_event (event, prompt);
if (! command_event_p (XEVENT (event)))
execute_internal_event (event);
else
{
if (XEVENT (event)->event_type == misc_user_event)
reset_current_events (command_builder);
result = lookup_command_event (command_builder, event, 1);
if (!KEYMAPP (result))
{
result = current_events_into_vector (command_builder);
reset_key_echo (command_builder, 0);
break;
}
prompt = Qnil;
}
}
Vquit_flag = Qnil; /* In case we read a ^G; do not call check_quit() here */
Fdeallocate_event (event);
RETURN_UNGCPRO (unbind_to (speccount, result));
}
DEFUN ("this-command-keys", Fthis_command_keys, Sthis_command_keys, 0, 0, 0,
"Return a vector of the keyboard or mouse button events that were used\n\
to invoke this command. This copies the vector and the events; it is safe\n\
to keep and modify them.")
()
{
struct Lisp_Event *e;
Lisp_Object result;
int len;
if (NILP (Vthis_command_keys))
return (make_vector (0, Qnil));
for (e = XEVENT (Vthis_command_keys), len = 0;
e;
e = event_next (e), len++)
;
/* Vthis_command_keys is threaded in reverse-chronological order */
result = make_vector (len, Qnil);
for (e = XEVENT (Vthis_command_keys);
e;
e = event_next (e), len--)
{
Lisp_Object tem = Qnil;
XSETEVENT (tem, e);
vector_data (XVECTOR (result))[len - 1] = Fcopy_event (tem, Qnil);
}
return (result);
}
int
poll_fds_for_input (SELECT_TYPE mask)
{
EMACS_TIME sometime;
EMACS_SELECT_TIME select_time;
SELECT_TYPE temp_mask;
int retval;
while (1)
{
EMACS_SET_SECS_USECS (sometime, 0, 0);
EMACS_TIME_TO_SELECT_TIME (sometime, select_time);
temp_mask = mask;
/* To effect a poll, tell select() to block for zero seconds. */
retval = select (MAXDESC, &temp_mask, 0, 0, &select_time);
if (retval >= 0)
return retval;
/* else, we got interrupted by a signal, so try again. */
}
return 0; /* not reached */
}
static int signal_event_pipe_initialized;
void
signal_fake_event (void)
{
char byte = 0;
/* We do the write always. Formerly I tried to "optimize" this
by setting a flag indicating whether we're blocking and only
doing the write in that case, but there is a race condition
if the signal occurs after we've checked for the signal
occurrence (which could occur in many places throughout
an iteration of the command loop, e.g. in status_notify()),
but before we set the blocking flag.
This should be OK as long as write() is reentrant, which
I'm fairly sure it is since it's a system call. */
if (signal_event_pipe_initialized)
/* In case a signal comes through while we're dumping */
{
int old_errno = errno;
write (signal_event_pipe[1], &byte, 1);
errno = old_errno;
}
}
void
drain_signal_event_pipe (void)
{
char chars[128];
/* The input end of the pipe has been set to non-blocking. */
while (read (signal_event_pipe[0], chars, sizeof (chars)) > 0)
;
}
/************************************************************************/
/* initialization */
/************************************************************************/
void
syms_of_event_stream (void)
{
defsymbol (&Qdisabled, "disabled");
deferror (&Qundefined_keystroke_sequence, "undefined-keystroke-sequence",
"Undefined keystroke sequence", 1);
defsymbol (&Qundefined, "undefined");
defsymbol (&Qcommand_execute, "command-execute");
defsymbol (&Qemacs_handle_focus_change, "emacs-handle-focus-change");
defsubr (&Srecent_keys);
defsubr (&Sinput_pending_p);
defsubr (&Senqueue_eval_event);
defsubr (&Semacs_handle_focus_change);
defsubr (&Snext_event);
defsubr (&Snext_command_event);
defsubr (&Sdiscard_input);
defsubr (&Ssit_for);
defsubr (&Ssleep_for);
defsubr (&Saccept_process_output);
defsubr (&Sadd_timeout);
defsubr (&Sdisable_timeout);
defsubr (&Sadd_async_timeout);
defsubr (&Sdisable_async_timeout);
defsubr (&Sdispatch_event);
defsubr (&Sread_key_sequence);
defsubr (&Sthis_command_keys);
defsymbol (&Qpre_command_hook, "pre-command-hook");
defsymbol (&Qpost_command_hook, "post-command-hook");
defsymbol (&Qlocal_pre_command_hook, "local-pre-command-hook");
defsymbol (&Qunread_command_events, "unread-command-events");
defsymbol (&Qunread_command_event, "unread-command-event");
}
void
vars_of_event_stream (void)
{
#ifdef HAVE_X_WINDOWS
vars_of_event_Xt ();
#endif
#if defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)
vars_of_event_tty ();
#endif
#ifdef HAVE_NEXTSTEP
vars_of_event_ns ();
#endif
the_command_builder
= (struct command_builder *) xmalloc (sizeof (struct command_builder));
the_command_builder->current_events = Qnil;
the_command_builder->most_current_event = Qnil;
the_command_builder->prefix_events = Qnil;
the_command_builder->last_non_function_event = Qnil;
the_command_builder->echo_buf_length = 300; /* #### Kludge */
the_command_builder->echo_buf =
(Bufbyte *) xmalloc (the_command_builder->echo_buf_length);
the_command_builder->echo_buf[0] = 0;
the_command_builder->echo_buf_index = -1;
the_command_builder->echo_esc_index = -1;
the_command_builder->self_insert_countdown = 0;
staticpro (&the_command_builder->current_events);
staticpro (&the_command_builder->prefix_events);
recent_keys_ring_index = 0;
recent_keys_ring = make_vector (RECENT_KEYS_SIZE, Qnil);
staticpro (&recent_keys_ring);
Vthis_command_keys = Qnil;
staticpro (&Vthis_command_keys);
num_input_chars = 0;
command_event_queue = Qnil;
staticpro (&command_event_queue);
Vlast_selected_frame = Qnil;
staticpro (&Vlast_selected_frame);
pending_timeout_list = Qnil;
staticpro (&pending_timeout_list);
pending_async_timeout_list = Qnil;
staticpro (&pending_async_timeout_list);
the_low_level_timeout_blocktype =
Blocktype_new (struct low_level_timeout_blocktype);
something_happened = 0;
last_point_position_buffer = Qnil;
staticpro (&last_point_position_buffer);
DEFVAR_INT ("echo-keystrokes", &echo_keystrokes,
"*Nonzero means echo unfinished commands after this many seconds of pause.");
echo_keystrokes = 1;
DEFVAR_INT ("auto-save-interval", &auto_save_interval,
"*Number of keyboard input characters between auto-saves.\n\
Zero means disable autosaving due to number of characters typed.\n\
See also the variable `auto-save-timeout'.");
auto_save_interval = 300;
DEFVAR_LISP ("pre-command-hook", &Vpre_command_hook,
"Function or functions to run before every command.\n\
This may examine the `this-command' variable to find out what command\n\
is about to be run, or may change it to cause a different command to run.\n\
Function on this hook must be careful to avoid signalling errors!");
Vpre_command_hook = Qnil;
DEFVAR_LISP ("post-command-hook", &Vpost_command_hook,
"Function or functions to run after every command.\n\
This may examine the `this-command' variable to find out what command\n\
was just executed.");
Vpost_command_hook = Qnil;
DEFVAR_LISP ("last-command-event", &Vlast_command_event,
"Last keyboard or mouse button event that was part of a command. This\n\
variable is off limits: you may not set its value or modify the event that\n\
is its value, as it is destructively modified by `read-key-sequence'. If\n\
you want to keep a pointer to this value, you must use `copy-event'.");
Vlast_command_event = Qnil;
DEFVAR_LISP ("last-command-char", &Vlast_command_char,
"If the value of `last-command-event' is a keyboard event, then\n\
this is the nearest ASCII equivalent to it. This the the value that\n\
`self-insert-command' will put in the buffer. Remember that there is\n\
NOT a 1:1 mapping between keyboard events and ASCII characters: the set\n\
of keyboard events is much larger, so writing code that examines this\n\
variable to determine what key has been typed is bad practice, unless\n\
you are certain that it will be one of a small set of characters.");
Vlast_command_char = Qnil;
DEFVAR_LISP ("last-input-event", &Vlast_input_event,
"Last keyboard or mouse button event received. This variable is off\n\
limits: you may not set its value or modify the event that is its value, as\n\
it is destructively modified by `next-event'. If you want to keep a pointer\n\
to this value, you must use `copy-event'.");
Vlast_input_event = Qnil;
DEFVAR_LISP ("last-input-char", &Vlast_input_char,
"If the value of `last-input-event' is a keyboard event, then\n\
this is the nearest ASCII equivalent to it. Remember that there is\n\
NOT a 1:1 mapping between keyboard events and ASCII characters: the set\n\
of keyboard events is much larger, so writing code that examines this\n\
variable to determine what key has been typed is bad practice, unless\n\
you are certain that it will be one of a small set of characters.");
Vlast_input_char = Qnil;
DEFVAR_LISP ("last-input-time", &Vlast_input_time,
"The time (in seconds since Jan 1, 1970) of the last-command-event,\n\
represented as a cons of two 16-bit integers. This is destructively\n\
modified, so copy it if you want to keep it.");
Vlast_input_time = Qnil;
DEFVAR_LISP ("unread-command-events", &Vunread_command_events,
"List of event objects to be read as next command input events.\n\
This can be used to simulate the receipt of events from the user.\n\
Normally this is nil.");
Vunread_command_events = Qnil;
DEFVAR_LISP ("unread-command-event", &Vunread_command_event,
"Obsolete. Use `unread-command-events' instead.");
Vunread_command_event = Qnil;
DEFVAR_LISP ("last-command", &Vlast_command,
"The last command executed. Normally a symbol with a function definition,\n\
but can be whatever was found in the keymap, or whatever the variable\n\
`this-command' was set to by that command.");
Vlast_command = Qnil;
DEFVAR_LISP ("this-command", &Vthis_command,
"The command now being executed.\n\
The command can set this variable; whatever is put here\n\
will be in `last-command' during the following command.");
Vthis_command = Qnil;
DEFVAR_LISP ("help-char", &Vhelp_char,
"Character to recognize as meaning Help.\n\
When it is read, do `(eval help-form)', and display result if it's a string.\n\
If the value of `help-form' is nil, this char can be read normally.\n\
This can be any form recognized as a single key specifier.\n\
To disable the help-char, set it to a negative number.");
Vhelp_char = make_number (8); /* C-h */
DEFVAR_LISP ("help-form", &Vhelp_form,
"Form to execute when character help-char is read.\n\
If the form returns a string, that string is displayed.\n\
If `help-form' is nil, the help char is not recognized.");
Vhelp_form = Qnil;
DEFVAR_LISP ("prefix-help-command", &Vprefix_help_command,
"Command to run when `help-char' character follows a prefix key.\n\
This command is used only when there is no actual binding\n\
for that character after that prefix key.");
Vprefix_help_command = Qnil;
DEFVAR_LISP ("keyboard-translate-table", &Vkeyboard_translate_table,
"String used as translate table for keyboard input, or nil.\n\
Each character is looked up in this string and the contents used instead.\n\
If string is of length N, character codes N and up are untranslated.\n\
This is the right thing to use only if you are on a dumb tty, as it cannot\n\
handle input which cannot be represented as ASCII. If you are running emacs\n\
under X, you should do the translations with the `xmodmap' program instead.");
Vkeyboard_translate_table = Qnil;
DEFVAR_LISP ("retry-undefined-key-binding-unshifted",
&Vretry_undefined_key_binding_unshifted,
"If a key-sequence which ends with a shifted keystroke is undefined\n\
and this variable is non-nil then the command lookup is retried again\n\
with the last key unshifted. (e.g. C-X C-F would be retried as C-X C-f.)\n\
If lookup still fails, a normal error is signalled.");
Vretry_undefined_key_binding_unshifted = Qt;
Vcontrolling_terminal = Qnil;
staticpro (&Vcontrolling_terminal);
}
void
complex_vars_of_event_stream (void)
{
DEFVAR_LISP ("local-pre-command-hook", &Vlocal_pre_command_hook,
"Buffer-local function or functions to run before every command.\n\
This variable is local to each buffer (see also `pre-command-hook').\n\
This may examine the `this-command' variable to find out what command\n\
is about to be run, or may change it to cause a different command to run.\n\
Function on this hook must be careful to avoid signalling errors!");
Vlocal_pre_command_hook = Qnil;
Fmake_variable_buffer_local (Qlocal_pre_command_hook);
defsymbol (&Qlocal_post_command_hook, "local-post-command-hook");
DEFVAR_LISP ("local-post-command-hook", &Vlocal_post_command_hook,
"Buffer-local function or functions to run after every command.\n\
This variable is local to each buffer (see also `post-command-hook').\n\
This may examine the `this-command' variable to find out what command\n\
was just executed.");
Vlocal_post_command_hook = Qnil;
Fmake_variable_buffer_local (Qlocal_post_command_hook);
}
void
init_event_stream (void)
{
if (initialized)
{
/* Do this first; the init_event_*_late() functions
pay attention to it. */
if (pipe (signal_event_pipe) < 0)
{
perror ("XEmacs: can't open pipe");
exit (-1);
}
signal_event_pipe_initialized = 1;
/* Set it non-blocking so we can drain its output. */
set_descriptor_non_blocking (signal_event_pipe[0]);
/* WARNING: In order for the signal-event pipe to work correctly
and not cause lockups, the following need to be followed:
1) event_pending_p() must ignore input on the signal-event pipe.
2) As soon as next_event() notices input on the signal-event
pipe, it must drain it. */
FD_ZERO (&input_wait_mask);
FD_ZERO (&non_fake_input_wait_mask);
FD_ZERO (&process_only_mask);
FD_ZERO (&device_only_mask);
FD_SET (signal_event_pipe[0], &input_wait_mask);
#ifdef HAVE_X_WINDOWS
if (!strcmp (display_use, "x"))
init_event_Xt_late ();
else
#endif
#ifdef HAVE_NEXTSTEP
if (!strcmp (display_use, "ns"))
init_event_ns_late ();
else
#endif
{
/* For TTY's, use the Xt event loop if we can; it allows
us to later open an X connection. */
#if defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM)
init_event_Xt_late ();
#else
init_event_tty_late ();
#endif
}
init_interrupts_late ();
}
}
/*
useful testcases for v18/v19 compatibility:
(defun foo ()
(interactive)
(setq unread-command-event (character-to-event ?A (allocate-event)))
(setq x (list (read-char)
; (read-key-sequence "") ; try it with and without this
last-command-char last-input-char
(recent-keys) (this-command-keys))))
(global-set-key "\^Q" 'foo)
without the read-key-sequence:
^Q ==> (65 17 65 [... ^Q] [^Q])
^U^U^Q ==> (65 17 65 [... ^U ^U ^Q] [^U ^U ^Q])
^U^U^U^G^Q ==> (65 17 65 [... ^U ^U ^U ^G ^Q] [^Q])
with the read-key-sequence:
^Qb ==> (65 [b] 17 98 [... ^Q b] [b])
^U^U^Qb ==> (65 [b] 17 98 [... ^U ^U ^Q b] [b])
^U^U^U^G^Qb ==> (65 [b] 17 98 [... ^U ^U ^U ^G ^Q b] [b])
;the evi-mode command "4dlj.j.j.j.j.j." is also a good testcase (gag)
;(setq x (list (read-char) quit-flag))^J^G
;(let ((inhibit-quit t)) (setq x (list (read-char) quit-flag)))^J^G
;for BOTH, x should get set to (7 t), but no result should be printed.
;also do this: make two frames, one viewing "*scratch*", the other "foo".
;in *scratch*, type (sit-for 20)^J
;wait a couple of seconds, move cursor to foo, type "a"
;a should be inserted in foo. Cursor highlighting should not change in
;the meantime.
;do it with sleep-for. move cursor into foo, then back into *scratch*
;before typing.
;make sure ^G aborts both sit-for and sleep-for.
(defun tst ()
(list (condition-case c
(sleep-for 20)
(quit c))
(read-char)))
(tst)^Ja^G ==> ((quit) 97) with no signal
(tst)^J^Ga ==> ((quit) 97) with no signal
(tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer
Do this:
(setq enable-recursive-minibuffers t
minibuffer-max-depth nil)
ESC ESC ESC ESC - there are now two minibuffers active
C-g C-g C-g - there should be active 0, not 1
Similarly:
C-x C-f ~ / ? - wait for "Making completion list..." to display
C-g - wait for "Quit" to display
C-g - minibuffer should not be active
however C-g before "Quit" is displayed should leave minibuffer active.
;do it all in both v18 and v19 and make sure all results are the same.
;all of these cases matter a lot, but some in quite subtle ways.
*/
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.