comparison src/event-stream.c @ 428:3ecd8885ac67 r21-2-22

Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children a5df635868b2
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 /* The portable interface to event streams.
2 Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Board of Trustees, University of Illinois.
4 Copyright (C) 1995 Sun Microsystems, Inc.
5 Copyright (C) 1995, 1996 Ben Wing.
6
7 This file is part of XEmacs.
8
9 XEmacs is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 2, or (at your option) any
12 later version.
13
14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with XEmacs; see the file COPYING. If not, write to
21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 Boston, MA 02111-1307, USA. */
23
24 /* Synched up with: Not in FSF. */
25
26 /* This file has been Mule-ized. */
27
28 /*
29 * DANGER!!
30 *
31 * If you ever change ANYTHING in this file, you MUST run the
32 * testcases at the end to make sure that you haven't changed
33 * the semantics of recent-keys, last-input-char, or keyboard
34 * macros. You'd be surprised how easy it is to break this.
35 *
36 */
37
38 /* TODO:
39 This stuff is way too hard to maintain - needs rework.
40
41 (global-set-key "\C-p" global-map) causes a crash - need recursion check.
42
43 C-x @ h <scrollbar-drag> x causes a crash.
44
45 The command builder should deal only with key and button events.
46 Other command events should be able to come in the MIDDLE of a key
47 sequence, without disturbing the key sequence composition, or the
48 command builder structure representing it.
49
50 Someone should rethink universal-argument and figure out how an
51 arbitrary command can influence the next command (universal-argument
52 or universal-coding-system-argument) or the next key (hyperify).
53
54 Both C-h and Help in the middle of a key sequence should trigger
55 prefix-help-command. help-char is stupid. Maybe we need
56 keymap-of-last-resort?
57
58 After prefix-help is run, one should be able to CONTINUE TYPING,
59 instead of RETYPING, the key sequence.
60 */
61
62 #include <config.h>
63 #include "lisp.h"
64
65 #ifdef HAVE_X_WINDOWS
66 #include "console-x.h" /* for menu accelerators ... */
67 #include "gui-x.h"
68 #include "../lwlib/lwlib.h"
69 #else
70 #define lw_menu_active 0
71 #endif
72
73 #include "blocktype.h"
74 #include "buffer.h"
75 #include "commands.h"
76 #include "device.h"
77 #include "elhash.h"
78 #include "events.h"
79 #include "frame.h"
80 #include "insdel.h" /* for buffer_reset_changes */
81 #include "keymap.h"
82 #include "lstream.h"
83 #include "macros.h" /* for defining_keyboard_macro */
84 #include "process.h"
85 #include "window.h"
86
87 #include "sysdep.h" /* init_poll_for_quit() */
88 #include "syssignal.h" /* SIGCHLD, etc. */
89 #include "sysfile.h"
90 #include "systime.h" /* to set Vlast_input_time */
91
92 #include "events-mod.h"
93 #ifdef FILE_CODING
94 #include "file-coding.h"
95 #endif
96
97 #include <errno.h>
98
99 /* The number of keystrokes between auto-saves. */
100 static int auto_save_interval;
101
102 Lisp_Object Qundefined_keystroke_sequence;
103
104 Lisp_Object Qcommand_event_p;
105
106 /* Hooks to run before and after each command. */
107 Lisp_Object Vpre_command_hook, Vpost_command_hook;
108 Lisp_Object Qpre_command_hook, Qpost_command_hook;
109
110 /* Hook run when XEmacs is about to be idle. */
111 Lisp_Object Qpre_idle_hook, Vpre_idle_hook;
112
113 /* Control gratuitous keyboard focus throwing. */
114 int focus_follows_mouse;
115
116 #ifdef ILL_CONCEIVED_HOOK
117 /* Hook run after a command if there's no more input soon. */
118 Lisp_Object Qpost_command_idle_hook, Vpost_command_idle_hook;
119
120 /* Delay time in microseconds before running post-command-idle-hook. */
121 int post_command_idle_delay;
122 #endif /* ILL_CONCEIVED_HOOK */
123
124 #ifdef DEFERRED_ACTION_CRAP
125 /* List of deferred actions to be performed at a later time.
126 The precise format isn't relevant here; we just check whether it is nil. */
127 Lisp_Object Vdeferred_action_list;
128
129 /* Function to call to handle deferred actions, when there are any. */
130 Lisp_Object Vdeferred_action_function;
131 Lisp_Object Qdeferred_action_function;
132 #endif /* DEFERRED_ACTION_CRAP */
133
134 /* Non-nil disable property on a command means
135 do not execute it; call disabled-command-hook's value instead. */
136 Lisp_Object Qdisabled, Vdisabled_command_hook;
137
138 EXFUN (Fnext_command_event, 2);
139
140 static void pre_command_hook (void);
141 static void post_command_hook (void);
142
143 /* Last keyboard or mouse input event read as a command. */
144 Lisp_Object Vlast_command_event;
145
146 /* The nearest ASCII equivalent of the above. */
147 Lisp_Object Vlast_command_char;
148
149 /* Last keyboard or mouse event read for any purpose. */
150 Lisp_Object Vlast_input_event;
151
152 /* The nearest ASCII equivalent of the above. */
153 Lisp_Object Vlast_input_char;
154
155 Lisp_Object Vcurrent_mouse_event;
156
157 /* This is fbound in cmdloop.el, see the commentary there */
158 Lisp_Object Qcancel_mode_internal;
159
160 /* If not Qnil, event objects to be read as the next command input */
161 Lisp_Object Vunread_command_events;
162 Lisp_Object Vunread_command_event; /* obsoleteness support */
163
164 static Lisp_Object Qunread_command_events, Qunread_command_event;
165
166 /* Previous command, represented by a Lisp object.
167 Does not include prefix commands and arg setting commands */
168 Lisp_Object Vlast_command;
169
170 /* If a command sets this, the value goes into
171 previous-command for the next command. */
172 Lisp_Object Vthis_command;
173
174 /* The value of point when the last command was executed. */
175 Bufpos last_point_position;
176
177 /* The frame that was current when the last command was started. */
178 Lisp_Object Vlast_selected_frame;
179
180 /* The buffer that was current when the last command was started. */
181 Lisp_Object last_point_position_buffer;
182
183 /* A (16bit . 16bit) representation of the time of the last-command-event. */
184 Lisp_Object Vlast_input_time;
185
186 /* A (16bit 16bit usec) representation of the time
187 of the last-command-event. */
188 Lisp_Object Vlast_command_event_time;
189
190 /* Character to recognize as the help char. */
191 Lisp_Object Vhelp_char;
192
193 /* Form to execute when help char is typed. */
194 Lisp_Object Vhelp_form;
195
196 /* Command to run when the help character follows a prefix key. */
197 Lisp_Object Vprefix_help_command;
198
199 /* Flag to tell QUIT that some interesting occurrence (e.g. a keypress)
200 may have happened. */
201 volatile int something_happened;
202
203 /* Hash table to translate keysyms through */
204 Lisp_Object Vkeyboard_translate_table;
205
206 /* If control-meta-super-shift-X is undefined, try control-meta-super-x */
207 Lisp_Object Vretry_undefined_key_binding_unshifted;
208 Lisp_Object Qretry_undefined_key_binding_unshifted;
209
210 #ifdef HAVE_XIM
211 /* If composed input is undefined, use self-insert-char */
212 Lisp_Object Vcomposed_character_default_binding;
213 #endif /* HAVE_XIM */
214
215 /* Console that corresponds to our controlling terminal */
216 Lisp_Object Vcontrolling_terminal;
217
218 /* An event (actually an event chain linked through event_next) or Qnil.
219 */
220 Lisp_Object Vthis_command_keys;
221 Lisp_Object Vthis_command_keys_tail;
222
223 /* #### kludge! */
224 Lisp_Object Qauto_show_make_point_visible;
225
226 /* File in which we write all commands we read; an lstream */
227 static Lisp_Object Vdribble_file;
228
229 /* Recent keys ring location; a vector of events or nil-s */
230 Lisp_Object Vrecent_keys_ring;
231 int recent_keys_ring_size;
232 int recent_keys_ring_index;
233
234 /* Boolean specifying whether keystrokes should be added to
235 recent-keys. */
236 int inhibit_input_event_recording;
237
238 /* prefix key(s) that must match in order to activate menu.
239 This is ugly. fix me.
240 */
241 Lisp_Object Vmenu_accelerator_prefix;
242
243 /* list of modifier keys to match accelerator for top level menus */
244 Lisp_Object Vmenu_accelerator_modifiers;
245
246 /* whether menu accelerators are enabled */
247 Lisp_Object Vmenu_accelerator_enabled;
248
249 /* keymap for auxiliary menu accelerator functions */
250 Lisp_Object Vmenu_accelerator_map;
251
252 Lisp_Object Qmenu_force;
253 Lisp_Object Qmenu_fallback;
254 Lisp_Object Qmenu_quit;
255 Lisp_Object Qmenu_up;
256 Lisp_Object Qmenu_down;
257 Lisp_Object Qmenu_left;
258 Lisp_Object Qmenu_right;
259 Lisp_Object Qmenu_select;
260 Lisp_Object Qmenu_escape;
261
262 /* this is in keymap.c */
263 extern Lisp_Object Fmake_keymap (Lisp_Object name);
264
265 #ifdef DEBUG_XEMACS
266 int debug_emacs_events;
267
268 static void
269 external_debugging_print_event (char *event_description, Lisp_Object event)
270 {
271 write_c_string ("(", Qexternal_debugging_output);
272 write_c_string (event_description, Qexternal_debugging_output);
273 write_c_string (") ", Qexternal_debugging_output);
274 print_internal (event, Qexternal_debugging_output, 1);
275 write_c_string ("\n", Qexternal_debugging_output);
276 }
277 #define DEBUG_PRINT_EMACS_EVENT(event_description, event) do { \
278 if (debug_emacs_events) \
279 external_debugging_print_event (event_description, event); \
280 } while (0)
281 #else
282 #define DEBUG_PRINT_EMACS_EVENT(string, event)
283 #endif
284
285
286 /* The callback routines for the window system or terminal driver */
287 struct event_stream *event_stream;
288
289 /* This structure is what we use to encapsulate the state of a command sequence
290 being composed; key events are executed by adding themselves to the command
291 builder; if the command builder is then complete (does not still represent
292 a prefix key sequence) it executes the corresponding command.
293 */
294 struct command_builder
295 {
296 struct lcrecord_header header;
297 Lisp_Object console; /* back pointer to the console this command
298 builder is for */
299 /* Qnil, or a Lisp_Event representing the first event read
300 * after the last command completed. Threaded. */
301 /* #### NYI */
302 Lisp_Object prefix_events;
303 /* Qnil, or a Lisp_Event representing event in the current
304 * keymap-lookup sequence. Subsequent events are threaded via
305 * the event's next slot */
306 Lisp_Object current_events;
307 /* Last elt of above */
308 Lisp_Object most_current_event;
309 /* Last elt before function map code took over. What this means is:
310 All prefixes up to (but not including) this event have non-nil
311 bindings, but the prefix including this event has a nil binding.
312 Any events in the chain after this one were read solely because
313 we're part of a possible function key. If we end up with
314 something that's not part of a possible function key, we have to
315 unread all of those events. */
316 Lisp_Object last_non_munged_event;
317 /* One set of values for function-key-map, one for key-translation-map */
318 struct munging_key_translation
319 {
320 /* First event that can begin a possible function key sequence
321 (to be translated according to function-key-map). Normally
322 this is the first event in the chain. However, once we've
323 translated a sequence through function-key-map, this will point
324 to the first event after the translated sequence: we don't ever
325 want to translate any events twice through function-key-map, or
326 things could get really screwed up (e.g. if the user created a
327 translation loop). If this is nil, then the next-read event is
328 the first that can begin a function key sequence. */
329 Lisp_Object first_mungeable_event;
330 } munge_me[2];
331
332 Bufbyte *echo_buf;
333 Bytecount echo_buf_length; /* size of echo_buf */
334 Bytecount echo_buf_index; /* index into echo_buf
335 * -1 before doing echoing for new cmd */
336 /* Self-insert-command is magic in that it doesn't always push an undo-
337 boundary: up to 20 consecutive self-inserts can happen before an undo-
338 boundary is pushed. This variable is that counter.
339 */
340 int self_insert_countdown;
341 };
342
343 static void echo_key_event (struct command_builder *, Lisp_Object event);
344 static void maybe_kbd_translate (Lisp_Object event);
345
346 /* This structure is basically a typeahead queue: things like
347 wait-reading-process-output will delay the execution of
348 keyboard and mouse events by pushing them here.
349
350 Chained through event_next()
351 command_event_queue_tail is a pointer to the last-added element.
352 */
353 static Lisp_Object command_event_queue;
354 static Lisp_Object command_event_queue_tail;
355
356 /* Nonzero means echo unfinished commands after this many seconds of pause. */
357 static Lisp_Object Vecho_keystrokes;
358
359 /* The number of keystrokes since the last auto-save. */
360 static int keystrokes_since_auto_save;
361
362 /* Used by the C-g signal handler so that it will never "hard quit"
363 when waiting for an event. Otherwise holding down C-g could
364 cause a suspension back to the shell, which is generally
365 undesirable. (#### This doesn't fully work.) */
366
367 int emacs_is_blocking;
368
369 /* Handlers which run during sit-for, sleep-for and accept-process-output
370 are not allowed to recursively call these routines. We record here
371 if we are in that situation. */
372
373 static Lisp_Object recursive_sit_for;
374
375
376
377 /**********************************************************************/
378 /* Command-builder object */
379 /**********************************************************************/
380
381 #define XCOMMAND_BUILDER(x) \
382 XRECORD (x, command_builder, struct command_builder)
383 #define XSETCOMMAND_BUILDER(x, p) XSETRECORD (x, p, command_builder)
384 #define COMMAND_BUILDERP(x) RECORDP (x, command_builder)
385 #define GC_COMMAND_BUILDERP(x) GC_RECORDP (x, command_builder)
386 #define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder)
387
388 static Lisp_Object
389 mark_command_builder (Lisp_Object obj)
390 {
391 struct command_builder *builder = XCOMMAND_BUILDER (obj);
392 mark_object (builder->prefix_events);
393 mark_object (builder->current_events);
394 mark_object (builder->most_current_event);
395 mark_object (builder->last_non_munged_event);
396 mark_object (builder->munge_me[0].first_mungeable_event);
397 mark_object (builder->munge_me[1].first_mungeable_event);
398 return builder->console;
399 }
400
401 static void
402 finalize_command_builder (void *header, int for_disksave)
403 {
404 if (!for_disksave)
405 {
406 xfree (((struct command_builder *) header)->echo_buf);
407 ((struct command_builder *) header)->echo_buf = 0;
408 }
409 }
410
411 DEFINE_LRECORD_IMPLEMENTATION ("command-builder", command_builder,
412 mark_command_builder, internal_object_printer,
413 finalize_command_builder, 0, 0, 0,
414 struct command_builder);
415
416 static void
417 reset_command_builder_event_chain (struct command_builder *builder)
418 {
419 builder->prefix_events = Qnil;
420 builder->current_events = Qnil;
421 builder->most_current_event = Qnil;
422 builder->last_non_munged_event = Qnil;
423 builder->munge_me[0].first_mungeable_event = Qnil;
424 builder->munge_me[1].first_mungeable_event = Qnil;
425 }
426
427 Lisp_Object
428 allocate_command_builder (Lisp_Object console)
429 {
430 Lisp_Object builder_obj;
431 struct command_builder *builder =
432 alloc_lcrecord_type (struct command_builder, &lrecord_command_builder);
433
434 builder->console = console;
435 reset_command_builder_event_chain (builder);
436 builder->echo_buf_length = 300; /* #### Kludge */
437 builder->echo_buf = xnew_array (Bufbyte, builder->echo_buf_length);
438 builder->echo_buf[0] = 0;
439 builder->echo_buf_index = -1;
440 builder->echo_buf_index = -1;
441 builder->self_insert_countdown = 0;
442
443 XSETCOMMAND_BUILDER (builder_obj, builder);
444 return builder_obj;
445 }
446
447 static void
448 command_builder_append_event (struct command_builder *builder,
449 Lisp_Object event)
450 {
451 assert (EVENTP (event));
452
453 if (EVENTP (builder->most_current_event))
454 XSET_EVENT_NEXT (builder->most_current_event, event);
455 else
456 builder->current_events = event;
457
458 builder->most_current_event = event;
459 if (NILP (builder->munge_me[0].first_mungeable_event))
460 builder->munge_me[0].first_mungeable_event = event;
461 if (NILP (builder->munge_me[1].first_mungeable_event))
462 builder->munge_me[1].first_mungeable_event = event;
463 }
464
465
466 /**********************************************************************/
467 /* Low-level interfaces onto event methods */
468 /**********************************************************************/
469
470 enum event_stream_operation
471 {
472 EVENT_STREAM_PROCESS,
473 EVENT_STREAM_TIMEOUT,
474 EVENT_STREAM_CONSOLE,
475 EVENT_STREAM_READ
476 };
477
478 static void
479 check_event_stream_ok (enum event_stream_operation op)
480 {
481 if (!event_stream && noninteractive)
482 {
483 switch (op)
484 {
485 case EVENT_STREAM_PROCESS:
486 error ("Can't start subprocesses in -batch mode");
487 case EVENT_STREAM_TIMEOUT:
488 error ("Can't add timeouts in -batch mode");
489 case EVENT_STREAM_CONSOLE:
490 error ("Can't add consoles in -batch mode");
491 case EVENT_STREAM_READ:
492 error ("Can't read events in -batch mode");
493 default:
494 abort ();
495 }
496 }
497 else if (!event_stream)
498 {
499 error ("event-stream callbacks not initialized (internal error?)");
500 }
501 }
502
503 static int
504 event_stream_event_pending_p (int user)
505 {
506 return event_stream && event_stream->event_pending_p (user);
507 }
508
509 static int
510 maybe_read_quit_event (struct Lisp_Event *event)
511 {
512 /* A C-g that came from `sigint_happened' will always come from the
513 controlling terminal. If that doesn't exist, however, then the
514 user manually sent us a SIGINT, and we pretend the C-g came from
515 the selected console. */
516 struct console *con;
517
518 if (CONSOLEP (Vcontrolling_terminal) &&
519 CONSOLE_LIVE_P (XCONSOLE (Vcontrolling_terminal)))
520 con = XCONSOLE (Vcontrolling_terminal);
521 else
522 con = XCONSOLE (Fselected_console ());
523
524 if (sigint_happened)
525 {
526 int ch = CONSOLE_QUIT_CHAR (con);
527 sigint_happened = 0;
528 Vquit_flag = Qnil;
529 character_to_event (ch, event, con, 1, 1);
530 event->channel = make_console (con);
531 return 1;
532 }
533 return 0;
534 }
535
536 void
537 event_stream_next_event (struct Lisp_Event *event)
538 {
539 Lisp_Object event_obj;
540
541 check_event_stream_ok (EVENT_STREAM_READ);
542
543 XSETEVENT (event_obj, event);
544 zero_event (event);
545 /* If C-g was pressed, treat it as a character to be read.
546 Note that if C-g was pressed while we were blocking,
547 the SIGINT signal handler will be called. It will
548 set Vquit_flag and write a byte on our "fake pipe",
549 which will unblock us. */
550 if (maybe_read_quit_event (event))
551 {
552 DEBUG_PRINT_EMACS_EVENT ("SIGINT", event_obj);
553 return;
554 }
555
556 /* If a longjmp() happens in the callback, we're screwed.
557 Let's hope it doesn't. I think the code here is fairly
558 clean and doesn't do this. */
559 emacs_is_blocking = 1;
560 #if 0
561 /* Do this if the poll-for-quit timer seems to be taking too
562 much CPU time when idle ... */
563 reset_poll_for_quit ();
564 #endif
565 event_stream->next_event_cb (event);
566 #if 0
567 init_poll_for_quit ();
568 #endif
569 emacs_is_blocking = 0;
570
571 #ifdef DEBUG_XEMACS
572 /* timeout events have more info set later, so
573 print the event out in next_event_internal(). */
574 if (event->event_type != timeout_event)
575 DEBUG_PRINT_EMACS_EVENT ("real", event_obj);
576 #endif
577 maybe_kbd_translate (event_obj);
578 }
579
580 void
581 event_stream_handle_magic_event (struct Lisp_Event *event)
582 {
583 check_event_stream_ok (EVENT_STREAM_READ);
584 event_stream->handle_magic_event_cb (event);
585 }
586
587 static int
588 event_stream_add_timeout (EMACS_TIME timeout)
589 {
590 check_event_stream_ok (EVENT_STREAM_TIMEOUT);
591 return event_stream->add_timeout_cb (timeout);
592 }
593
594 static void
595 event_stream_remove_timeout (int id)
596 {
597 check_event_stream_ok (EVENT_STREAM_TIMEOUT);
598 event_stream->remove_timeout_cb (id);
599 }
600
601 void
602 event_stream_select_console (struct console *con)
603 {
604 check_event_stream_ok (EVENT_STREAM_CONSOLE);
605 if (!con->input_enabled)
606 {
607 event_stream->select_console_cb (con);
608 con->input_enabled = 1;
609 }
610 }
611
612 void
613 event_stream_unselect_console (struct console *con)
614 {
615 check_event_stream_ok (EVENT_STREAM_CONSOLE);
616 if (con->input_enabled)
617 {
618 event_stream->unselect_console_cb (con);
619 con->input_enabled = 0;
620 }
621 }
622
623 void
624 event_stream_select_process (struct Lisp_Process *proc)
625 {
626 check_event_stream_ok (EVENT_STREAM_PROCESS);
627 if (!get_process_selected_p (proc))
628 {
629 event_stream->select_process_cb (proc);
630 set_process_selected_p (proc, 1);
631 }
632 }
633
634 void
635 event_stream_unselect_process (struct Lisp_Process *proc)
636 {
637 check_event_stream_ok (EVENT_STREAM_PROCESS);
638 if (get_process_selected_p (proc))
639 {
640 event_stream->unselect_process_cb (proc);
641 set_process_selected_p (proc, 0);
642 }
643 }
644
645 USID
646 event_stream_create_stream_pair (void* inhandle, void* outhandle,
647 Lisp_Object* instream, Lisp_Object* outstream, int flags)
648 {
649 check_event_stream_ok (EVENT_STREAM_PROCESS);
650 return event_stream->create_stream_pair_cb
651 (inhandle, outhandle, instream, outstream, flags);
652 }
653
654 USID
655 event_stream_delete_stream_pair (Lisp_Object instream, Lisp_Object outstream)
656 {
657 check_event_stream_ok (EVENT_STREAM_PROCESS);
658 return event_stream->delete_stream_pair_cb (instream, outstream);
659 }
660
661 void
662 event_stream_quit_p (void)
663 {
664 if (event_stream)
665 event_stream->quit_p_cb ();
666 }
667
668
669
670 /**********************************************************************/
671 /* Character prompting */
672 /**********************************************************************/
673
674 static void
675 echo_key_event (struct command_builder *command_builder,
676 Lisp_Object event)
677 {
678 /* This function can GC */
679 char buf[255];
680 Bytecount buf_index = command_builder->echo_buf_index;
681 Bufbyte *e;
682 Bytecount len;
683
684 if (buf_index < 0)
685 {
686 buf_index = 0; /* We're echoing now */
687 clear_echo_area (selected_frame (), Qnil, 0);
688 }
689
690 format_event_object (buf, XEVENT (event), 1);
691 len = strlen (buf);
692
693 if (len + buf_index + 4 > command_builder->echo_buf_length)
694 return;
695 e = command_builder->echo_buf + buf_index;
696 memcpy (e, buf, len);
697 e += len;
698
699 e[0] = ' ';
700 e[1] = '-';
701 e[2] = ' ';
702 e[3] = 0;
703
704 command_builder->echo_buf_index = buf_index + len + 1;
705 }
706
707 static void
708 regenerate_echo_keys_from_this_command_keys (struct command_builder *
709 builder)
710 {
711 Lisp_Object event;
712
713 builder->echo_buf_index = 0;
714
715 EVENT_CHAIN_LOOP (event, Vthis_command_keys)
716 echo_key_event (builder, event);
717 }
718
719 static void
720 maybe_echo_keys (struct command_builder *command_builder, int no_snooze)
721 {
722 /* This function can GC */
723 double echo_keystrokes;
724 struct frame *f = selected_frame ();
725 /* Message turns off echoing unless more keystrokes turn it on again. */
726 if (echo_area_active (f) && !EQ (Qcommand, echo_area_status (f)))
727 return;
728
729 if (INTP (Vecho_keystrokes) || FLOATP (Vecho_keystrokes))
730 echo_keystrokes = extract_float (Vecho_keystrokes);
731 else
732 echo_keystrokes = 0;
733
734 if (minibuf_level == 0
735 && echo_keystrokes > 0.0
736 && !lw_menu_active)
737 {
738 if (!no_snooze)
739 {
740 /* #### C-g here will cause QUIT. Setting dont_check_for_quit
741 doesn't work. See check_quit. */
742 if (NILP (Fsit_for (Vecho_keystrokes, Qnil)))
743 /* input came in, so don't echo. */
744 return;
745 }
746
747 echo_area_message (f, command_builder->echo_buf, Qnil, 0,
748 /* not echo_buf_index. That doesn't include
749 the terminating " - ". */
750 strlen ((char *) command_builder->echo_buf),
751 Qcommand);
752 }
753 }
754
755 static void
756 reset_key_echo (struct command_builder *command_builder,
757 int remove_echo_area_echo)
758 {
759 /* This function can GC */
760 struct frame *f = selected_frame ();
761
762 command_builder->echo_buf_index = -1;
763
764 if (remove_echo_area_echo)
765 clear_echo_area (f, Qcommand, 0);
766 }
767
768
769 /**********************************************************************/
770 /* random junk */
771 /**********************************************************************/
772
773 static void
774 maybe_kbd_translate (Lisp_Object event)
775 {
776 Emchar c;
777 int did_translate = 0;
778
779 if (XEVENT_TYPE (event) != key_press_event)
780 return;
781 if (!HASH_TABLEP (Vkeyboard_translate_table))
782 return;
783 if (EQ (Fhash_table_count (Vkeyboard_translate_table), Qzero))
784 return;
785
786 c = event_to_character (XEVENT (event), 0, 0, 0);
787 if (c != -1)
788 {
789 Lisp_Object traduit = Fgethash (make_char (c), Vkeyboard_translate_table,
790 Qnil);
791 if (!NILP (traduit) && SYMBOLP (traduit))
792 {
793 XEVENT (event)->event.key.keysym = traduit;
794 XEVENT (event)->event.key.modifiers = 0;
795 did_translate = 1;
796 }
797 else if (CHARP (traduit))
798 {
799 struct Lisp_Event ev2;
800
801 /* This used to call Fcharacter_to_event() directly into EVENT,
802 but that can eradicate timestamps and other such stuff.
803 This way is safer. */
804 zero_event (&ev2);
805 character_to_event (XCHAR (traduit), &ev2,
806 XCONSOLE (EVENT_CHANNEL (XEVENT (event))), 1, 1);
807 XEVENT (event)->event.key.keysym = ev2.event.key.keysym;
808 XEVENT (event)->event.key.modifiers = ev2.event.key.modifiers;
809 did_translate = 1;
810 }
811 }
812
813 if (!did_translate)
814 {
815 Lisp_Object traduit = Fgethash (XEVENT (event)->event.key.keysym,
816 Vkeyboard_translate_table, Qnil);
817 if (!NILP (traduit) && SYMBOLP (traduit))
818 {
819 XEVENT (event)->event.key.keysym = traduit;
820 did_translate = 1;
821 }
822 }
823
824 #ifdef DEBUG_XEMACS
825 if (did_translate)
826 DEBUG_PRINT_EMACS_EVENT ("->keyboard-translate-table", event);
827 #endif
828 }
829
830 /* NB: The following auto-save stuff is in keyboard.c in FSFmacs, and
831 keystrokes_since_auto_save is equivalent to the difference between
832 num_nonmacro_input_chars and last_auto_save. */
833
834 /* When an auto-save happens, record the "time", and don't do again soon. */
835
836 void
837 record_auto_save (void)
838 {
839 keystrokes_since_auto_save = 0;
840 }
841
842 /* Make an auto save happen as soon as possible at command level. */
843
844 void
845 force_auto_save_soon (void)
846 {
847 keystrokes_since_auto_save = 1 + max (auto_save_interval, 20);
848
849 #if 0 /* FSFmacs */
850 record_asynch_buffer_change ();
851 #endif
852 }
853
854 static void
855 maybe_do_auto_save (void)
856 {
857 /* This function can call lisp */
858 keystrokes_since_auto_save++;
859 if (auto_save_interval > 0 &&
860 keystrokes_since_auto_save > max (auto_save_interval, 20) &&
861 !detect_input_pending ())
862 {
863 Fdo_auto_save (Qnil, Qnil);
864 record_auto_save ();
865 }
866 }
867
868 static Lisp_Object
869 print_help (Lisp_Object object)
870 {
871 Fprinc (object, Qnil);
872 return Qnil;
873 }
874
875 static void
876 execute_help_form (struct command_builder *command_builder,
877 Lisp_Object event)
878 {
879 /* This function can GC */
880 Lisp_Object help = Qnil;
881 int speccount = specpdl_depth ();
882 Bytecount buf_index = command_builder->echo_buf_index;
883 Lisp_Object echo = ((buf_index <= 0)
884 ? Qnil
885 : make_string (command_builder->echo_buf,
886 buf_index));
887 struct gcpro gcpro1, gcpro2;
888 GCPRO2 (echo, help);
889
890 record_unwind_protect (save_window_excursion_unwind,
891 Fcurrent_window_configuration (Qnil));
892 reset_key_echo (command_builder, 1);
893
894 help = Feval (Vhelp_form);
895 if (STRINGP (help))
896 internal_with_output_to_temp_buffer (build_string ("*Help*"),
897 print_help, help, Qnil);
898 Fnext_command_event (event, Qnil);
899 /* Remove the help from the frame */
900 unbind_to (speccount, Qnil);
901 /* Hmmmm. Tricky. The unbind restores an old window configuration,
902 apparently bypassing any setting of windows_structure_changed.
903 So we need to set it so that things get redrawn properly. */
904 /* #### This is massive overkill. Look at doing it better once the
905 new redisplay is fully in place. */
906 {
907 Lisp_Object frmcons, devcons, concons;
908 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
909 {
910 struct frame *f = XFRAME (XCAR (frmcons));
911 MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f);
912 }
913 }
914
915 redisplay ();
916 if (event_matches_key_specifier_p (XEVENT (event), make_char (' ')))
917 {
918 /* Discard next key if it is a space */
919 reset_key_echo (command_builder, 1);
920 Fnext_command_event (event, Qnil);
921 }
922
923 command_builder->echo_buf_index = buf_index;
924 if (buf_index > 0)
925 memcpy (command_builder->echo_buf,
926 XSTRING_DATA (echo), buf_index + 1); /* terminating 0 */
927 UNGCPRO;
928 }
929
930
931 /**********************************************************************/
932 /* input pending */
933 /**********************************************************************/
934
935 int
936 detect_input_pending (void)
937 {
938 /* Always call the event_pending_p hook even if there's an unread
939 character, because that might do some needed ^G detection (on
940 systems without SIGIO, for example).
941 */
942 if (event_stream_event_pending_p (1))
943 return 1;
944 if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event))
945 return 1;
946 if (!NILP (command_event_queue))
947 {
948 Lisp_Object event;
949
950 EVENT_CHAIN_LOOP (event, command_event_queue)
951 {
952 if (XEVENT_TYPE (event) != eval_event
953 && XEVENT_TYPE (event) != magic_eval_event)
954 return 1;
955 }
956 }
957 return 0;
958 }
959
960 DEFUN ("input-pending-p", Finput_pending_p, 0, 0, 0, /*
961 Return t if command input is currently available with no waiting.
962 Actually, the value is nil only if we can be sure that no input is available.
963 */
964 ())
965 {
966 return detect_input_pending () ? Qt : Qnil;
967 }
968
969
970 /**********************************************************************/
971 /* timeouts */
972 /**********************************************************************/
973
974 /**** Low-level timeout functions. ****
975
976 These functions maintain a sorted list of one-shot timeouts (where
977 the timeouts are in absolute time). They are intended for use by
978 functions that need to convert a list of absolute timeouts into a
979 series of intervals to wait for. */
980
981 /* We ensure that 0 is never a valid ID, so that a value of 0 can be
982 used to indicate an absence of a timer. */
983 static int low_level_timeout_id_tick;
984
985 static struct low_level_timeout_blocktype
986 {
987 Blocktype_declare (struct low_level_timeout);
988 } *the_low_level_timeout_blocktype;
989
990 /* Add a one-shot timeout at time TIME to TIMEOUT_LIST. Return
991 a unique ID identifying the timeout. */
992
993 int
994 add_low_level_timeout (struct low_level_timeout **timeout_list,
995 EMACS_TIME thyme)
996 {
997 struct low_level_timeout *tm;
998 struct low_level_timeout *t, **tt;
999
1000 /* Allocate a new time struct. */
1001
1002 tm = Blocktype_alloc (the_low_level_timeout_blocktype);
1003 tm->next = NULL;
1004 if (low_level_timeout_id_tick == 0)
1005 low_level_timeout_id_tick++;
1006 tm->id = low_level_timeout_id_tick++;
1007 tm->time = thyme;
1008
1009 /* Add it to the queue. */
1010
1011 tt = timeout_list;
1012 t = *tt;
1013 while (t && EMACS_TIME_EQUAL_OR_GREATER (tm->time, t->time))
1014 {
1015 tt = &t->next;
1016 t = *tt;
1017 }
1018 tm->next = t;
1019 *tt = tm;
1020
1021 return tm->id;
1022 }
1023
1024 /* Remove the low-level timeout identified by ID from TIMEOUT_LIST.
1025 If the timeout is not there, do nothing. */
1026
1027 void
1028 remove_low_level_timeout (struct low_level_timeout **timeout_list, int id)
1029 {
1030 struct low_level_timeout *t, *prev;
1031
1032 /* find it */
1033
1034 for (t = *timeout_list, prev = NULL; t && t->id != id; t = t->next)
1035 prev = t;
1036
1037 if (!t)
1038 return; /* couldn't find it */
1039
1040 if (!prev)
1041 *timeout_list = t->next;
1042 else prev->next = t->next;
1043
1044 Blocktype_free (the_low_level_timeout_blocktype, t);
1045 }
1046
1047 /* If there are timeouts on TIMEOUT_LIST, store the relative time
1048 interval to the first timeout on the list into INTERVAL and
1049 return 1. Otherwise, return 0. */
1050
1051 int
1052 get_low_level_timeout_interval (struct low_level_timeout *timeout_list,
1053 EMACS_TIME *interval)
1054 {
1055 if (!timeout_list) /* no timer events; block indefinitely */
1056 return 0;
1057 else
1058 {
1059 EMACS_TIME current_time;
1060
1061 /* The time to block is the difference between the first
1062 (earliest) timer on the queue and the current time.
1063 If that is negative, then the timer will fire immediately
1064 but we still have to call select(), with a zero-valued
1065 timeout: user events must have precedence over timer events. */
1066 EMACS_GET_TIME (current_time);
1067 if (EMACS_TIME_GREATER (timeout_list->time, current_time))
1068 EMACS_SUB_TIME (*interval, timeout_list->time,
1069 current_time);
1070 else
1071 EMACS_SET_SECS_USECS (*interval, 0, 0);
1072 return 1;
1073 }
1074 }
1075
1076 /* Pop the first (i.e. soonest) timeout off of TIMEOUT_LIST and return
1077 its ID. Also, if TIME_OUT is not 0, store the absolute time of the
1078 timeout into TIME_OUT. */
1079
1080 int
1081 pop_low_level_timeout (struct low_level_timeout **timeout_list,
1082 EMACS_TIME *time_out)
1083 {
1084 struct low_level_timeout *tm = *timeout_list;
1085 int id;
1086
1087 assert (tm);
1088 id = tm->id;
1089 if (time_out)
1090 *time_out = tm->time;
1091 *timeout_list = tm->next;
1092 Blocktype_free (the_low_level_timeout_blocktype, tm);
1093 return id;
1094 }
1095
1096
1097 /**** High-level timeout functions. ****/
1098
1099 static int timeout_id_tick;
1100
1101 static Lisp_Object pending_timeout_list, pending_async_timeout_list;
1102
1103 static Lisp_Object Vtimeout_free_list;
1104
1105 static Lisp_Object
1106 mark_timeout (Lisp_Object obj)
1107 {
1108 struct Lisp_Timeout *tm = XTIMEOUT (obj);
1109 mark_object (tm->function);
1110 return tm->object;
1111 }
1112
1113 /* Should never, ever be called. (except by an external debugger) */
1114 static void
1115 print_timeout (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1116 {
1117 CONST struct Lisp_Timeout *t = XTIMEOUT (obj);
1118 char buf[64];
1119
1120 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (timeout) 0x%lx>",
1121 (unsigned long) t);
1122 write_c_string (buf, printcharfun);
1123 }
1124
1125 static const struct lrecord_description timeout_description[] = {
1126 { XD_LISP_OBJECT, offsetof(struct Lisp_Timeout, function), 2 },
1127 { XD_END }
1128 };
1129
1130 DEFINE_LRECORD_IMPLEMENTATION ("timeout", timeout,
1131 mark_timeout, print_timeout,
1132 0, 0, 0, timeout_description, struct Lisp_Timeout);
1133
1134 /* Generate a timeout and return its ID. */
1135
1136 int
1137 event_stream_generate_wakeup (unsigned int milliseconds,
1138 unsigned int vanilliseconds,
1139 Lisp_Object function, Lisp_Object object,
1140 int async_p)
1141 {
1142 Lisp_Object op = allocate_managed_lcrecord (Vtimeout_free_list);
1143 struct Lisp_Timeout *timeout = XTIMEOUT (op);
1144 EMACS_TIME current_time;
1145 EMACS_TIME interval;
1146
1147 timeout->id = timeout_id_tick++;
1148 timeout->resignal_msecs = vanilliseconds;
1149 timeout->function = function;
1150 timeout->object = object;
1151
1152 EMACS_GET_TIME (current_time);
1153 EMACS_SET_SECS_USECS (interval, milliseconds / 1000,
1154 1000 * (milliseconds % 1000));
1155 EMACS_ADD_TIME (timeout->next_signal_time, current_time, interval);
1156
1157 if (async_p)
1158 {
1159 timeout->interval_id =
1160 event_stream_add_async_timeout (timeout->next_signal_time);
1161 pending_async_timeout_list = noseeum_cons (op,
1162 pending_async_timeout_list);
1163 }
1164 else
1165 {
1166 timeout->interval_id =
1167 event_stream_add_timeout (timeout->next_signal_time);
1168 pending_timeout_list = noseeum_cons (op, pending_timeout_list);
1169 }
1170 return timeout->id;
1171 }
1172
1173 /* Given the INTERVAL-ID of a timeout just signalled, resignal the timeout
1174 as necessary and return the timeout's ID and function and object slots.
1175
1176 This should be called as a result of receiving notice that a timeout
1177 has fired. INTERVAL-ID is *not* the timeout's ID, but is the ID that
1178 identifies this particular firing of the timeout. INTERVAL-ID's and
1179 timeout ID's are in separate number spaces and bear no relation to
1180 each other. The INTERVAL-ID is all that the event callback routines
1181 work with: they work only with one-shot intervals, not with timeouts
1182 that may fire repeatedly.
1183
1184 NOTE: The returned FUNCTION and OBJECT are *not* GC-protected at all.
1185 */
1186
1187 static int
1188 event_stream_resignal_wakeup (int interval_id, int async_p,
1189 Lisp_Object *function, Lisp_Object *object)
1190 {
1191 Lisp_Object op = Qnil, rest;
1192 struct Lisp_Timeout *timeout;
1193 Lisp_Object *timeout_list;
1194 struct gcpro gcpro1;
1195 int id;
1196
1197 GCPRO1 (op); /* just in case ... because it's removed from the list
1198 for awhile. */
1199
1200 timeout_list = async_p ? &pending_async_timeout_list : &pending_timeout_list;
1201
1202 /* Find the timeout on the list of pending ones. */
1203 LIST_LOOP (rest, *timeout_list)
1204 {
1205 timeout = XTIMEOUT (XCAR (rest));
1206 if (timeout->interval_id == interval_id)
1207 break;
1208 }
1209
1210 assert (!NILP (rest));
1211 op = XCAR (rest);
1212 timeout = XTIMEOUT (op);
1213 /* We make sure to snarf the data out of the timeout object before
1214 we free it with free_managed_lcrecord(). */
1215 id = timeout->id;
1216 *function = timeout->function;
1217 *object = timeout->object;
1218
1219 /* Remove this one from the list of pending timeouts */
1220 *timeout_list = delq_no_quit_and_free_cons (op, *timeout_list);
1221
1222 /* If this timeout wants to be resignalled, do it now. */
1223 if (timeout->resignal_msecs)
1224 {
1225 EMACS_TIME current_time;
1226 EMACS_TIME interval;
1227
1228 /* Determine the time that the next resignalling should occur.
1229 We do that by adding the interval time to the last signalled
1230 time until we get a time that's current.
1231
1232 (This way, it doesn't matter if the timeout was signalled
1233 exactly when we asked for it, or at some time later.)
1234 */
1235 EMACS_GET_TIME (current_time);
1236 EMACS_SET_SECS_USECS (interval, timeout->resignal_msecs / 1000,
1237 1000 * (timeout->resignal_msecs % 1000));
1238 do
1239 {
1240 EMACS_ADD_TIME (timeout->next_signal_time, timeout->next_signal_time,
1241 interval);
1242 } while (EMACS_TIME_GREATER (current_time, timeout->next_signal_time));
1243
1244 if (async_p)
1245 timeout->interval_id =
1246 event_stream_add_async_timeout (timeout->next_signal_time);
1247 else
1248 timeout->interval_id =
1249 event_stream_add_timeout (timeout->next_signal_time);
1250 /* Add back onto the list. Note that the effect of this
1251 is to move frequently-hit timeouts to the front of the
1252 list, which is a good thing. */
1253 *timeout_list = noseeum_cons (op, *timeout_list);
1254 }
1255 else
1256 free_managed_lcrecord (Vtimeout_free_list, op);
1257
1258 UNGCPRO;
1259 return id;
1260 }
1261
1262 void
1263 event_stream_disable_wakeup (int id, int async_p)
1264 {
1265 struct Lisp_Timeout *timeout = 0;
1266 Lisp_Object rest;
1267 Lisp_Object *timeout_list;
1268
1269 if (async_p)
1270 timeout_list = &pending_async_timeout_list;
1271 else
1272 timeout_list = &pending_timeout_list;
1273
1274 /* Find the timeout on the list of pending ones, if it's still there. */
1275 LIST_LOOP (rest, *timeout_list)
1276 {
1277 timeout = XTIMEOUT (XCAR (rest));
1278 if (timeout->id == id)
1279 break;
1280 }
1281
1282 /* If we found it, remove it from the list and disable the pending
1283 one-shot. */
1284 if (!NILP (rest))
1285 {
1286 Lisp_Object op = XCAR (rest);
1287 *timeout_list =
1288 delq_no_quit_and_free_cons (op, *timeout_list);
1289 if (async_p)
1290 event_stream_remove_async_timeout (timeout->interval_id);
1291 else
1292 event_stream_remove_timeout (timeout->interval_id);
1293 free_managed_lcrecord (Vtimeout_free_list, op);
1294 }
1295 }
1296
1297 static int
1298 event_stream_wakeup_pending_p (int id, int async_p)
1299 {
1300 struct Lisp_Timeout *timeout;
1301 Lisp_Object rest;
1302 Lisp_Object timeout_list;
1303 int found = 0;
1304
1305
1306 if (async_p)
1307 timeout_list = pending_async_timeout_list;
1308 else
1309 timeout_list = pending_timeout_list;
1310
1311 /* Find the element on the list of pending ones, if it's still there. */
1312 LIST_LOOP (rest, timeout_list)
1313 {
1314 timeout = XTIMEOUT (XCAR (rest));
1315 if (timeout->id == id)
1316 {
1317 found = 1;
1318 break;
1319 }
1320 }
1321
1322 return found;
1323 }
1324
1325
1326 /**** Asynch. timeout functions (see also signal.c) ****/
1327
1328 #if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)
1329 extern int poll_for_quit_id;
1330 #endif
1331
1332 #if defined(HAVE_UNIX_PROCESSES) && !defined(SIGCHLD)
1333 extern int poll_for_sigchld_id;
1334 #endif
1335
1336 void
1337 event_stream_deal_with_async_timeout (int interval_id)
1338 {
1339 /* This function can GC */
1340 Lisp_Object humpty, dumpty;
1341 #if ((!defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)) \
1342 || defined(HAVE_UNIX_PROCESSES) && !defined(SIGCHLD))
1343 int id =
1344 #endif
1345 event_stream_resignal_wakeup (interval_id, 1, &humpty, &dumpty);
1346
1347 #if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)
1348 if (id == poll_for_quit_id)
1349 {
1350 quit_check_signal_happened = 1;
1351 quit_check_signal_tick_count++;
1352 return;
1353 }
1354 #endif
1355
1356 #if defined(HAVE_UNIX_PROCESSES) && !defined(SIGCHLD)
1357 if (id == poll_for_sigchld_id)
1358 {
1359 kick_status_notify ();
1360 return;
1361 }
1362 #endif
1363
1364 /* call1 GC-protects its arguments */
1365 call1_trapping_errors ("Error in asynchronous timeout callback",
1366 humpty, dumpty);
1367 }
1368
1369
1370 /**** Lisp-level timeout functions. ****/
1371
1372 static unsigned long
1373 lisp_number_to_milliseconds (Lisp_Object secs, int allow_0)
1374 {
1375 #ifdef LISP_FLOAT_TYPE
1376 double fsecs;
1377 CHECK_INT_OR_FLOAT (secs);
1378 fsecs = XFLOATINT (secs);
1379 #else
1380 long fsecs;
1381 CHECK_INT (secs);
1382 fsecs = XINT (secs);
1383 #endif
1384 if (fsecs < 0)
1385 signal_simple_error ("timeout is negative", secs);
1386 if (!allow_0 && fsecs == 0)
1387 signal_simple_error ("timeout is non-positive", secs);
1388 if (fsecs >= (((unsigned int) 0xFFFFFFFF) / 1000))
1389 signal_simple_error
1390 ("timeout would exceed 32 bits when represented in milliseconds", secs);
1391
1392 return (unsigned long) (1000 * fsecs);
1393 }
1394
1395 DEFUN ("add-timeout", Fadd_timeout, 3, 4, 0, /*
1396 Add a timeout, to be signaled after the timeout period has elapsed.
1397 SECS is a number of seconds, expressed as an integer or a float.
1398 FUNCTION will be called after that many seconds have elapsed, with one
1399 argument, the given OBJECT. If the optional RESIGNAL argument is provided,
1400 then after this timeout expires, `add-timeout' will automatically be called
1401 again with RESIGNAL as the first argument.
1402
1403 This function returns an object which is the id number of this particular
1404 timeout. You can pass that object to `disable-timeout' to turn off the
1405 timeout before it has been signalled.
1406
1407 NOTE: Id numbers as returned by this function are in a distinct namespace
1408 from those returned by `add-async-timeout'. This means that the same id
1409 number could refer to a pending synchronous timeout and a different pending
1410 asynchronous timeout, and that you cannot pass an id from `add-timeout'
1411 to `disable-async-timeout', or vice-versa.
1412
1413 The number of seconds may be expressed as a floating-point number, in which
1414 case some fractional part of a second will be used. Caveat: the usable
1415 timeout granularity will vary from system to system.
1416
1417 Adding a timeout causes a timeout event to be returned by `next-event', and
1418 the function will be invoked by `dispatch-event,' so if emacs is in a tight
1419 loop, the function will not be invoked until the next call to sit-for or
1420 until the return to top-level (the same is true of process filters).
1421
1422 If you need to have a timeout executed even when XEmacs is in the midst of
1423 running Lisp code, use `add-async-timeout'.
1424
1425 WARNING: if you are thinking of calling add-timeout from inside of a
1426 callback function as a way of resignalling a timeout, think again. There
1427 is a race condition. That's why the RESIGNAL argument exists.
1428 */
1429 (secs, function, object, resignal))
1430 {
1431 unsigned long msecs = lisp_number_to_milliseconds (secs, 0);
1432 unsigned long msecs2 = (NILP (resignal) ? 0 :
1433 lisp_number_to_milliseconds (resignal, 0));
1434 int id;
1435 Lisp_Object lid;
1436 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 0);
1437 lid = make_int (id);
1438 if (id != XINT (lid)) abort ();
1439 return lid;
1440 }
1441
1442 DEFUN ("disable-timeout", Fdisable_timeout, 1, 1, 0, /*
1443 Disable a timeout from signalling any more.
1444 ID should be a timeout id number as returned by `add-timeout'. If ID
1445 corresponds to a one-shot timeout that has already signalled, nothing
1446 will happen.
1447
1448 It will not work to call this function on an id number returned by
1449 `add-async-timeout'. Use `disable-async-timeout' for that.
1450 */
1451 (id))
1452 {
1453 CHECK_INT (id);
1454 event_stream_disable_wakeup (XINT (id), 0);
1455 return Qnil;
1456 }
1457
1458 DEFUN ("add-async-timeout", Fadd_async_timeout, 3, 4, 0, /*
1459 Add an asynchronous timeout, to be signaled after an interval has elapsed.
1460 SECS is a number of seconds, expressed as an integer or a float.
1461 FUNCTION will be called after that many seconds have elapsed, with one
1462 argument, the given OBJECT. If the optional RESIGNAL argument is provided,
1463 then after this timeout expires, `add-async-timeout' will automatically be
1464 called again with RESIGNAL as the first argument.
1465
1466 This function returns an object which is the id number of this particular
1467 timeout. You can pass that object to `disable-async-timeout' to turn off
1468 the timeout before it has been signalled.
1469
1470 NOTE: Id numbers as returned by this function are in a distinct namespace
1471 from those returned by `add-timeout'. This means that the same id number
1472 could refer to a pending synchronous timeout and a different pending
1473 asynchronous timeout, and that you cannot pass an id from
1474 `add-async-timeout' to `disable-timeout', or vice-versa.
1475
1476 The number of seconds may be expressed as a floating-point number, in which
1477 case some fractional part of a second will be used. Caveat: the usable
1478 timeout granularity will vary from system to system.
1479
1480 Adding an asynchronous timeout causes the function to be invoked as soon
1481 as the timeout occurs, even if XEmacs is in the midst of executing some
1482 other code. (This is unlike the synchronous timeouts added with
1483 `add-timeout', where the timeout will only be signalled when XEmacs is
1484 waiting for events, i.e. the next return to top-level or invocation of
1485 `sit-for' or related functions.) This means that the function that is
1486 called *must* not signal an error or change any global state (e.g. switch
1487 buffers or windows) except when locking code is in place to make sure
1488 that race conditions don't occur in the interaction between the
1489 asynchronous timeout function and other code.
1490
1491 Under most circumstances, you should use `add-timeout' instead, as it is
1492 much safer. Asynchronous timeouts should only be used when such behavior
1493 is really necessary.
1494
1495 Asynchronous timeouts are blocked and will not occur when `inhibit-quit'
1496 is non-nil. As soon as `inhibit-quit' becomes nil again, any pending
1497 asynchronous timeouts will get called immediately. (Multiple occurrences
1498 of the same asynchronous timeout are not queued, however.) While the
1499 callback function of an asynchronous timeout is invoked, `inhibit-quit'
1500 is automatically bound to non-nil, and thus other asynchronous timeouts
1501 will be blocked unless the callback function explicitly sets `inhibit-quit'
1502 to nil.
1503
1504 WARNING: if you are thinking of calling `add-async-timeout' from inside of a
1505 callback function as a way of resignalling a timeout, think again. There
1506 is a race condition. That's why the RESIGNAL argument exists.
1507 */
1508 (secs, function, object, resignal))
1509 {
1510 unsigned long msecs = lisp_number_to_milliseconds (secs, 0);
1511 unsigned long msecs2 = (NILP (resignal) ? 0 :
1512 lisp_number_to_milliseconds (resignal, 0));
1513 int id;
1514 Lisp_Object lid;
1515 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 1);
1516 lid = make_int (id);
1517 if (id != XINT (lid)) abort ();
1518 return lid;
1519 }
1520
1521 DEFUN ("disable-async-timeout", Fdisable_async_timeout, 1, 1, 0, /*
1522 Disable an asynchronous timeout from signalling any more.
1523 ID should be a timeout id number as returned by `add-async-timeout'. If ID
1524 corresponds to a one-shot timeout that has already signalled, nothing
1525 will happen.
1526
1527 It will not work to call this function on an id number returned by
1528 `add-timeout'. Use `disable-timeout' for that.
1529 */
1530 (id))
1531 {
1532 CHECK_INT (id);
1533 event_stream_disable_wakeup (XINT (id), 1);
1534 return Qnil;
1535 }
1536
1537
1538 /**********************************************************************/
1539 /* enqueuing and dequeuing events */
1540 /**********************************************************************/
1541
1542 /* Add an event to the back of the command-event queue: it will be the next
1543 event read after all pending events. This only works on keyboard,
1544 mouse-click, misc-user, and eval events.
1545 */
1546 static void
1547 enqueue_command_event (Lisp_Object event)
1548 {
1549 enqueue_event (event, &command_event_queue, &command_event_queue_tail);
1550 }
1551
1552 static Lisp_Object
1553 dequeue_command_event (void)
1554 {
1555 return dequeue_event (&command_event_queue, &command_event_queue_tail);
1556 }
1557
1558 /* put the event on the typeahead queue, unless
1559 the event is the quit char, in which case the `QUIT'
1560 which will occur on the next trip through this loop is
1561 all the processing we should do - leaving it on the queue
1562 would cause the quit to be processed twice.
1563 */
1564 static void
1565 enqueue_command_event_1 (Lisp_Object event_to_copy)
1566 {
1567 /* do not call check_quit() here. Vquit_flag was set in
1568 next_event_internal. */
1569 if (NILP (Vquit_flag))
1570 enqueue_command_event (Fcopy_event (event_to_copy, Qnil));
1571 }
1572
1573 void
1574 enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object)
1575 {
1576 Lisp_Object event = Fmake_event (Qnil, Qnil);
1577
1578 XEVENT (event)->event_type = magic_eval_event;
1579 /* channel for magic_eval events is nil */
1580 XEVENT (event)->event.magic_eval.internal_function = fun;
1581 XEVENT (event)->event.magic_eval.object = object;
1582 enqueue_command_event (event);
1583 }
1584
1585 DEFUN ("enqueue-eval-event", Fenqueue_eval_event, 2, 2, 0, /*
1586 Add an eval event to the back of the eval event queue.
1587 When this event is dispatched, FUNCTION (which should be a function
1588 of one argument) will be called with OBJECT as its argument.
1589 See `next-event' for a description of event types and how events
1590 are received.
1591 */
1592 (function, object))
1593 {
1594 Lisp_Object event = Fmake_event (Qnil, Qnil);
1595
1596 XEVENT (event)->event_type = eval_event;
1597 /* channel for eval events is nil */
1598 XEVENT (event)->event.eval.function = function;
1599 XEVENT (event)->event.eval.object = object;
1600 enqueue_command_event (event);
1601
1602 return event;
1603 }
1604
1605 Lisp_Object
1606 enqueue_misc_user_event (Lisp_Object channel, Lisp_Object function,
1607 Lisp_Object object)
1608 {
1609 Lisp_Object event = Fmake_event (Qnil, Qnil);
1610
1611 XEVENT (event)->event_type = misc_user_event;
1612 XEVENT (event)->channel = channel;
1613 XEVENT (event)->event.misc.function = function;
1614 XEVENT (event)->event.misc.object = object;
1615 XEVENT (event)->event.misc.button = 0;
1616 XEVENT (event)->event.misc.modifiers = 0;
1617 XEVENT (event)->event.misc.x = -1;
1618 XEVENT (event)->event.misc.y = -1;
1619 enqueue_command_event (event);
1620
1621 return event;
1622 }
1623
1624 Lisp_Object
1625 enqueue_misc_user_event_pos (Lisp_Object channel, Lisp_Object function,
1626 Lisp_Object object,
1627 int button, int modifiers, int x, int y)
1628 {
1629 Lisp_Object event = Fmake_event (Qnil, Qnil);
1630
1631 XEVENT (event)->event_type = misc_user_event;
1632 XEVENT (event)->channel = channel;
1633 XEVENT (event)->event.misc.function = function;
1634 XEVENT (event)->event.misc.object = object;
1635 XEVENT (event)->event.misc.button = button;
1636 XEVENT (event)->event.misc.modifiers = modifiers;
1637 XEVENT (event)->event.misc.x = x;
1638 XEVENT (event)->event.misc.y = y;
1639 enqueue_command_event (event);
1640
1641 return event;
1642 }
1643
1644
1645 /**********************************************************************/
1646 /* focus-event handling */
1647 /**********************************************************************/
1648
1649 /*
1650
1651 Ben's capsule lecture on focus:
1652
1653 In FSFmacs `select-frame' never changes the window-manager frame
1654 focus. All it does is change the "selected frame". This is similar
1655 to what happens when we call `select-device' or `select-console'.
1656 Whenever an event comes in (including a keyboard event), its frame is
1657 selected; therefore, evaluating `select-frame' in *scratch* won't
1658 cause any effects because the next received event (in the same frame)
1659 will cause a switch back to the frame displaying *scratch*.
1660
1661 Whenever a focus-change event is received from the window manager, it
1662 generates a `switch-frame' event, which causes the Lisp function
1663 `handle-switch-frame' to get run. This basically just runs
1664 `select-frame' (see below, however).
1665
1666 In FSFmacs, if you want to have an operation run when a frame is
1667 selected, you supply an event binding for `switch-frame' (and then
1668 maybe call `handle-switch-frame', or something ...).
1669
1670 In XEmacs, we *do* change the window-manager frame focus as a result
1671 of `select-frame', but not until the next time an event is received,
1672 so that a function that momentarily changes the selected frame won't
1673 cause WM focus flashing. (#### There's something not quite right here;
1674 this is causing the wrong-cursor-focus problems that you occasionally
1675 see. But the general idea is correct.) This approach is winning for
1676 people who use the explicit-focus model, but is trickier to implement.
1677
1678 We also don't make the `switch-frame' event visible but instead have
1679 `select-frame-hook', which is a better approach.
1680
1681 There is the problem of surrogate minibuffers, where when we enter the
1682 minibuffer, you essentially want to temporarily switch the WM focus to
1683 the frame with the minibuffer, and switch it back when you exit the
1684 minibuffer.
1685
1686 FSFmacs solves this with the crockish `redirect-frame-focus', which
1687 says "for keyboard events received from FRAME, act like they're
1688 coming from FOCUS-FRAME". I think what this means is that, when
1689 a keyboard event comes in and the event manager is about to select the
1690 event's frame, if that frame has its focus redirected, the redirected-to
1691 frame is selected instead. That way, if you're in a minibufferless
1692 frame and enter the minibuffer, then all Lisp functions that run see
1693 the selected frame as the minibuffer's frame rather than the minibufferless
1694 frame you came from, so that (e.g.) your typing actually appears in
1695 the minibuffer's frame and things behave sanely.
1696
1697 There's also some weird logic that switches the redirected frame focus
1698 from one frame to another if Lisp code explicitly calls `select-frame'
1699 \(but not if `handle-switch-frame' is called), and saves and restores
1700 the frame focus in window configurations, etc. etc. All of this logic
1701 is heavily #if 0'd, with lots of comments saying "No, this approach
1702 doesn't seem to work, so I'm trying this ... is it reasonable?
1703 Well, I'm not sure ..." that are a red flag indicating crockishness.
1704
1705 Because of our way of doing things, we can avoid all this crock.
1706 Keyboard events never cause a select-frame (who cares what frame
1707 they're associated with? They come from a console, only). We change
1708 the actual WM focus to a surrogate minibuffer frame, so we don't have
1709 to do any internal redirection. In order to get the focus back,
1710 I took the approach in minibuf.el of just checking to see if the
1711 frame we moved to is still the selected frame, and move back to the
1712 old one if so. Conceivably we might have to do the weird "tracking"
1713 that FSFmacs does when `select-frame' is called, but I don't think
1714 so. If the selected frame moved from the minibuffer frame, then
1715 we just leave it there, figuring that someone knows what they're
1716 doing. Because we don't have any redirection recorded anywhere,
1717 it's safe to do this, and we don't end up with unwanted redirection.
1718
1719 */
1720
1721 static void
1722 run_select_frame_hook (void)
1723 {
1724 run_hook (Qselect_frame_hook);
1725 }
1726
1727 static void
1728 run_deselect_frame_hook (void)
1729 {
1730 #if 0 /* unclean! FSF calls this at all sorts of random places,
1731 including a bunch of places in their mouse.el. If this
1732 is implemented, it has to be done cleanly. */
1733 run_hook (Qmouse_leave_buffer_hook); /* #### Correct? It's also
1734 called in `call-interactively'.
1735 Does this mean it will be
1736 called twice? Oh well, FSF
1737 bug -- FSF calls it in
1738 `handle-switch-frame',
1739 which is approximately the
1740 same as the caller of this
1741 function. */
1742 #endif
1743 run_hook (Qdeselect_frame_hook);
1744 }
1745
1746 /* When select-frame is called and focus_follows_mouse is false, we want
1747 to tell the window system that the focus should be changed to point to
1748 the new frame. However,
1749 sometimes Lisp functions will temporarily change the selected frame
1750 (e.g. to call a function that operates on the selected frame),
1751 and it's annoying if this focus-change happens exactly when
1752 select-frame is called, because then you get some flickering of the
1753 window-manager border and perhaps other undesirable results. We
1754 really only want to change the focus when we're about to retrieve
1755 an event from the user. To do this, we keep track of the frame
1756 where the window-manager focus lies on, and just before waiting
1757 for user events, check the currently selected frame and change
1758 the focus as necessary.
1759
1760 On the other hand, if focus_follows_mouse is true, we need to switch the
1761 selected frame back to the frame with window manager focus just before we
1762 execute the next command in Fcommand_loop_1, just as the selected buffer is
1763 reverted after a set-buffer.
1764
1765 Both cases are handled by this function. It must be called as appropriate
1766 from these two places, depending on the value of focus_follows_mouse. */
1767
1768 void
1769 investigate_frame_change (void)
1770 {
1771 Lisp_Object devcons, concons;
1772
1773 /* if the selected frame was changed, change the window-system
1774 focus to the new frame. We don't do it when select-frame was
1775 called, to avoid flickering and other unwanted side effects when
1776 the frame is just changed temporarily. */
1777 DEVICE_LOOP_NO_BREAK (devcons, concons)
1778 {
1779 struct device *d = XDEVICE (XCAR (devcons));
1780 Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d);
1781
1782 /* You'd think that maybe we should use FRAME_WITH_FOCUS_REAL,
1783 but that can cause us to end up in an infinite loop focusing
1784 between two frames. It seems that since the call to `select-frame'
1785 in emacs_handle_focus_change_final() is based on the _FOR_HOOKS
1786 value, we need to do so too. */
1787 if (!NILP (sel_frame) &&
1788 !EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) &&
1789 !NILP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)) &&
1790 !EQ (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d), sel_frame))
1791 {
1792 /* At this point, we know that the frame has been changed. Now, if
1793 * focus_follows_mouse is not set, we finish off the frame change,
1794 * so that user events will now come from the new frame. Otherwise,
1795 * if focus_follows_mouse is set, no gratuitous frame changing
1796 * should take place. Set the focus back to the frame which was
1797 * originally selected for user input.
1798 */
1799 if (!focus_follows_mouse)
1800 {
1801 /* prevent us from issuing the same request more than once */
1802 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = sel_frame;
1803 MAYBE_DEVMETH (d, focus_on_frame, (XFRAME (sel_frame)));
1804 }
1805 else
1806 {
1807 Lisp_Object old_frame = Qnil;
1808
1809 /* #### Do we really want to check OUGHT ??
1810 * It seems to make sense, though I have never seen us
1811 * get here and have it be non-nil.
1812 */
1813 if (FRAMEP (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d)))
1814 old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d);
1815 else if (FRAMEP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)))
1816 old_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d);
1817
1818 /* #### Can old_frame ever be NIL? play it safe.. */
1819 if (!NILP (old_frame))
1820 {
1821 /* Fselect_frame is not really the right thing: it frobs the
1822 * buffer stack. But there's no easy way to do the right
1823 * thing, and this code already had this problem anyway.
1824 */
1825 Fselect_frame (old_frame);
1826 }
1827 }
1828 }
1829 }
1830 }
1831
1832 static Lisp_Object
1833 cleanup_after_missed_defocusing (Lisp_Object frame)
1834 {
1835 if (FRAMEP (frame) && FRAME_LIVE_P (XFRAME (frame)))
1836 Fselect_frame (frame);
1837 return Qnil;
1838 }
1839
1840 void
1841 emacs_handle_focus_change_preliminary (Lisp_Object frame_inp_and_dev)
1842 {
1843 Lisp_Object frame = Fcar (frame_inp_and_dev);
1844 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev));
1845 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev)));
1846 struct device *d;
1847
1848 if (!DEVICE_LIVE_P (XDEVICE (device)))
1849 return;
1850 else
1851 d = XDEVICE (device);
1852
1853 /* Any received focus-change notifications render invalid any
1854 pending focus-change requests. */
1855 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = Qnil;
1856 if (in_p)
1857 {
1858 Lisp_Object focus_frame;
1859
1860 if (!FRAME_LIVE_P (XFRAME (frame)))
1861 return;
1862 else
1863 focus_frame = DEVICE_FRAME_WITH_FOCUS_REAL (d);
1864
1865 /* Mark the minibuffer as changed to make sure it gets updated
1866 properly if the echo area is active. */
1867 {
1868 struct window *w = XWINDOW (FRAME_MINIBUF_WINDOW (XFRAME (frame)));
1869 MARK_WINDOWS_CHANGED (w);
1870 }
1871
1872 if (FRAMEP (focus_frame) && !EQ (frame, focus_frame))
1873 {
1874 /* Oops, we missed a focus-out event. */
1875 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil;
1876 redisplay_redraw_cursor (XFRAME (focus_frame), 1);
1877 }
1878 DEVICE_FRAME_WITH_FOCUS_REAL (d) = frame;
1879 if (!EQ (frame, focus_frame))
1880 {
1881 redisplay_redraw_cursor (XFRAME (frame), 1);
1882 }
1883 }
1884 else
1885 {
1886 /* We ignore the frame reported in the event. If it's different
1887 from where we think the focus was, oh well -- we messed up.
1888 Nonetheless, we pretend we were right, for sensible behavior. */
1889 frame = DEVICE_FRAME_WITH_FOCUS_REAL (d);
1890 if (!NILP (frame))
1891 {
1892 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil;
1893
1894 if (FRAME_LIVE_P (XFRAME (frame)))
1895 redisplay_redraw_cursor (XFRAME (frame), 1);
1896 }
1897 }
1898 }
1899
1900 /* Called from the window-system-specific code when we receive a
1901 notification that the focus lies on a particular frame.
1902 Argument is a cons: (frame . (device . in-p)) where in-p is non-nil
1903 for focus-in.
1904 */
1905 void
1906 emacs_handle_focus_change_final (Lisp_Object frame_inp_and_dev)
1907 {
1908 Lisp_Object frame = Fcar (frame_inp_and_dev);
1909 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev));
1910 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev)));
1911 struct device *d;
1912 int count;
1913
1914 if (!DEVICE_LIVE_P (XDEVICE (device)))
1915 return;
1916 else
1917 d = XDEVICE (device);
1918
1919 if (in_p)
1920 {
1921 Lisp_Object focus_frame;
1922
1923 if (!FRAME_LIVE_P (XFRAME (frame)))
1924 return;
1925 else
1926 focus_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d);
1927
1928 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = frame;
1929 if (FRAMEP (focus_frame) && !EQ (frame, focus_frame))
1930 {
1931 /* Oops, we missed a focus-out event. */
1932 Fselect_frame (focus_frame);
1933 /* Do an unwind-protect in case an error occurs in
1934 the deselect-frame-hook */
1935 count = specpdl_depth ();
1936 record_unwind_protect (cleanup_after_missed_defocusing, frame);
1937 run_deselect_frame_hook ();
1938 unbind_to (count, Qnil);
1939 /* the cleanup method changed the focus frame to nil, so
1940 we need to reflect this */
1941 focus_frame = Qnil;
1942 }
1943 else
1944 Fselect_frame (frame);
1945 if (!EQ (frame, focus_frame))
1946 run_select_frame_hook ();
1947 }
1948 else
1949 {
1950 /* We ignore the frame reported in the event. If it's different
1951 from where we think the focus was, oh well -- we messed up.
1952 Nonetheless, we pretend we were right, for sensible behavior. */
1953 frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d);
1954 if (!NILP (frame))
1955 {
1956 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = Qnil;
1957 run_deselect_frame_hook ();
1958 }
1959 }
1960 }
1961
1962
1963 /**********************************************************************/
1964 /* retrieving the next event */
1965 /**********************************************************************/
1966
1967 static int in_single_console;
1968
1969 /* #### These functions don't currently do anything. */
1970 void
1971 single_console_state (void)
1972 {
1973 in_single_console = 1;
1974 }
1975
1976 void
1977 any_console_state (void)
1978 {
1979 in_single_console = 0;
1980 }
1981
1982 int
1983 in_single_console_state (void)
1984 {
1985 return in_single_console;
1986 }
1987
1988 /* the number of keyboard characters read. callint.c wants this. */
1989 Charcount num_input_chars;
1990
1991 static void
1992 next_event_internal (Lisp_Object target_event, int allow_queued)
1993 {
1994 struct gcpro gcpro1;
1995 /* QUIT; This is incorrect - the caller must do this because some
1996 callers (ie, Fnext_event()) do not want to QUIT. */
1997
1998 assert (NILP (XEVENT_NEXT (target_event)));
1999
2000 GCPRO1 (target_event);
2001
2002 /* When focus_follows_mouse is nil, if a frame change took place, we need
2003 * to actually switch window manager focus to the selected window now.
2004 */
2005 if (!focus_follows_mouse)
2006 investigate_frame_change ();
2007
2008 if (allow_queued && !NILP (command_event_queue))
2009 {
2010 Lisp_Object event = dequeue_command_event ();
2011 Fcopy_event (event, target_event);
2012 Fdeallocate_event (event);
2013 DEBUG_PRINT_EMACS_EVENT ("command event queue", target_event);
2014 }
2015 else
2016 {
2017 struct Lisp_Event *e = XEVENT (target_event);
2018
2019 /* The command_event_queue was empty. Wait for an event. */
2020 event_stream_next_event (e);
2021 /* If this was a timeout, then we need to extract some data
2022 out of the returned closure and might need to resignal
2023 it. */
2024 if (e->event_type == timeout_event)
2025 {
2026 Lisp_Object tristan, isolde;
2027
2028 e->event.timeout.id_number =
2029 event_stream_resignal_wakeup (e->event.timeout.interval_id, 0,
2030 &tristan, &isolde);
2031
2032 e->event.timeout.function = tristan;
2033 e->event.timeout.object = isolde;
2034 /* next_event_internal() doesn't print out timeout events
2035 because of the extra info we just set. */
2036 DEBUG_PRINT_EMACS_EVENT ("real, timeout", target_event);
2037 }
2038
2039 /* If we read a ^G, then set quit-flag but do not discard the ^G.
2040 The callers of next_event_internal() will do one of two things:
2041
2042 -- set Vquit_flag to Qnil. (next-event does this.) This will
2043 cause the ^G to be treated as a normal keystroke.
2044 -- not change Vquit_flag but attempt to enqueue the ^G, at
2045 which point it will be discarded. The next time QUIT is
2046 called, it will notice that Vquit_flag was set.
2047
2048 */
2049 if (e->event_type == key_press_event &&
2050 event_matches_key_specifier_p
2051 (e, make_char (CONSOLE_QUIT_CHAR (XCONSOLE (EVENT_CHANNEL (e))))))
2052 {
2053 Vquit_flag = Qt;
2054 }
2055 }
2056
2057 UNGCPRO;
2058 }
2059
2060 static void
2061 run_pre_idle_hook (void)
2062 {
2063 if (!NILP (Vpre_idle_hook)
2064 && !detect_input_pending ())
2065 safe_run_hook_trapping_errors
2066 ("Error in `pre-idle-hook' (setting hook to nil)",
2067 Qpre_idle_hook, 1);
2068 }
2069
2070 static void push_this_command_keys (Lisp_Object event);
2071 static void push_recent_keys (Lisp_Object event);
2072 static void dribble_out_event (Lisp_Object event);
2073 static void execute_internal_event (Lisp_Object event);
2074
2075 DEFUN ("next-event", Fnext_event, 0, 2, 0, /*
2076 Return the next available event.
2077 Pass this object to `dispatch-event' to handle it.
2078 In most cases, you will want to use `next-command-event', which returns
2079 the next available "user" event (i.e. keypress, button-press,
2080 button-release, or menu selection) instead of this function.
2081
2082 If EVENT is non-nil, it should be an event object and will be filled in
2083 and returned; otherwise a new event object will be created and returned.
2084 If PROMPT is non-nil, it should be a string and will be displayed in the
2085 echo area while this function is waiting for an event.
2086
2087 The next available event will be
2088
2089 -- any events in `unread-command-events' or `unread-command-event'; else
2090 -- the next event in the currently executing keyboard macro, if any; else
2091 -- an event queued by `enqueue-eval-event', if any; else
2092 -- the next available event from the window system or terminal driver.
2093
2094 In the last case, this function will block until an event is available.
2095
2096 The returned event will be one of the following types:
2097
2098 -- a key-press event.
2099 -- a button-press or button-release event.
2100 -- a misc-user-event, meaning the user selected an item on a menu or used
2101 the scrollbar.
2102 -- a process event, meaning that output from a subprocess is available.
2103 -- a timeout event, meaning that a timeout has elapsed.
2104 -- an eval event, which simply causes a function to be executed when the
2105 event is dispatched. Eval events are generated by `enqueue-eval-event'
2106 or by certain other conditions happening.
2107 -- a magic event, indicating that some window-system-specific event
2108 happened (such as a focus-change notification) that must be handled
2109 synchronously with other events. `dispatch-event' knows what to do with
2110 these events.
2111 */
2112 (event, prompt))
2113 {
2114 /* This function can call lisp */
2115 /* #### We start out using the selected console before an event
2116 is received, for echoing the partially completed command.
2117 This is most definitely wrong -- there needs to be a separate
2118 echo area for each console! */
2119 struct console *con = XCONSOLE (Vselected_console);
2120 struct command_builder *command_builder =
2121 XCOMMAND_BUILDER (con->command_builder);
2122 int store_this_key = 0;
2123 struct gcpro gcpro1;
2124 #ifdef LWLIB_MENUBARS_LUCID
2125 extern int in_menu_callback; /* defined in menubar-x.c */
2126 #endif /* LWLIB_MENUBARS_LUCID */
2127
2128 GCPRO1 (event);
2129 /* DO NOT do QUIT anywhere within this function or the functions it calls.
2130 We want to read the ^G as an event. */
2131
2132 #ifdef LWLIB_MENUBARS_LUCID
2133 /*
2134 * #### Fix the menu code so this isn't necessary.
2135 *
2136 * We cannot allow the lwmenu code to be reentered, because the
2137 * code is not written to be reentrant and will crash. Therefore
2138 * paths from the menu callbacks back into the menu code have to
2139 * be blocked. Fnext_event is the normal path into the menu code,
2140 * so we signal an error here.
2141 */
2142 if (in_menu_callback)
2143 error ("Attempt to call next-event inside menu callback");
2144 #endif /* LWLIB_MENUBARS_LUCID */
2145
2146 if (NILP (event))
2147 event = Fmake_event (Qnil, Qnil);
2148 else
2149 CHECK_LIVE_EVENT (event);
2150
2151 if (!NILP (prompt))
2152 {
2153 Bytecount len;
2154 CHECK_STRING (prompt);
2155
2156 len = XSTRING_LENGTH (prompt);
2157 if (command_builder->echo_buf_length < len)
2158 len = command_builder->echo_buf_length - 1;
2159 memcpy (command_builder->echo_buf, XSTRING_DATA (prompt), len);
2160 command_builder->echo_buf[len] = 0;
2161 command_builder->echo_buf_index = len;
2162 echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)),
2163 command_builder->echo_buf,
2164 Qnil, 0,
2165 command_builder->echo_buf_index,
2166 Qcommand);
2167 }
2168
2169 start_over_and_avoid_hosage:
2170
2171 /* If there is something in unread-command-events, simply return it.
2172 But do some error checking to make sure the user hasn't put something
2173 in the unread-command-events that they shouldn't have.
2174 This does not update this-command-keys and recent-keys.
2175 */
2176 if (!NILP (Vunread_command_events))
2177 {
2178 if (!CONSP (Vunread_command_events))
2179 {
2180 Vunread_command_events = Qnil;
2181 signal_error (Qwrong_type_argument,
2182 list3 (Qconsp, Vunread_command_events,
2183 Qunread_command_events));
2184 }
2185 else
2186 {
2187 Lisp_Object e = XCAR (Vunread_command_events);
2188 Vunread_command_events = XCDR (Vunread_command_events);
2189 if (!EVENTP (e) || !command_event_p (e))
2190 signal_error (Qwrong_type_argument,
2191 list3 (Qcommand_event_p, e, Qunread_command_events));
2192 redisplay ();
2193 if (!EQ (e, event))
2194 Fcopy_event (e, event);
2195 DEBUG_PRINT_EMACS_EVENT ("unread-command-events", event);
2196 }
2197 }
2198
2199 /* Do similar for unread-command-event (obsoleteness support). */
2200 else if (!NILP (Vunread_command_event))
2201 {
2202 Lisp_Object e = Vunread_command_event;
2203 Vunread_command_event = Qnil;
2204
2205 if (!EVENTP (e) || !command_event_p (e))
2206 {
2207 signal_error (Qwrong_type_argument,
2208 list3 (Qeventp, e, Qunread_command_event));
2209 }
2210 if (!EQ (e, event))
2211 Fcopy_event (e, event);
2212 redisplay ();
2213 DEBUG_PRINT_EMACS_EVENT ("unread-command-event", event);
2214 }
2215
2216 /* If we're executing a keyboard macro, take the next event from that,
2217 and update this-command-keys and recent-keys.
2218 Note that the unread-command-events take precedence over kbd macros.
2219 */
2220 else
2221 {
2222 if (!NILP (Vexecuting_macro))
2223 {
2224 redisplay ();
2225 pop_kbd_macro_event (event); /* This throws past us at
2226 end-of-macro. */
2227 store_this_key = 1;
2228 DEBUG_PRINT_EMACS_EVENT ("keyboard macro", event);
2229 }
2230 /* Otherwise, read a real event, possibly from the
2231 command_event_queue, and update this-command-keys and
2232 recent-keys. */
2233 else
2234 {
2235 run_pre_idle_hook ();
2236 redisplay ();
2237 next_event_internal (event, 1);
2238 Vquit_flag = Qnil; /* Read C-g as an event. */
2239 store_this_key = 1;
2240 }
2241 }
2242
2243 status_notify (); /* Notice process change */
2244
2245 #ifdef C_ALLOCA
2246 alloca (0); /* Cause a garbage collection now */
2247 /* Since we can free the most stuff here
2248 * (since this is typically called from
2249 * the command-loop top-level). */
2250 #endif /* C_ALLOCA */
2251
2252 if (object_dead_p (XEVENT (event)->channel))
2253 /* event_console_or_selected may crash if the channel is dead.
2254 Best just to eat it and get the next event. */
2255 goto start_over_and_avoid_hosage;
2256
2257 /* OK, now we can stop the selected-console kludge and use the
2258 actual console from the event. */
2259 con = event_console_or_selected (event);
2260 command_builder = XCOMMAND_BUILDER (con->command_builder);
2261
2262 switch (XEVENT_TYPE (event))
2263 {
2264 default:
2265 goto RETURN;
2266 case button_release_event:
2267 case misc_user_event:
2268 /* don't echo menu accelerator keys */
2269 reset_key_echo (command_builder, 1);
2270 goto EXECUTE_KEY;
2271 case button_press_event: /* key or mouse input can trigger prompting */
2272 goto STORE_AND_EXECUTE_KEY;
2273 case key_press_event: /* any key input can trigger autosave */
2274 break;
2275 }
2276
2277 maybe_do_auto_save ();
2278 num_input_chars++;
2279 STORE_AND_EXECUTE_KEY:
2280 if (store_this_key)
2281 {
2282 echo_key_event (command_builder, event);
2283 }
2284
2285 EXECUTE_KEY:
2286 /* Store the last-input-event. The semantics of this is that it is
2287 the thing most recently returned by next-command-event. It need
2288 not have come from the keyboard or a keyboard macro, it may have
2289 come from unread-command-events. It's always a command-event (a
2290 key, click, or menu selection), never a motion or process event.
2291 */
2292 if (!EVENTP (Vlast_input_event))
2293 Vlast_input_event = Fmake_event (Qnil, Qnil);
2294 if (XEVENT_TYPE (Vlast_input_event) == dead_event)
2295 {
2296 Vlast_input_event = Fmake_event (Qnil, Qnil);
2297 error ("Someone deallocated last-input-event!");
2298 }
2299 if (! EQ (event, Vlast_input_event))
2300 Fcopy_event (event, Vlast_input_event);
2301
2302 /* last-input-char and last-input-time are derived from
2303 last-input-event.
2304 Note that last-input-char will never have its high-bit set, in an
2305 effort to sidestep the ambiguity between M-x and oslash.
2306 */
2307 Vlast_input_char = Fevent_to_character (Vlast_input_event,
2308 Qnil, Qnil, Qnil);
2309 {
2310 EMACS_TIME t;
2311 EMACS_GET_TIME (t);
2312 if (!CONSP (Vlast_input_time))
2313 Vlast_input_time = Fcons (Qnil, Qnil);
2314 XCAR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 16) & 0xffff);
2315 XCDR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 0) & 0xffff);
2316 if (!CONSP (Vlast_command_event_time))
2317 Vlast_command_event_time = list3 (Qnil, Qnil, Qnil);
2318 XCAR (Vlast_command_event_time) =
2319 make_int ((EMACS_SECS (t) >> 16) & 0xffff);
2320 XCAR (XCDR (Vlast_command_event_time)) =
2321 make_int ((EMACS_SECS (t) >> 0) & 0xffff);
2322 XCAR (XCDR (XCDR (Vlast_command_event_time)))
2323 = make_int (EMACS_USECS (t));
2324 }
2325 /* If this key came from the keyboard or from a keyboard macro, then
2326 it goes into the recent-keys and this-command-keys vectors.
2327 If this key came from the keyboard, and we're defining a keyboard
2328 macro, then it goes into the macro.
2329 */
2330 if (store_this_key)
2331 {
2332 push_this_command_keys (event);
2333 if (!inhibit_input_event_recording)
2334 push_recent_keys (event);
2335 dribble_out_event (event);
2336 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro))
2337 {
2338 if (!EVENTP (command_builder->current_events))
2339 finalize_kbd_macro_chars (con);
2340 store_kbd_macro_event (event);
2341 }
2342 }
2343 /* If this is the help char and there is a help form, then execute the
2344 help form and swallow this character. This is the only place where
2345 calling Fnext_event() can cause arbitrary lisp code to run. Note
2346 that execute_help_form() calls Fnext_command_event(), which calls
2347 this function, as well as Fdispatch_event.
2348 */
2349 if (!NILP (Vhelp_form) &&
2350 event_matches_key_specifier_p (XEVENT (event), Vhelp_char))
2351 execute_help_form (command_builder, event);
2352
2353 RETURN:
2354 UNGCPRO;
2355 return event;
2356 }
2357
2358 DEFUN ("next-command-event", Fnext_command_event, 0, 2, 0, /*
2359 Return the next available "user" event.
2360 Pass this object to `dispatch-event' to handle it.
2361
2362 If EVENT is non-nil, it should be an event object and will be filled in
2363 and returned; otherwise a new event object will be created and returned.
2364 If PROMPT is non-nil, it should be a string and will be displayed in the
2365 echo area while this function is waiting for an event.
2366
2367 The event returned will be a keyboard, mouse press, or mouse release event.
2368 If there are non-command events available (mouse motion, sub-process output,
2369 etc) then these will be executed (with `dispatch-event') and discarded. This
2370 function is provided as a convenience; it is roughly equivalent to the lisp code
2371
2372 (while (progn
2373 (next-event event prompt)
2374 (not (or (key-press-event-p event)
2375 (button-press-event-p event)
2376 (button-release-event-p event)
2377 (misc-user-event-p event))))
2378 (dispatch-event event))
2379
2380 but it also makes a provision for displaying keystrokes in the echo area.
2381 */
2382 (event, prompt))
2383 {
2384 /* This function can GC */
2385 struct gcpro gcpro1;
2386 GCPRO1 (event);
2387 maybe_echo_keys (XCOMMAND_BUILDER
2388 (XCONSOLE (Vselected_console)->
2389 command_builder), 0); /* #### This sucks bigtime */
2390 for (;;)
2391 {
2392 event = Fnext_event (event, prompt);
2393 if (command_event_p (event))
2394 break;
2395 else
2396 execute_internal_event (event);
2397 }
2398 UNGCPRO;
2399 return event;
2400 }
2401
2402 static void
2403 reset_current_events (struct command_builder *command_builder)
2404 {
2405 Lisp_Object event = command_builder->current_events;
2406 reset_command_builder_event_chain (command_builder);
2407 if (EVENTP (event))
2408 deallocate_event_chain (event);
2409 }
2410
2411 DEFUN ("discard-input", Fdiscard_input, 0, 0, 0, /*
2412 Discard any pending "user" events.
2413 Also cancel any kbd macro being defined.
2414 A user event is a key press, button press, button release, or
2415 "misc-user" event (menu selection or scrollbar action).
2416 */
2417 ())
2418 {
2419 /* This throws away user-input on the queue, but doesn't process any
2420 events. Calling dispatch_event() here leads to a race condition.
2421 */
2422 Lisp_Object event = Fmake_event (Qnil, Qnil);
2423 Lisp_Object head = Qnil, tail = Qnil;
2424 Lisp_Object oiq = Vinhibit_quit;
2425 struct gcpro gcpro1, gcpro2;
2426 /* #### not correct here with Vselected_console? Should
2427 discard-input take a console argument, or maybe map over
2428 all consoles? */
2429 struct console *con = XCONSOLE (Vselected_console);
2430
2431 /* next_event_internal() can cause arbitrary Lisp code to be evalled */
2432 GCPRO2 (event, oiq);
2433 Vinhibit_quit = Qt;
2434 /* If a macro was being defined then we have to mark the modeline
2435 has changed to ensure that it gets updated correctly. */
2436 if (!NILP (con->defining_kbd_macro))
2437 MARK_MODELINE_CHANGED;
2438 con->defining_kbd_macro = Qnil;
2439 reset_current_events (XCOMMAND_BUILDER (con->command_builder));
2440
2441 while (!NILP (command_event_queue)
2442 || event_stream_event_pending_p (1))
2443 {
2444 /* This will take stuff off the command_event_queue, or read it
2445 from the event_stream, but it will not block.
2446 */
2447 next_event_internal (event, 1);
2448 Vquit_flag = Qnil; /* Treat C-g as a user event (ignore it).
2449 It is vitally important that we reset
2450 Vquit_flag here. Otherwise, if we're
2451 reading from a TTY console,
2452 maybe_read_quit_event() will notice
2453 that C-g has been set and send us
2454 another C-g. That will cause us
2455 to get right back here, and read
2456 another C-g, ad infinitum ... */
2457
2458 /* If the event is a user event, ignore it. */
2459 if (!command_event_p (event))
2460 {
2461 /* Otherwise, chain the event onto our list of events not to ignore,
2462 and keep reading until the queue is empty. This does not mean
2463 that if a subprocess is generating an infinite amount of output,
2464 we will never terminate (*provided* that the behavior of
2465 next_event_cb() is correct -- see the comment in events.h),
2466 because this loop ends as soon as there are no more user events
2467 on the command_event_queue or event_stream.
2468 */
2469 enqueue_event (Fcopy_event (event, Qnil), &head, &tail);
2470 }
2471 }
2472
2473 if (!NILP (command_event_queue) || !NILP (command_event_queue_tail))
2474 abort ();
2475
2476 /* Now tack our chain of events back on to the front of the queue.
2477 Actually, since the queue is now drained, we can just replace it.
2478 The effect of this will be that we have deleted all user events
2479 from the input stream without changing the relative ordering of
2480 any other events. (Some events may have been taken from the
2481 event_stream and added to the command_event_queue, however.)
2482
2483 At this time, the command_event_queue will contain only eval_events.
2484 */
2485
2486 command_event_queue = head;
2487 command_event_queue_tail = tail;
2488
2489 Fdeallocate_event (event);
2490 UNGCPRO;
2491
2492 Vinhibit_quit = oiq;
2493 return Qnil;
2494 }
2495
2496
2497 /**********************************************************************/
2498 /* pausing until an action occurs */
2499 /**********************************************************************/
2500
2501 /* This is used in accept-process-output, sleep-for and sit-for.
2502 Before running any process_events in these routines, we set
2503 recursive_sit_for to Qt, and use this unwind protect to reset it to
2504 Qnil upon exit. When recursive_sit_for is Qt, calling sit-for will
2505 cause it to return immediately.
2506
2507 All of these routines install timeouts, so we clear the installed
2508 timeout as well.
2509
2510 Note: It's very easy to break the desired behaviors of these
2511 3 routines. If you make any changes to anything in this area, run
2512 the regression tests at the bottom of the file. -- dmoore */
2513
2514
2515 static Lisp_Object
2516 sit_for_unwind (Lisp_Object timeout_id)
2517 {
2518 if (!NILP(timeout_id))
2519 Fdisable_timeout (timeout_id);
2520
2521 recursive_sit_for = Qnil;
2522 return Qnil;
2523 }
2524
2525 /* #### Is (accept-process-output nil 3) supposed to be like (sleep-for 3)?
2526 */
2527
2528 DEFUN ("accept-process-output", Faccept_process_output, 0, 3, 0, /*
2529 Allow any pending output from subprocesses to be read by Emacs.
2530 It is read into the process' buffers or given to their filter functions.
2531 Non-nil arg PROCESS means do not return until some output has been received
2532 from PROCESS. Nil arg PROCESS means do not return until some output has
2533 been received from any process.
2534 If the second arg is non-nil, it is the maximum number of seconds to wait:
2535 this function will return after that much time even if no input has arrived
2536 from PROCESS. This argument may be a float, meaning wait some fractional
2537 part of a second.
2538 If the third arg is non-nil, it is a number of milliseconds that is added
2539 to the second arg. (This exists only for compatibility.)
2540 Return non-nil iff we received any output before the timeout expired.
2541 */
2542 (process, timeout_secs, timeout_msecs))
2543 {
2544 /* This function can GC */
2545 struct gcpro gcpro1, gcpro2;
2546 Lisp_Object event = Qnil;
2547 Lisp_Object result = Qnil;
2548 int timeout_id = -1;
2549 int timeout_enabled = 0;
2550 int done = 0;
2551 struct buffer *old_buffer = current_buffer;
2552 int count;
2553
2554 /* We preserve the current buffer but nothing else. If a focus
2555 change alters the selected window then the top level event loop
2556 will eventually alter current_buffer to match. In the mean time
2557 we don't want to mess up whatever called this function. */
2558
2559 if (!NILP (process))
2560 CHECK_PROCESS (process);
2561
2562 GCPRO2 (event, process);
2563
2564 if (!NILP (timeout_secs) || !NILP (timeout_msecs))
2565 {
2566 unsigned long msecs = 0;
2567 if (!NILP (timeout_secs))
2568 msecs = lisp_number_to_milliseconds (timeout_secs, 1);
2569 if (!NILP (timeout_msecs))
2570 {
2571 CHECK_NATNUM (timeout_msecs);
2572 msecs += XINT (timeout_msecs);
2573 }
2574 if (msecs)
2575 {
2576 timeout_id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
2577 timeout_enabled = 1;
2578 }
2579 }
2580
2581 event = Fmake_event (Qnil, Qnil);
2582
2583 count = specpdl_depth ();
2584 record_unwind_protect (sit_for_unwind,
2585 timeout_enabled ? make_int (timeout_id) : Qnil);
2586 recursive_sit_for = Qt;
2587
2588 while (!done &&
2589 ((NILP (process) && timeout_enabled) ||
2590 (NILP (process) && event_stream_event_pending_p (0)) ||
2591 (!NILP (process))))
2592 /* Calling detect_input_pending() is the wrong thing here, because
2593 that considers the Vunread_command_events and command_event_queue.
2594 We don't need to look at the command_event_queue because we are
2595 only interested in process events, which don't go on that. In
2596 fact, we can't read from it anyway, because we put stuff on it.
2597
2598 Note that event_stream->event_pending_p must be called in such
2599 a way that it says whether any events *of any kind* are ready,
2600 not just user events, or (accept-process-output nil) will fail
2601 to dispatch any process events that may be on the queue. It is
2602 not clear to me that this is important, because the top-level
2603 loop will process it, and I don't think that there is ever a
2604 time when one calls accept-process-output with a nil argument
2605 and really need the processes to be handled. */
2606 {
2607 /* If our timeout has arrived, we move along. */
2608 if (timeout_enabled && !event_stream_wakeup_pending_p (timeout_id, 0))
2609 {
2610 timeout_enabled = 0;
2611 done = 1; /* We're done. */
2612 continue; /* Don't call next_event_internal */
2613 }
2614
2615 QUIT; /* next_event_internal() does not QUIT, so check for ^G
2616 before reading output from the process - this makes it
2617 less likely that the filter will actually be aborted.
2618 */
2619
2620 next_event_internal (event, 0);
2621 /* If C-g was pressed while we were waiting, Vquit_flag got
2622 set and next_event_internal() also returns C-g. When
2623 we enqueue the C-g below, it will get discarded. The
2624 next time through, QUIT will be called and will signal a quit. */
2625 switch (XEVENT_TYPE (event))
2626 {
2627 case process_event:
2628 {
2629 if (NILP (process) ||
2630 EQ (XEVENT (event)->event.process.process, process))
2631 {
2632 done = 1;
2633 /* RMS's version always returns nil when proc is nil,
2634 and only returns t if input ever arrived on proc. */
2635 result = Qt;
2636 }
2637
2638 execute_internal_event (event);
2639 break;
2640 }
2641 case timeout_event:
2642 /* We execute the event even if it's ours, and notice that it's
2643 happened above. */
2644 case pointer_motion_event:
2645 case magic_event:
2646 {
2647 execute_internal_event (event);
2648 break;
2649 }
2650 default:
2651 {
2652 enqueue_command_event_1 (event);
2653 break;
2654 }
2655 }
2656 }
2657
2658 unbind_to (count, timeout_enabled ? make_int (timeout_id) : Qnil);
2659
2660 Fdeallocate_event (event);
2661 UNGCPRO;
2662 current_buffer = old_buffer;
2663 return result;
2664 }
2665
2666 DEFUN ("sleep-for", Fsleep_for, 1, 1, 0, /*
2667 Pause, without updating display, for ARG seconds.
2668 ARG may be a float, meaning pause for some fractional part of a second.
2669
2670 It is recommended that you never call sleep-for from inside of a process
2671 filter function or timer event (either synchronous or asynchronous).
2672 */
2673 (seconds))
2674 {
2675 /* This function can GC */
2676 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1);
2677 int id;
2678 Lisp_Object event = Qnil;
2679 int count;
2680 struct gcpro gcpro1;
2681
2682 GCPRO1 (event);
2683
2684 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
2685 event = Fmake_event (Qnil, Qnil);
2686
2687 count = specpdl_depth ();
2688 record_unwind_protect (sit_for_unwind, make_int (id));
2689 recursive_sit_for = Qt;
2690
2691 while (1)
2692 {
2693 /* If our timeout has arrived, we move along. */
2694 if (!event_stream_wakeup_pending_p (id, 0))
2695 goto DONE_LABEL;
2696
2697 QUIT; /* next_event_internal() does not QUIT, so check for ^G
2698 before reading output from the process - this makes it
2699 less likely that the filter will actually be aborted.
2700 */
2701 /* We're a generator of the command_event_queue, so we can't be a
2702 consumer as well. We don't care about command and eval-events
2703 anyway.
2704 */
2705 next_event_internal (event, 0); /* blocks */
2706 /* See the comment in accept-process-output about Vquit_flag */
2707 switch (XEVENT_TYPE (event))
2708 {
2709 case timeout_event:
2710 /* We execute the event even if it's ours, and notice that it's
2711 happened above. */
2712 case process_event:
2713 case pointer_motion_event:
2714 case magic_event:
2715 {
2716 execute_internal_event (event);
2717 break;
2718 }
2719 default:
2720 {
2721 enqueue_command_event_1 (event);
2722 break;
2723 }
2724 }
2725 }
2726 DONE_LABEL:
2727 unbind_to (count, make_int (id));
2728 Fdeallocate_event (event);
2729 UNGCPRO;
2730 return Qnil;
2731 }
2732
2733 DEFUN ("sit-for", Fsit_for, 1, 2, 0, /*
2734 Perform redisplay, then wait ARG seconds or until user input is available.
2735 ARG may be a float, meaning a fractional part of a second.
2736 Optional second arg non-nil means don't redisplay, just wait for input.
2737 Redisplay is preempted as always if user input arrives, and does not
2738 happen if input is available before it starts.
2739 Value is t if waited the full time with no input arriving.
2740
2741 If sit-for is called from within a process filter function or timer
2742 event (either synchronous or asynchronous) it will return immediately.
2743 */
2744 (seconds, nodisplay))
2745 {
2746 /* This function can GC */
2747 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1);
2748 Lisp_Object event, result;
2749 struct gcpro gcpro1;
2750 int id;
2751 int count;
2752
2753 /* The unread-command-events count as pending input */
2754 if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event))
2755 return Qnil;
2756
2757 /* If the command-builder already has user-input on it (not eval events)
2758 then that means we're done too.
2759 */
2760 if (!NILP (command_event_queue))
2761 {
2762 EVENT_CHAIN_LOOP (event, command_event_queue)
2763 {
2764 if (command_event_p (event))
2765 return Qnil;
2766 }
2767 }
2768
2769 /* If we're in a macro, or noninteractive, or early in temacs, then
2770 don't wait. */
2771 if (noninteractive || !NILP (Vexecuting_macro))
2772 return Qnil;
2773
2774 /* Recursive call from a filter function or timeout handler. */
2775 if (!NILP(recursive_sit_for))
2776 {
2777 if (!event_stream_event_pending_p (1) && NILP (nodisplay))
2778 {
2779 run_pre_idle_hook ();
2780 redisplay ();
2781 }
2782 return Qnil;
2783 }
2784
2785
2786 /* Otherwise, start reading events from the event_stream.
2787 Do this loop at least once even if (sit-for 0) so that we
2788 redisplay when no input pending.
2789 */
2790 GCPRO1 (event);
2791 event = Fmake_event (Qnil, Qnil);
2792
2793 /* Generate the wakeup even if MSECS is 0, so that existing timeout/etc.
2794 events get processed. The old (pre-19.12) code special-cased this
2795 and didn't generate a wakeup, but the resulting behavior was less than
2796 ideal; viz. the occurrence of (sit-for 0.001) scattered throughout
2797 the E-Lisp universe. */
2798
2799 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
2800
2801 count = specpdl_depth ();
2802 record_unwind_protect (sit_for_unwind, make_int (id));
2803 recursive_sit_for = Qt;
2804
2805 while (1)
2806 {
2807 /* If there is no user input pending, then redisplay.
2808 */
2809 if (!event_stream_event_pending_p (1) && NILP (nodisplay))
2810 {
2811 run_pre_idle_hook ();
2812 redisplay ();
2813 }
2814
2815 /* If our timeout has arrived, we move along. */
2816 if (!event_stream_wakeup_pending_p (id, 0))
2817 {
2818 result = Qt;
2819 goto DONE_LABEL;
2820 }
2821
2822 QUIT; /* next_event_internal() does not QUIT, so check for ^G
2823 before reading output from the process - this makes it
2824 less likely that the filter will actually be aborted.
2825 */
2826 /* We're a generator of the command_event_queue, so we can't be a
2827 consumer as well. In fact, we know there's nothing on the
2828 command_event_queue that we didn't just put there.
2829 */
2830 next_event_internal (event, 0); /* blocks */
2831 /* See the comment in accept-process-output about Vquit_flag */
2832
2833 if (command_event_p (event))
2834 {
2835 QUIT; /* If the command was C-g check it here
2836 so that we abort out of the sit-for,
2837 not the next command. sleep-for and
2838 accept-process-output continue looping
2839 so they check QUIT again implicitly.*/
2840 result = Qnil;
2841 goto DONE_LABEL;
2842 }
2843 switch (XEVENT_TYPE (event))
2844 {
2845 case eval_event:
2846 {
2847 /* eval-events get delayed until later. */
2848 enqueue_command_event (Fcopy_event (event, Qnil));
2849 break;
2850 }
2851
2852 case timeout_event:
2853 /* We execute the event even if it's ours, and notice that it's
2854 happened above. */
2855 default:
2856 {
2857 execute_internal_event (event);
2858 break;
2859 }
2860 }
2861 }
2862
2863 DONE_LABEL:
2864 unbind_to (count, make_int (id));
2865
2866 /* Put back the event (if any) that made Fsit_for() exit before the
2867 timeout. Note that it is being added to the back of the queue, which
2868 would be inappropriate if there were any user events on the queue
2869 already: we would be misordering them. But we know that there are
2870 no user-events on the queue, or else we would not have reached this
2871 point at all.
2872 */
2873 if (NILP (result))
2874 enqueue_command_event (event);
2875 else
2876 Fdeallocate_event (event);
2877
2878 UNGCPRO;
2879 return result;
2880 }
2881
2882 /* This handy little function is used by xselect.c and energize.c to
2883 wait for replies from processes that aren't really processes (that is,
2884 the X server and the Energize server).
2885 */
2886 void
2887 wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg)
2888 {
2889 /* This function can GC */
2890 Lisp_Object event = Fmake_event (Qnil, Qnil);
2891 struct gcpro gcpro1;
2892 GCPRO1 (event);
2893
2894 while (!(*predicate) (predicate_arg))
2895 {
2896 QUIT; /* next_event_internal() does not QUIT. */
2897
2898 /* We're a generator of the command_event_queue, so we can't be a
2899 consumer as well. Also, we have no reason to consult the
2900 command_event_queue; there are only user and eval-events there,
2901 and we'd just have to put them back anyway.
2902 */
2903 next_event_internal (event, 0);
2904 /* See the comment in accept-process-output about Vquit_flag */
2905 if (command_event_p (event)
2906 || (XEVENT_TYPE (event) == eval_event)
2907 || (XEVENT_TYPE (event) == magic_eval_event))
2908 enqueue_command_event_1 (event);
2909 else
2910 execute_internal_event (event);
2911 }
2912 UNGCPRO;
2913 }
2914
2915
2916 /**********************************************************************/
2917 /* dispatching events; command builder */
2918 /**********************************************************************/
2919
2920 static void
2921 execute_internal_event (Lisp_Object event)
2922 {
2923 /* events on dead channels get silently eaten */
2924 if (object_dead_p (XEVENT (event)->channel))
2925 return;
2926
2927 /* This function can GC */
2928 switch (XEVENT_TYPE (event))
2929 {
2930 case empty_event:
2931 return;
2932
2933 case eval_event:
2934 {
2935 call1 (XEVENT (event)->event.eval.function,
2936 XEVENT (event)->event.eval.object);
2937 return;
2938 }
2939
2940 case magic_eval_event:
2941 {
2942 (XEVENT (event)->event.magic_eval.internal_function)
2943 (XEVENT (event)->event.magic_eval.object);
2944 return;
2945 }
2946
2947 case pointer_motion_event:
2948 {
2949 if (!NILP (Vmouse_motion_handler))
2950 call1 (Vmouse_motion_handler, event);
2951 return;
2952 }
2953
2954 case process_event:
2955 {
2956 Lisp_Object p = XEVENT (event)->event.process.process;
2957 Charcount readstatus;
2958
2959 assert (PROCESSP (p));
2960 while ((readstatus = read_process_output (p)) > 0)
2961 ;
2962 if (readstatus > 0)
2963 ; /* this clauses never gets executed but allows the #ifdefs
2964 to work cleanly. */
2965 #ifdef EWOULDBLOCK
2966 else if (readstatus == -1 && errno == EWOULDBLOCK)
2967 ;
2968 #endif /* EWOULDBLOCK */
2969 #ifdef EAGAIN
2970 else if (readstatus == -1 && errno == EAGAIN)
2971 ;
2972 #endif /* EAGAIN */
2973 else if ((readstatus == 0 &&
2974 /* Note that we cannot distinguish between no input
2975 available now and a closed pipe.
2976 With luck, a closed pipe will be accompanied by
2977 subprocess termination and SIGCHLD. */
2978 (!network_connection_p (p) ||
2979 /*
2980 When connected to ToolTalk (i.e.
2981 connected_via_filedesc_p()), it's not possible to
2982 reliably determine whether there is a message
2983 waiting for ToolTalk to receive. ToolTalk expects
2984 to have tt_message_receive() called exactly once
2985 every time the file descriptor becomes active, so
2986 the filter function forces this by returning 0.
2987 Emacs must not interpret this as a closed pipe. */
2988 connected_via_filedesc_p (XPROCESS (p))))
2989 #ifdef HAVE_PTYS
2990 /* On some OSs with ptys, when the process on one end of
2991 a pty exits, the other end gets an error reading with
2992 errno = EIO instead of getting an EOF (0 bytes read).
2993 Therefore, if we get an error reading and errno =
2994 EIO, just continue, because the child process has
2995 exited and should clean itself up soon (e.g. when we
2996 get a SIGCHLD). */
2997 || (readstatus == -1 && errno == EIO)
2998 #endif
2999 )
3000 {
3001 /* Currently, we rely on SIGCHLD to indicate that the
3002 process has terminated. Unfortunately, on some systems
3003 the SIGCHLD gets missed some of the time. So we put an
3004 additional check in status_notify() to see whether a
3005 process has terminated. We must tell status_notify()
3006 to enable that check, and we do so now. */
3007 kick_status_notify ();
3008 }
3009 else
3010 {
3011 /* Deactivate network connection */
3012 Lisp_Object status = Fprocess_status (p);
3013 if (EQ (status, Qopen)
3014 /* In case somebody changes the theory of whether to
3015 return open as opposed to run for network connection
3016 "processes"... */
3017 || EQ (status, Qrun))
3018 update_process_status (p, Qexit, 256, 0);
3019 deactivate_process (p);
3020 }
3021
3022 /* We must call status_notify here to allow the
3023 event_stream->unselect_process_cb to be run if appropriate.
3024 Otherwise, dead fds may be selected for, and we will get a
3025 continuous stream of process events for them. Since we don't
3026 return until all process events have been flushed, we would
3027 get stuck here, processing events on a process whose status
3028 was 'exit. Call this after dispatch-event, or the fds will
3029 have been closed before we read the last data from them.
3030 It's safe for the filter to signal an error because
3031 status_notify() will be called on return to top-level.
3032 */
3033 status_notify ();
3034 return;
3035 }
3036
3037 case timeout_event:
3038 {
3039 struct Lisp_Event *e = XEVENT (event);
3040 if (!NILP (e->event.timeout.function))
3041 call1 (e->event.timeout.function,
3042 e->event.timeout.object);
3043 return;
3044 }
3045 case magic_event:
3046 {
3047 event_stream_handle_magic_event (XEVENT (event));
3048 return;
3049 }
3050 default:
3051 abort ();
3052 }
3053 }
3054
3055
3056
3057 static void
3058 this_command_keys_replace_suffix (Lisp_Object suffix, Lisp_Object chain)
3059 {
3060 Lisp_Object first_before_suffix =
3061 event_chain_find_previous (Vthis_command_keys, suffix);
3062
3063 if (NILP (first_before_suffix))
3064 Vthis_command_keys = chain;
3065 else
3066 XSET_EVENT_NEXT (first_before_suffix, chain);
3067 deallocate_event_chain (suffix);
3068 Vthis_command_keys_tail = event_chain_tail (chain);
3069 }
3070
3071 static void
3072 command_builder_replace_suffix (struct command_builder *builder,
3073 Lisp_Object suffix, Lisp_Object chain)
3074 {
3075 Lisp_Object first_before_suffix =
3076 event_chain_find_previous (builder->current_events, suffix);
3077
3078 if (NILP (first_before_suffix))
3079 builder->current_events = chain;
3080 else
3081 XSET_EVENT_NEXT (first_before_suffix, chain);
3082 deallocate_event_chain (suffix);
3083 builder->most_current_event = event_chain_tail (chain);
3084 }
3085
3086 static Lisp_Object
3087 command_builder_find_leaf_1 (struct command_builder *builder)
3088 {
3089 Lisp_Object event0 = builder->current_events;
3090
3091 if (NILP (event0))
3092 return Qnil;
3093
3094 return event_binding (event0, 1);
3095 }
3096
3097 #if defined(HAVE_X_WINDOWS) && defined(LWLIB_MENUBARS_LUCID)
3098 static void
3099 menu_move_up (void)
3100 {
3101 widget_value *current, *prev;
3102 widget_value *entries;
3103
3104 current = lw_get_entries (False);
3105 entries = lw_get_entries (True);
3106 prev = NULL;
3107 if (current != entries)
3108 {
3109 while (entries != current)
3110 {
3111 if (entries->name /*&& entries->enabled*/) prev = entries;
3112 entries = entries->next;
3113 assert (entries);
3114 }
3115 }
3116
3117 if (!prev)
3118 /* move to last item */
3119 {
3120 while (entries->next)
3121 {
3122 if (entries->name /*&& entries->enabled*/) prev = entries;
3123 entries = entries->next;
3124 }
3125 if (prev)
3126 {
3127 if (entries->name /*&& entries->enabled*/)
3128 prev = entries;
3129 }
3130 else
3131 {
3132 /* no selectable items in this menu, pop up to previous level */
3133 lw_pop_menu ();
3134 return;
3135 }
3136 }
3137 lw_set_item (prev);
3138 }
3139
3140 static void
3141 menu_move_down (void)
3142 {
3143 widget_value *current;
3144 widget_value *new;
3145
3146 current = lw_get_entries (False);
3147 new = current;
3148
3149 while (new->next)
3150 {
3151 new = new->next;
3152 if (new->name /*&& new->enabled*/) break;
3153 }
3154
3155 if (new==current||!(new->name/*||new->enabled*/))
3156 {
3157 new = lw_get_entries (True);
3158 while (new!=current)
3159 {
3160 if (new->name /*&& new->enabled*/) break;
3161 new = new->next;
3162 }
3163 if (new==current&&!(new->name /*|| new->enabled*/))
3164 {
3165 lw_pop_menu ();
3166 return;
3167 }
3168 }
3169
3170 lw_set_item (new);
3171 }
3172
3173 static void
3174 menu_move_left (void)
3175 {
3176 int level = lw_menu_level ();
3177 int l = level;
3178 widget_value *current;
3179
3180 while (level >= 3)
3181 {
3182 --level;
3183 lw_pop_menu ();
3184 }
3185 menu_move_up ();
3186 current = lw_get_entries (False);
3187 if (l > 2 && current->contents)
3188 lw_push_menu (current->contents);
3189 }
3190
3191 static void
3192 menu_move_right (void)
3193 {
3194 int level = lw_menu_level ();
3195 int l = level;
3196 widget_value *current;
3197
3198 while (level >= 3)
3199 {
3200 --level;
3201 lw_pop_menu ();
3202 }
3203 menu_move_down ();
3204 current = lw_get_entries (False);
3205 if (l > 2 && current->contents)
3206 lw_push_menu (current->contents);
3207 }
3208
3209 static void
3210 menu_select_item (widget_value *val)
3211 {
3212 if (val == NULL)
3213 val = lw_get_entries (False);
3214
3215 /* is match a submenu? */
3216
3217 if (val->contents)
3218 {
3219 /* enter the submenu */
3220
3221 lw_set_item (val);
3222 lw_push_menu (val->contents);
3223 }
3224 else
3225 {
3226 /* Execute the menu entry by calling the menu's `select'
3227 callback function
3228 */
3229 lw_kill_menus (val);
3230 }
3231 }
3232
3233 static Lisp_Object
3234 command_builder_operate_menu_accelerator (struct command_builder *builder)
3235 {
3236 /* this function can GC */
3237
3238 struct console *con = XCONSOLE (Vselected_console);
3239 Lisp_Object evee = builder->most_current_event;
3240 Lisp_Object binding;
3241 widget_value *entries;
3242
3243 extern int lw_menu_accelerate; /* lwlib.c */
3244
3245 #if 0
3246 {
3247 int i;
3248 Lisp_Object t;
3249 char buf[50];
3250
3251 t = builder->current_events;
3252 i = 0;
3253 while (!NILP (t))
3254 {
3255 i++;
3256 sprintf (buf,"OPERATE (%d): ",i);
3257 write_c_string (buf, Qexternal_debugging_output);
3258 print_internal (t, Qexternal_debugging_output, 1);
3259 write_c_string ("\n", Qexternal_debugging_output);
3260 t = XEVENT_NEXT (t);
3261 }
3262 }
3263 #endif /* 0 */
3264
3265 /* menu accelerator keys don't go into keyboard macros */
3266 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro))
3267 con->kbd_macro_ptr = con->kbd_macro_end;
3268
3269 /* don't echo menu accelerator keys */
3270 /*reset_key_echo (builder, 1);*/
3271
3272 if (!lw_menu_accelerate)
3273 {
3274 /* `convert' mouse display to keyboard display
3275 by entering the open submenu
3276 */
3277 entries = lw_get_entries (False);
3278 if (entries->contents)
3279 {
3280 lw_push_menu (entries->contents);
3281 lw_display_menu (CurrentTime);
3282 }
3283 }
3284
3285 /* compare event to the current menu accelerators */
3286
3287 entries=lw_get_entries (True);
3288
3289 while (entries)
3290 {
3291 Lisp_Object accel;
3292 VOID_TO_LISP (accel, entries->accel);
3293 if (entries->name && !NILP (accel))
3294 {
3295 if (event_matches_key_specifier_p (XEVENT (evee), accel))
3296 {
3297 /* a match! */
3298
3299 menu_select_item (entries);
3300
3301 if (lw_menu_active) lw_display_menu (CurrentTime);
3302
3303 reset_this_command_keys (Vselected_console, 1);
3304 /*reset_command_builder_event_chain (builder);*/
3305 return Vmenu_accelerator_map;
3306 }
3307 }
3308 entries = entries->next;
3309 }
3310
3311 /* try to look up event in menu-accelerator-map */
3312
3313 binding = event_binding_in (evee, Vmenu_accelerator_map, 1);
3314
3315 if (NILP (binding))
3316 {
3317 /* beep at user for undefined key */
3318 return Qnil;
3319 }
3320 else
3321 {
3322 if (EQ (binding, Qmenu_quit))
3323 {
3324 /* turn off menus and set quit flag */
3325 lw_kill_menus (NULL);
3326 Vquit_flag = Qt;
3327 }
3328 else if (EQ (binding, Qmenu_up))
3329 {
3330 int level = lw_menu_level ();
3331 if (level > 2)
3332 menu_move_up ();
3333 }
3334 else if (EQ (binding, Qmenu_down))
3335 {
3336 int level = lw_menu_level ();
3337 if (level > 2)
3338 menu_move_down ();
3339 else
3340 menu_select_item (NULL);
3341 }
3342 else if (EQ (binding, Qmenu_left))
3343 {
3344 int level = lw_menu_level ();
3345 if (level > 3)
3346 {
3347 lw_pop_menu ();
3348 lw_display_menu (CurrentTime);
3349 }
3350 else
3351 menu_move_left ();
3352 }
3353 else if (EQ (binding, Qmenu_right))
3354 {
3355 int level = lw_menu_level ();
3356 if (level > 2 &&
3357 lw_get_entries (False)->contents)
3358 {
3359 widget_value *current = lw_get_entries (False);
3360 if (current->contents)
3361 menu_select_item (NULL);
3362 }
3363 else
3364 menu_move_right ();
3365 }
3366 else if (EQ (binding, Qmenu_select))
3367 menu_select_item (NULL);
3368 else if (EQ (binding, Qmenu_escape))
3369 {
3370 int level = lw_menu_level ();
3371
3372 if (level > 2)
3373 {
3374 lw_pop_menu ();
3375 lw_display_menu (CurrentTime);
3376 }
3377 else
3378 {
3379 /* turn off menus quietly */
3380 lw_kill_menus (NULL);
3381 }
3382 }
3383 else if (KEYMAPP (binding))
3384 {
3385 /* prefix key */
3386 reset_this_command_keys (Vselected_console, 1);
3387 /*reset_command_builder_event_chain (builder);*/
3388 return binding;
3389 }
3390 else
3391 {
3392 /* turn off menus and execute binding */
3393 lw_kill_menus (NULL);
3394 reset_this_command_keys (Vselected_console, 1);
3395 /*reset_command_builder_event_chain (builder);*/
3396 return binding;
3397 }
3398 }
3399
3400 if (lw_menu_active) lw_display_menu (CurrentTime);
3401
3402 reset_this_command_keys (Vselected_console, 1);
3403 /*reset_command_builder_event_chain (builder);*/
3404
3405 return Vmenu_accelerator_map;
3406 }
3407
3408 static Lisp_Object
3409 menu_accelerator_junk_on_error (Lisp_Object errordata, Lisp_Object ignored)
3410 {
3411 Vmenu_accelerator_prefix = Qnil;
3412 Vmenu_accelerator_modifiers = Qnil;
3413 Vmenu_accelerator_enabled = Qnil;
3414 if (!NILP (errordata))
3415 {
3416 Lisp_Object args[2];
3417
3418 args[0] = build_string ("Error in menu accelerators (setting to nil)");
3419 /* #### This should call
3420 (with-output-to-string (display-error errordata))
3421 but that stuff is all in Lisp currently. */
3422 args[1] = errordata;
3423 warn_when_safe_lispobj
3424 (Qerror, Qwarning,
3425 emacs_doprnt_string_lisp ((CONST Bufbyte *) "%s: %s",
3426 Qnil, -1, 2, args));
3427 }
3428
3429 return Qnil;
3430 }
3431
3432 static Lisp_Object
3433 menu_accelerator_safe_compare (Lisp_Object event0)
3434 {
3435 if (CONSP (Vmenu_accelerator_prefix))
3436 {
3437 Lisp_Object t;
3438 t=Vmenu_accelerator_prefix;
3439 while (!NILP (t)
3440 && !NILP (event0)
3441 && event_matches_key_specifier_p (XEVENT (event0), Fcar (t)))
3442 {
3443 t = Fcdr (t);
3444 event0 = XEVENT_NEXT (event0);
3445 }
3446 if (!NILP (t))
3447 return Qnil;
3448 }
3449 else if (NILP (event0))
3450 return Qnil;
3451 else if (event_matches_key_specifier_p (XEVENT (event0), Vmenu_accelerator_prefix))
3452 event0 = XEVENT_NEXT (event0);
3453 else
3454 return Qnil;
3455 return event0;
3456 }
3457
3458 static Lisp_Object
3459 menu_accelerator_safe_mod_compare (Lisp_Object cons)
3460 {
3461 return (event_matches_key_specifier_p (XEVENT (XCAR (cons)), XCDR (cons))
3462 ? Qt
3463 : Qnil);
3464 }
3465
3466 static Lisp_Object
3467 command_builder_find_menu_accelerator (struct command_builder *builder)
3468 {
3469 /* this function can GC */
3470 Lisp_Object event0 = builder->current_events;
3471 struct console *con = XCONSOLE (Vselected_console);
3472 struct frame *f = XFRAME (CONSOLE_SELECTED_FRAME (con));
3473 Widget menubar_widget;
3474
3475 /* compare entries in event0 against the menu prefix */
3476
3477 if ((!CONSOLE_X_P (XCONSOLE (builder->console))) || NILP (event0) ||
3478 XEVENT (event0)->event_type != key_press_event)
3479 return Qnil;
3480
3481 if (!NILP (Vmenu_accelerator_prefix))
3482 {
3483 event0 = condition_case_1 (Qerror,
3484 menu_accelerator_safe_compare,
3485 event0,
3486 menu_accelerator_junk_on_error,
3487 Qnil);
3488 }
3489
3490 if (NILP (event0))
3491 return Qnil;
3492
3493 menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
3494 if (menubar_widget
3495 && CONSP (Vmenu_accelerator_modifiers))
3496 {
3497 Lisp_Object fake;
3498 Lisp_Object last = Qnil;
3499 struct gcpro gcpro1;
3500 Lisp_Object matchp;
3501
3502 widget_value *val;
3503 LWLIB_ID id = XPOPUP_DATA (f->menubar_data)->id;
3504
3505 val = lw_get_all_values (id);
3506 if (val)
3507 {
3508 val = val->contents;
3509
3510 fake = Fcopy_sequence (Vmenu_accelerator_modifiers);
3511 last = fake;
3512
3513 while (!NILP (Fcdr (last)))
3514 last = Fcdr (last);
3515
3516 Fsetcdr (last, Fcons (Qnil, Qnil));
3517 last = Fcdr (last);
3518 }
3519
3520 fake = Fcons (Qnil, fake);
3521
3522 GCPRO1 (fake);
3523
3524 while (val)
3525 {
3526 Lisp_Object accel;
3527 VOID_TO_LISP (accel, val->accel);
3528 if (val->name && !NILP (accel))
3529 {
3530 Fsetcar (last, accel);
3531 Fsetcar (fake, event0);
3532 matchp = condition_case_1 (Qerror,
3533 menu_accelerator_safe_mod_compare,
3534 fake,
3535 menu_accelerator_junk_on_error,
3536 Qnil);
3537 if (!NILP (matchp))
3538 {
3539 /* we found one! */
3540
3541 lw_set_menu (menubar_widget, val);
3542 /* yah - yet another hack.
3543 pretend emacs timestamp is the same as an X timestamp,
3544 which for the moment it is. (read events.h)
3545 */
3546 lw_map_menu (XEVENT (event0)->timestamp);
3547
3548 if (val->contents)
3549 lw_push_menu (val->contents);
3550
3551 lw_display_menu (CurrentTime);
3552
3553 /* menu accelerator keys don't go into keyboard macros */
3554 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro))
3555 con->kbd_macro_ptr = con->kbd_macro_end;
3556
3557 /* don't echo menu accelerator keys */
3558 /*reset_key_echo (builder, 1);*/
3559 reset_this_command_keys (Vselected_console, 1);
3560 UNGCPRO;
3561
3562 return Vmenu_accelerator_map;
3563 }
3564 }
3565
3566 val = val->next;
3567 }
3568
3569 UNGCPRO;
3570 }
3571 return Qnil;
3572 }
3573
3574
3575 DEFUN ("accelerate-menu", Faccelerate_menu, 0, 0, "_", /*
3576 Make the menubar active. Menu items can be selected using menu accelerators
3577 or by actions defined in menu-accelerator-map.
3578 */
3579 ())
3580 {
3581 struct console *con = XCONSOLE (Vselected_console);
3582 struct frame *f = XFRAME (CONSOLE_SELECTED_FRAME (con));
3583 LWLIB_ID id;
3584 widget_value *val;
3585
3586 if (NILP (f->menubar_data))
3587 error ("Frame has no menubar.");
3588
3589 id = XPOPUP_DATA (f->menubar_data)->id;
3590 val = lw_get_all_values (id);
3591 val = val->contents;
3592 lw_set_menu (FRAME_X_MENUBAR_WIDGET (f), val);
3593 lw_map_menu (CurrentTime);
3594
3595 lw_display_menu (CurrentTime);
3596
3597 /* menu accelerator keys don't go into keyboard macros */
3598 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro))
3599 con->kbd_macro_ptr = con->kbd_macro_end;
3600
3601 return Qnil;
3602 }
3603 #endif /* HAVE_X_WINDOWS && HAVE_MENUBARS */
3604
3605 /* See if we can do function-key-map or key-translation-map translation
3606 on the current events in the command builder. If so, do this, and
3607 return the resulting binding, if any. */
3608
3609 static Lisp_Object
3610 munge_keymap_translate (struct command_builder *builder,
3611 enum munge_me_out_the_door munge,
3612 int has_normal_binding_p)
3613 {
3614 Lisp_Object suffix;
3615
3616 EVENT_CHAIN_LOOP (suffix, builder->munge_me[munge].first_mungeable_event)
3617 {
3618 Lisp_Object result = munging_key_map_event_binding (suffix, munge);
3619
3620 if (NILP (result))
3621 continue;
3622
3623 if (KEYMAPP (result))
3624 {
3625 if (NILP (builder->last_non_munged_event)
3626 && !has_normal_binding_p)
3627 builder->last_non_munged_event = builder->most_current_event;
3628 }
3629 else
3630 builder->last_non_munged_event = Qnil;
3631
3632 if (!KEYMAPP (result) &&
3633 !VECTORP (result) &&
3634 !STRINGP (result))
3635 {
3636 struct gcpro gcpro1;
3637 GCPRO1 (suffix);
3638 result = call1 (result, Qnil);
3639 UNGCPRO;
3640 if (NILP (result))
3641 return Qnil;
3642 }
3643
3644 if (KEYMAPP (result))
3645 return result;
3646
3647 if (VECTORP (result) || STRINGP (result))
3648 {
3649 Lisp_Object new_chain = key_sequence_to_event_chain (result);
3650 Lisp_Object tempev;
3651 int n, tckn;
3652
3653 /* If the first_mungeable_event of the other munger is
3654 within the events we're munging, then it will point to
3655 deallocated events afterwards, which is bad -- so make it
3656 point at the beginning of the munged events. */
3657 EVENT_CHAIN_LOOP (tempev, suffix)
3658 {
3659 Lisp_Object *mungeable_event =
3660 &builder->munge_me[1 - munge].first_mungeable_event;
3661 if (EQ (tempev, *mungeable_event))
3662 {
3663 *mungeable_event = new_chain;
3664 break;
3665 }
3666 }
3667
3668 n = event_chain_count (suffix);
3669 command_builder_replace_suffix (builder, suffix, new_chain);
3670 builder->munge_me[munge].first_mungeable_event = Qnil;
3671 /* Now hork this-command-keys as well. */
3672
3673 /* We just assume that the events we just replaced are
3674 sitting in copied form at the end of this-command-keys.
3675 If the user did weird things with `dispatch-event' this
3676 may not be the case, but at least we make sure we won't
3677 crash. */
3678 new_chain = copy_event_chain (new_chain);
3679 tckn = event_chain_count (Vthis_command_keys);
3680 if (tckn >= n)
3681 {
3682 this_command_keys_replace_suffix
3683 (event_chain_nth (Vthis_command_keys, tckn - n),
3684 new_chain);
3685 }
3686
3687 result = command_builder_find_leaf_1 (builder);
3688 return result;
3689 }
3690
3691 signal_simple_error ((munge == MUNGE_ME_FUNCTION_KEY ?
3692 "Invalid binding in function-key-map" :
3693 "Invalid binding in key-translation-map"),
3694 result);
3695 }
3696
3697 return Qnil;
3698 }
3699
3700 /* Compare the current state of the command builder against the local and
3701 global keymaps, and return the binding. If there is no match, try again,
3702 case-insensitively. The return value will be one of:
3703 -- nil (there is no binding)
3704 -- a keymap (part of a command has been specified)
3705 -- a command (anything that satisfies `commandp'; this includes
3706 some symbols, lists, subrs, strings, vectors, and
3707 compiled-function objects)
3708 */
3709 static Lisp_Object
3710 command_builder_find_leaf (struct command_builder *builder,
3711 int allow_misc_user_events_p)
3712 {
3713 /* This function can GC */
3714 Lisp_Object result;
3715 Lisp_Object evee = builder->current_events;
3716
3717 if (XEVENT_TYPE (evee) == misc_user_event)
3718 {
3719 if (allow_misc_user_events_p && (NILP (XEVENT_NEXT (evee))))
3720 return list2 (XEVENT (evee)->event.eval.function,
3721 XEVENT (evee)->event.eval.object);
3722 else
3723 return Qnil;
3724 }
3725
3726 /* if we're currently in a menu accelerator, check there for further events */
3727 #if defined(HAVE_X_WINDOWS) && defined(LWLIB_MENUBARS_LUCID)
3728 if (lw_menu_active)
3729 {
3730 return command_builder_operate_menu_accelerator (builder);
3731 }
3732 else
3733 {
3734 result = Qnil;
3735 if (EQ (Vmenu_accelerator_enabled, Qmenu_force))
3736 result = command_builder_find_menu_accelerator (builder);
3737 if (NILP (result))
3738 #endif
3739 result = command_builder_find_leaf_1 (builder);
3740 #if defined(HAVE_X_WINDOWS) && defined(LWLIB_MENUBARS_LUCID)
3741 if (NILP (result)
3742 && EQ (Vmenu_accelerator_enabled, Qmenu_fallback))
3743 result = command_builder_find_menu_accelerator (builder);
3744 }
3745 #endif
3746
3747 /* Check to see if we have a potential function-key-map match. */
3748 if (NILP (result))
3749 {
3750 result = munge_keymap_translate (builder, MUNGE_ME_FUNCTION_KEY, 0);
3751 regenerate_echo_keys_from_this_command_keys (builder);
3752 }
3753 /* Check to see if we have a potential key-translation-map match. */
3754 {
3755 Lisp_Object key_translate_result =
3756 munge_keymap_translate (builder, MUNGE_ME_KEY_TRANSLATION,
3757 !NILP (result));
3758 if (!NILP (key_translate_result))
3759 {
3760 result = key_translate_result;
3761 regenerate_echo_keys_from_this_command_keys (builder);
3762 }
3763 }
3764
3765 if (!NILP (result))
3766 return result;
3767
3768 /* If key-sequence wasn't bound, we'll try some fallbacks. */
3769
3770 /* If we didn't find a binding, and the last event in the sequence is
3771 a shifted character, then try again with the lowercase version. */
3772
3773 if (XEVENT_TYPE (builder->most_current_event) == key_press_event
3774 && !NILP (Vretry_undefined_key_binding_unshifted))
3775 {
3776 Lisp_Object terminal = builder->most_current_event;
3777 struct key_data* key = & XEVENT (terminal)->event.key;
3778 Emchar c = 0;
3779 if ((key->modifiers & MOD_SHIFT)
3780 || (CHAR_OR_CHAR_INTP (key->keysym)
3781 && ((c = XCHAR_OR_CHAR_INT (key->keysym)), c >= 'A' && c <= 'Z')))
3782 {
3783 struct Lisp_Event terminal_copy = *XEVENT (terminal);
3784
3785 if (key->modifiers & MOD_SHIFT)
3786 key->modifiers &= (~ MOD_SHIFT);
3787 else
3788 key->keysym = make_char (c + 'a' - 'A');
3789
3790 result = command_builder_find_leaf (builder, allow_misc_user_events_p);
3791 if (!NILP (result))
3792 return result;
3793 /* If there was no match with the lower-case version either,
3794 then put back the upper-case event for the error
3795 message. But make sure that function-key-map didn't
3796 change things out from under us. */
3797 if (EQ (terminal, builder->most_current_event))
3798 *XEVENT (terminal) = terminal_copy;
3799 }
3800 }
3801
3802 /* help-char is `auto-bound' in every keymap */
3803 if (!NILP (Vprefix_help_command) &&
3804 event_matches_key_specifier_p (XEVENT (builder->most_current_event),
3805 Vhelp_char))
3806 return Vprefix_help_command;
3807
3808 #ifdef HAVE_XIM
3809 /* If keysym is a non-ASCII char, bind it to self-insert-char by default. */
3810 if (XEVENT_TYPE (builder->most_current_event) == key_press_event
3811 && !NILP (Vcomposed_character_default_binding))
3812 {
3813 Lisp_Object keysym = XEVENT (builder->most_current_event)->event.key.keysym;
3814 if (CHARP (keysym) && !CHAR_ASCII_P (XCHAR (keysym)))
3815 return Vcomposed_character_default_binding;
3816 }
3817 #endif /* HAVE_XIM */
3818
3819 /* If we read extra events attempting to match a function key but end
3820 up failing, then we release those events back to the command loop
3821 and fail on the original lookup. The released events will then be
3822 reprocessed in the context of the first part having failed. */
3823 if (!NILP (builder->last_non_munged_event))
3824 {
3825 Lisp_Object event0 = builder->last_non_munged_event;
3826
3827 /* Put the commands back on the event queue. */
3828 enqueue_event_chain (XEVENT_NEXT (event0),
3829 &command_event_queue,
3830 &command_event_queue_tail);
3831
3832 /* Then remove them from the command builder. */
3833 XSET_EVENT_NEXT (event0, Qnil);
3834 builder->most_current_event = event0;
3835 builder->last_non_munged_event = Qnil;
3836 }
3837
3838 return Qnil;
3839 }
3840
3841
3842 /* Every time a command-event (a key, button, or menu selection) is read by
3843 Fnext_event(), it is stored in the recent_keys_ring, in Vlast_input_event,
3844 and in Vthis_command_keys. (Eval-events are not stored there.)
3845
3846 Every time a command is invoked, Vlast_command_event is set to the last
3847 event in the sequence.
3848
3849 This means that Vthis_command_keys is really about "input read since the
3850 last command was executed" rather than about "what keys invoked this
3851 command." This is a little counterintuitive, but that's the way it
3852 has always worked.
3853
3854 As an extra kink, the function read-key-sequence resets/updates the
3855 last-command-event and this-command-keys. It doesn't append to the
3856 command-keys as read-char does. Such are the pitfalls of having to
3857 maintain compatibility with a program for which the only specification
3858 is the code itself.
3859
3860 (We could implement recent_keys_ring and Vthis_command_keys as the same
3861 data structure.)
3862 */
3863
3864 DEFUN ("recent-keys", Frecent_keys, 0, 1, 0, /*
3865 Return a vector of recent keyboard or mouse button events read.
3866 If NUMBER is non-nil, not more than NUMBER events will be returned.
3867 Change number of events stored using `set-recent-keys-ring-size'.
3868
3869 This copies the event objects into a new vector; it is safe to keep and
3870 modify them.
3871 */
3872 (number))
3873 {
3874 struct gcpro gcpro1;
3875 Lisp_Object val = Qnil;
3876 int nwanted;
3877 int start, nkeys, i, j;
3878 GCPRO1 (val);
3879
3880 if (NILP (number))
3881 nwanted = recent_keys_ring_size;
3882 else
3883 {
3884 CHECK_NATNUM (number);
3885 nwanted = XINT (number);
3886 }
3887
3888 /* Create the keys ring vector, if none present. */
3889 if (NILP (Vrecent_keys_ring))
3890 {
3891 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil);
3892 /* And return nothing in particular. */
3893 return make_vector (0, Qnil);
3894 }
3895
3896 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index]))
3897 /* This means the vector has not yet wrapped */
3898 {
3899 nkeys = recent_keys_ring_index;
3900 start = 0;
3901 }
3902 else
3903 {
3904 nkeys = recent_keys_ring_size;
3905 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index);
3906 }
3907
3908 if (nwanted < nkeys)
3909 {
3910 start += nkeys - nwanted;
3911 if (start >= recent_keys_ring_size)
3912 start -= recent_keys_ring_size;
3913 nkeys = nwanted;
3914 }
3915 else
3916 nwanted = nkeys;
3917
3918 val = make_vector (nwanted, Qnil);
3919
3920 for (i = 0, j = start; i < nkeys; i++)
3921 {
3922 Lisp_Object e = XVECTOR_DATA (Vrecent_keys_ring)[j];
3923
3924 if (NILP (e))
3925 abort ();
3926 XVECTOR_DATA (val)[i] = Fcopy_event (e, Qnil);
3927 if (++j >= recent_keys_ring_size)
3928 j = 0;
3929 }
3930 UNGCPRO;
3931 return val;
3932 }
3933
3934
3935 DEFUN ("recent-keys-ring-size", Frecent_keys_ring_size, 0, 0, 0, /*
3936 The maximum number of events `recent-keys' can return.
3937 */
3938 ())
3939 {
3940 return make_int (recent_keys_ring_size);
3941 }
3942
3943 DEFUN ("set-recent-keys-ring-size", Fset_recent_keys_ring_size, 1, 1, 0, /*
3944 Set the maximum number of events to be stored internally.
3945 */
3946 (size))
3947 {
3948 Lisp_Object new_vector = Qnil;
3949 int i, j, nkeys, start, min;
3950 struct gcpro gcpro1;
3951 GCPRO1 (new_vector);
3952
3953 CHECK_INT (size);
3954 if (XINT (size) <= 0)
3955 error ("Recent keys ring size must be positive");
3956 if (XINT (size) == recent_keys_ring_size)
3957 return size;
3958
3959 new_vector = make_vector (XINT (size), Qnil);
3960
3961 if (NILP (Vrecent_keys_ring))
3962 {
3963 Vrecent_keys_ring = new_vector;
3964 return size;
3965 }
3966
3967 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index]))
3968 /* This means the vector has not yet wrapped */
3969 {
3970 nkeys = recent_keys_ring_index;
3971 start = 0;
3972 }
3973 else
3974 {
3975 nkeys = recent_keys_ring_size;
3976 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index);
3977 }
3978
3979 if (XINT (size) > nkeys)
3980 min = nkeys;
3981 else
3982 min = XINT (size);
3983
3984 for (i = 0, j = start; i < min; i++)
3985 {
3986 XVECTOR_DATA (new_vector)[i] = XVECTOR_DATA (Vrecent_keys_ring)[j];
3987 if (++j >= recent_keys_ring_size)
3988 j = 0;
3989 }
3990 recent_keys_ring_size = XINT (size);
3991 recent_keys_ring_index = (i < recent_keys_ring_size) ? i : 0;
3992
3993 Vrecent_keys_ring = new_vector;
3994
3995 UNGCPRO;
3996 return size;
3997 }
3998
3999 /* Vthis_command_keys having value Qnil means that the next time
4000 push_this_command_keys is called, it should start over.
4001 The times at which the command-keys are reset
4002 (instead of merely being augmented) are pretty counterintuitive.
4003 (More specifically:
4004
4005 -- We do not reset this-command-keys when we finish reading a
4006 command. This is because some commands (e.g. C-u) act
4007 like command prefixes; they signal this by setting prefix-arg
4008 to non-nil.
4009 -- Therefore, we reset this-command-keys when we finish
4010 executing a command, unless prefix-arg is set.
4011 -- However, if we ever do a non-local exit out of a command
4012 loop (e.g. an error in a command), we need to reset
4013 this-command-keys. We do this by calling reset_this_command_keys()
4014 from cmdloop.c, whenever an error causes an invocation of the
4015 default error handler, and whenever there's a throw to top-level.)
4016 */
4017
4018 void
4019 reset_this_command_keys (Lisp_Object console, int clear_echo_area_p)
4020 {
4021 struct command_builder *command_builder =
4022 XCOMMAND_BUILDER (XCONSOLE (console)->command_builder);
4023
4024 reset_key_echo (command_builder, clear_echo_area_p);
4025
4026 deallocate_event_chain (Vthis_command_keys);
4027 Vthis_command_keys = Qnil;
4028 Vthis_command_keys_tail = Qnil;
4029
4030 reset_current_events (command_builder);
4031 }
4032
4033 static void
4034 push_this_command_keys (Lisp_Object event)
4035 {
4036 Lisp_Object new = Fmake_event (Qnil, Qnil);
4037
4038 Fcopy_event (event, new);
4039 enqueue_event (new, &Vthis_command_keys, &Vthis_command_keys_tail);
4040 }
4041
4042 /* The following two functions are used in call-interactively,
4043 for the @ and e specifications. We used to just use
4044 `current-mouse-event' (i.e. the last mouse event in this-command-keys),
4045 but FSF does it more generally so we follow their lead. */
4046
4047 Lisp_Object
4048 extract_this_command_keys_nth_mouse_event (int n)
4049 {
4050 Lisp_Object event;
4051
4052 EVENT_CHAIN_LOOP (event, Vthis_command_keys)
4053 {
4054 if (EVENTP (event)
4055 && (XEVENT_TYPE (event) == button_press_event
4056 || XEVENT_TYPE (event) == button_release_event
4057 || XEVENT_TYPE (event) == misc_user_event))
4058 {
4059 if (!n)
4060 {
4061 /* must copy to avoid an abort() in next_event_internal() */
4062 if (!NILP (XEVENT_NEXT (event)))
4063 return Fcopy_event (event, Qnil);
4064 else
4065 return event;
4066 }
4067 n--;
4068 }
4069 }
4070
4071 return Qnil;
4072 }
4073
4074 Lisp_Object
4075 extract_vector_nth_mouse_event (Lisp_Object vector, int n)
4076 {
4077 int i;
4078 int len = XVECTOR_LENGTH (vector);
4079
4080 for (i = 0; i < len; i++)
4081 {
4082 Lisp_Object event = XVECTOR_DATA (vector)[i];
4083 if (EVENTP (event))
4084 switch (XEVENT_TYPE (event))
4085 {
4086 case button_press_event :
4087 case button_release_event :
4088 case misc_user_event :
4089 if (n == 0)
4090 return event;
4091 n--;
4092 break;
4093 default:
4094 continue;
4095 }
4096 }
4097
4098 return Qnil;
4099 }
4100
4101 static void
4102 push_recent_keys (Lisp_Object event)
4103 {
4104 Lisp_Object e;
4105
4106 if (NILP (Vrecent_keys_ring))
4107 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil);
4108
4109 e = XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index];
4110
4111 if (NILP (e))
4112 {
4113 e = Fmake_event (Qnil, Qnil);
4114 XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index] = e;
4115 }
4116 Fcopy_event (event, e);
4117 if (++recent_keys_ring_index == recent_keys_ring_size)
4118 recent_keys_ring_index = 0;
4119 }
4120
4121
4122 static Lisp_Object
4123 current_events_into_vector (struct command_builder *command_builder)
4124 {
4125 Lisp_Object vector;
4126 Lisp_Object event;
4127 int n = event_chain_count (command_builder->current_events);
4128
4129 /* Copy the vector and the events in it. */
4130 /* No need to copy the events, since they're already copies, and
4131 nobody other than the command-builder has pointers to them */
4132 vector = make_vector (n, Qnil);
4133 n = 0;
4134 EVENT_CHAIN_LOOP (event, command_builder->current_events)
4135 XVECTOR_DATA (vector)[n++] = event;
4136 reset_command_builder_event_chain (command_builder);
4137 return vector;
4138 }
4139
4140
4141 /*
4142 Given the current state of the command builder and a new command event
4143 that has just been dispatched:
4144
4145 -- add the event to the event chain forming the current command
4146 (doing meta-translation as necessary)
4147 -- return the binding of this event chain; this will be one of:
4148 -- nil (there is no binding)
4149 -- a keymap (part of a command has been specified)
4150 -- a command (anything that satisfies `commandp'; this includes
4151 some symbols, lists, subrs, strings, vectors, and
4152 compiled-function objects)
4153 */
4154 static Lisp_Object
4155 lookup_command_event (struct command_builder *command_builder,
4156 Lisp_Object event, int allow_misc_user_events_p)
4157 {
4158 /* This function can GC */
4159 struct frame *f = selected_frame ();
4160 /* Clear output from previous command execution */
4161 if (!EQ (Qcommand, echo_area_status (f))
4162 /* but don't let mouse-up clear what mouse-down just printed */
4163 && (XEVENT (event)->event_type != button_release_event))
4164 clear_echo_area (f, Qnil, 0);
4165
4166 /* Add the given event to the command builder.
4167 Extra hack: this also updates the recent_keys_ring and Vthis_command_keys
4168 vectors to translate "ESC x" to "M-x" (for any "x" of course).
4169 */
4170 {
4171 Lisp_Object recent = command_builder->most_current_event;
4172
4173 if (EVENTP (recent)
4174 && event_matches_key_specifier_p (XEVENT (recent), Vmeta_prefix_char))
4175 {
4176 struct Lisp_Event *e;
4177 /* When we see a sequence like "ESC x", pretend we really saw "M-x".
4178 DoubleThink the recent-keys and this-command-keys as well. */
4179
4180 /* Modify the previous most-recently-pushed event on the command
4181 builder to be a copy of this one with the meta-bit set instead of
4182 pushing a new event.
4183 */
4184 Fcopy_event (event, recent);
4185 e = XEVENT (recent);
4186 if (e->event_type == key_press_event)
4187 e->event.key.modifiers |= MOD_META;
4188 else if (e->event_type == button_press_event
4189 || e->event_type == button_release_event)
4190 e->event.button.modifiers |= MOD_META;
4191 else
4192 abort ();
4193
4194 {
4195 int tckn = event_chain_count (Vthis_command_keys);
4196 if (tckn >= 2)
4197 /* ??? very strange if it's < 2. */
4198 this_command_keys_replace_suffix
4199 (event_chain_nth (Vthis_command_keys, tckn - 2),
4200 Fcopy_event (recent, Qnil));
4201 }
4202
4203 regenerate_echo_keys_from_this_command_keys (command_builder);
4204 }
4205 else
4206 {
4207 event = Fcopy_event (event, Fmake_event (Qnil, Qnil));
4208
4209 command_builder_append_event (command_builder, event);
4210 }
4211 }
4212
4213 {
4214 Lisp_Object leaf = command_builder_find_leaf (command_builder,
4215 allow_misc_user_events_p);
4216 struct gcpro gcpro1;
4217 GCPRO1 (leaf);
4218
4219 if (KEYMAPP (leaf))
4220 {
4221 if (!lw_menu_active)
4222 {
4223 Lisp_Object prompt = Fkeymap_prompt (leaf, Qt);
4224 if (STRINGP (prompt))
4225 {
4226 /* Append keymap prompt to key echo buffer */
4227 int buf_index = command_builder->echo_buf_index;
4228 Bytecount len = XSTRING_LENGTH (prompt);
4229
4230 if (len + buf_index + 1 <= command_builder->echo_buf_length)
4231 {
4232 Bufbyte *echo = command_builder->echo_buf + buf_index;
4233 memcpy (echo, XSTRING_DATA (prompt), len);
4234 echo[len] = 0;
4235 }
4236 maybe_echo_keys (command_builder, 1);
4237 }
4238 else
4239 maybe_echo_keys (command_builder, 0);
4240 }
4241 else if (!NILP (Vquit_flag)) {
4242 Lisp_Object quit_event = Fmake_event(Qnil, Qnil);
4243 struct Lisp_Event *e = XEVENT (quit_event);
4244 /* if quit happened during menu acceleration, pretend we read it */
4245 struct console *con = XCONSOLE (Fselected_console ());
4246 int ch = CONSOLE_QUIT_CHAR (con);
4247
4248 character_to_event (ch, e, con, 1, 1);
4249 e->channel = make_console (con);
4250
4251 enqueue_command_event (quit_event);
4252 Vquit_flag = Qnil;
4253 }
4254 }
4255 else if (!NILP (leaf))
4256 {
4257 if (EQ (Qcommand, echo_area_status (f))
4258 && command_builder->echo_buf_index > 0)
4259 {
4260 /* If we had been echoing keys, echo the last one (without
4261 the trailing dash) and redisplay before executing the
4262 command. */
4263 command_builder->echo_buf[command_builder->echo_buf_index] = 0;
4264 maybe_echo_keys (command_builder, 1);
4265 Fsit_for (Qzero, Qt);
4266 }
4267 }
4268 RETURN_UNGCPRO (leaf);
4269 }
4270 }
4271
4272 static void
4273 execute_command_event (struct command_builder *command_builder,
4274 Lisp_Object event)
4275 {
4276 /* This function can GC */
4277 struct console *con = XCONSOLE (command_builder->console);
4278 struct gcpro gcpro1;
4279
4280 GCPRO1 (event); /* event may be freshly created */
4281 reset_current_events (command_builder);
4282
4283 switch (XEVENT (event)->event_type)
4284 {
4285 case key_press_event:
4286 Vcurrent_mouse_event = Qnil;
4287 break;
4288 case button_press_event:
4289 case button_release_event:
4290 case misc_user_event:
4291 Vcurrent_mouse_event = Fcopy_event (event, Qnil);
4292 break;
4293 default: break;
4294 }
4295
4296 /* Store the last-command-event. The semantics of this is that it
4297 is the last event most recently involved in command-lookup. */
4298 if (!EVENTP (Vlast_command_event))
4299 Vlast_command_event = Fmake_event (Qnil, Qnil);
4300 if (XEVENT (Vlast_command_event)->event_type == dead_event)
4301 {
4302 Vlast_command_event = Fmake_event (Qnil, Qnil);
4303 error ("Someone deallocated the last-command-event!");
4304 }
4305
4306 if (! EQ (event, Vlast_command_event))
4307 Fcopy_event (event, Vlast_command_event);
4308
4309 /* Note that last-command-char will never have its high-bit set, in
4310 an effort to sidestep the ambiguity between M-x and oslash. */
4311 Vlast_command_char = Fevent_to_character (Vlast_command_event,
4312 Qnil, Qnil, Qnil);
4313
4314 /* Actually call the command, with all sorts of hair to preserve or clear
4315 the echo-area and region as appropriate and call the pre- and post-
4316 command-hooks. */
4317 {
4318 int old_kbd_macro = con->kbd_macro_end;
4319 struct window *w = XWINDOW (Fselected_window (Qnil));
4320
4321 /* We're executing a new command, so the old value is irrelevant. */
4322 zmacs_region_stays = 0;
4323
4324 /* If the previous command tried to force a specific window-start,
4325 reset the flag in case this command moves point far away from
4326 that position. Also, reset the window's buffer's change
4327 information so that we don't trigger an incremental update. */
4328 if (w->force_start)
4329 {
4330 w->force_start = 0;
4331 buffer_reset_changes (XBUFFER (w->buffer));
4332 }
4333
4334 pre_command_hook ();
4335
4336 if (XEVENT (event)->event_type == misc_user_event)
4337 {
4338 call1 (XEVENT (event)->event.eval.function,
4339 XEVENT (event)->event.eval.object);
4340 }
4341 else
4342 {
4343 Fcommand_execute (Vthis_command, Qnil, Qnil);
4344 }
4345
4346 post_command_hook ();
4347
4348 #if 0 /* #### here was an attempted fix that didn't work */
4349 if (XEVENT (event)->event_type == misc_user_event)
4350 ;
4351 else
4352 #endif
4353 if (!NILP (con->prefix_arg))
4354 {
4355 /* Commands that set the prefix arg don't update last-command, don't
4356 reset the echoing state, and don't go into keyboard macros unless
4357 followed by another command. */
4358 maybe_echo_keys (command_builder, 0);
4359
4360 /* If we're recording a keyboard macro, and the last command
4361 executed set a prefix argument, then decrement the pointer to
4362 the "last character really in the macro" to be just before this
4363 command. This is so that the ^U in "^U ^X )" doesn't go onto
4364 the end of macro. */
4365 if (!NILP (con->defining_kbd_macro))
4366 con->kbd_macro_end = old_kbd_macro;
4367 }
4368 else
4369 {
4370 /* Start a new command next time */
4371 Vlast_command = Vthis_command;
4372 /* Emacs 18 doesn't unconditionally clear the echoed keystrokes,
4373 so we don't either */
4374 reset_this_command_keys (make_console (con), 0);
4375 }
4376 }
4377
4378 UNGCPRO;
4379 }
4380
4381 /* Run the pre command hook. */
4382
4383 static void
4384 pre_command_hook (void)
4385 {
4386 last_point_position = BUF_PT (current_buffer);
4387 XSETBUFFER (last_point_position_buffer, current_buffer);
4388 /* This function can GC */
4389 safe_run_hook_trapping_errors
4390 ("Error in `pre-command-hook' (setting hook to nil)",
4391 Qpre_command_hook, 1);
4392 }
4393
4394 /* Run the post command hook. */
4395
4396 static void
4397 post_command_hook (void)
4398 {
4399 /* This function can GC */
4400 /* Turn off region highlighting unless this command requested that
4401 it be left on, or we're in the minibuffer. We don't turn it off
4402 when we're in the minibuffer so that things like M-x write-region
4403 still work!
4404
4405 This could be done via a function on the post-command-hook, but
4406 we don't want the user to accidentally remove it.
4407 */
4408
4409 Lisp_Object win = Fselected_window (Qnil);
4410
4411 #if 0
4412 /* If the last command deleted the frame, `win' might be nil.
4413 It seems safest to do nothing in this case. */
4414 /* ### This doesn't really fix the problem,
4415 if delete-frame is called by some hook */
4416 if (NILP (win))
4417 return;
4418 #endif
4419
4420 if (! zmacs_region_stays
4421 && (!MINI_WINDOW_P (XWINDOW (win))
4422 || EQ (zmacs_region_buffer (), WINDOW_BUFFER (XWINDOW (win)))))
4423 zmacs_deactivate_region ();
4424 else
4425 zmacs_update_region ();
4426
4427 safe_run_hook_trapping_errors
4428 ("Error in `post-command-hook' (setting hook to nil)",
4429 Qpost_command_hook, 1);
4430
4431 #ifdef DEFERRED_ACTION_CRAP
4432 if (!NILP (Vdeferred_action_list))
4433 call0 (Vdeferred_action_function);
4434 #endif
4435
4436 #ifdef ILL_CONCEIVED_HOOK
4437 if (NILP (Vunread_command_events)
4438 && NILP (Vexecuting_macro)
4439 && !NILP (Vpost_command_idle_hook)
4440 && !NILP (Fsit_for (make_float ((double) post_command_idle_delay
4441 / 1000000), Qnil)))
4442 safe_run_hook_trapping_errors
4443 ("Error in `post-command-idle-hook' (setting hook to nil)",
4444 Qpost_command_idle_hook, 1);
4445 #endif
4446
4447 #if 0 /* FSFmacs */
4448 if (!NILP (current_buffer->mark_active))
4449 {
4450 if (!NILP (Vdeactivate_mark) && !NILP (Vtransient_mark_mode))
4451 {
4452 current_buffer->mark_active = Qnil;
4453 run_hook (intern ("deactivate-mark-hook"));
4454 }
4455 else if (current_buffer != prev_buffer ||
4456 BUF_MODIFF (current_buffer) != prev_modiff)
4457 run_hook (intern ("activate-mark-hook"));
4458 }
4459 #endif /* FSFmacs */
4460
4461 /* #### Kludge!!! This is necessary to make sure that things
4462 are properly positioned even if post-command-hook moves point.
4463 #### There should be a cleaner way of handling this. */
4464 call0 (Qauto_show_make_point_visible);
4465 }
4466
4467
4468 DEFUN ("dispatch-event", Fdispatch_event, 1, 1, 0, /*
4469 Given an event object as returned by `next-event', execute it.
4470
4471 Key-press, button-press, and button-release events get accumulated
4472 until a complete key sequence (see `read-key-sequence') is reached,
4473 at which point the sequence is looked up in the current keymaps and
4474 acted upon.
4475
4476 Mouse motion events cause the low-level handling function stored in
4477 `mouse-motion-handler' to be called. (There are very few circumstances
4478 under which you should change this handler. Use `mode-motion-hook'
4479 instead.)
4480
4481 Menu, timeout, and eval events cause the associated function or handler
4482 to be called.
4483
4484 Process events cause the subprocess's output to be read and acted upon
4485 appropriately (see `start-process').
4486
4487 Magic events are handled as necessary.
4488 */
4489 (event))
4490 {
4491 /* This function can GC */
4492 struct command_builder *command_builder;
4493 struct Lisp_Event *ev;
4494 Lisp_Object console;
4495 Lisp_Object channel;
4496
4497 CHECK_LIVE_EVENT (event);
4498 ev = XEVENT (event);
4499
4500 /* events on dead channels get silently eaten */
4501 channel = EVENT_CHANNEL (ev);
4502 if (object_dead_p (channel))
4503 return Qnil;
4504
4505 /* Some events don't have channels (e.g. eval events). */
4506 console = CDFW_CONSOLE (channel);
4507 if (NILP (console))
4508 console = Vselected_console;
4509 else if (!EQ (console, Vselected_console))
4510 Fselect_console (console);
4511
4512 command_builder = XCOMMAND_BUILDER (XCONSOLE (console)->command_builder);
4513 switch (XEVENT (event)->event_type)
4514 {
4515 case button_press_event:
4516 case button_release_event:
4517 case key_press_event:
4518 {
4519 Lisp_Object leaf = lookup_command_event (command_builder, event, 1);
4520
4521 if (KEYMAPP (leaf))
4522 /* Incomplete key sequence */
4523 break;
4524 if (NILP (leaf))
4525 {
4526 /* At this point, we know that the sequence is not bound to a
4527 command. Normally, we beep and print a message informing the
4528 user of this. But we do not beep or print a message when:
4529
4530 o the last event in this sequence is a mouse-up event; or
4531 o the last event in this sequence is a mouse-down event and
4532 there is a binding for the mouse-up version.
4533
4534 That is, if the sequence ``C-x button1'' is typed, and is not
4535 bound to a command, but the sequence ``C-x button1up'' is bound
4536 to a command, we do not complain about the ``C-x button1''
4537 sequence. If neither ``C-x button1'' nor ``C-x button1up'' is
4538 bound to a command, then we complain about the ``C-x button1''
4539 sequence, but later will *not* complain about the
4540 ``C-x button1up'' sequence, which would be redundant.
4541
4542 This is pretty hairy, but I think it's the most intuitive
4543 behavior.
4544 */
4545 Lisp_Object terminal = command_builder->most_current_event;
4546
4547 if (XEVENT_TYPE (terminal) == button_press_event)
4548 {
4549 int no_bitching;
4550 /* Temporarily pretend the last event was an "up" instead of a
4551 "down", and look up its binding. */
4552 XEVENT_TYPE (terminal) = button_release_event;
4553 /* If the "up" version is bound, don't complain. */
4554 no_bitching
4555 = !NILP (command_builder_find_leaf (command_builder, 0));
4556 /* Undo the temporary changes we just made. */
4557 XEVENT_TYPE (terminal) = button_press_event;
4558 if (no_bitching)
4559 {
4560 /* Pretend this press was not seen (treat as a prefix) */
4561 if (EQ (command_builder->current_events, terminal))
4562 {
4563 reset_current_events (command_builder);
4564 }
4565 else
4566 {
4567 Lisp_Object eve;
4568
4569 EVENT_CHAIN_LOOP (eve, command_builder->current_events)
4570 if (EQ (XEVENT_NEXT (eve), terminal))
4571 break;
4572
4573 Fdeallocate_event (command_builder->
4574 most_current_event);
4575 XSET_EVENT_NEXT (eve, Qnil);
4576 command_builder->most_current_event = eve;
4577 }
4578 maybe_echo_keys (command_builder, 1);
4579 break;
4580 }
4581 }
4582
4583 /* Complain that the typed sequence is not defined, if this is the
4584 kind of sequence that warrants a complaint. */
4585 XCONSOLE (console)->defining_kbd_macro = Qnil;
4586 XCONSOLE (console)->prefix_arg = Qnil;
4587 /* Don't complain about undefined button-release events */
4588 if (XEVENT_TYPE (terminal) != button_release_event)
4589 {
4590 Lisp_Object keys = current_events_into_vector (command_builder);
4591 struct gcpro gcpro1;
4592
4593 /* Run the pre-command-hook before barfing about an undefined
4594 key. */
4595 Vthis_command = Qnil;
4596 GCPRO1 (keys);
4597 pre_command_hook ();
4598 UNGCPRO;
4599 /* The post-command-hook doesn't run. */
4600 Fsignal (Qundefined_keystroke_sequence, list1 (keys));
4601 }
4602 /* Reset the command builder for reading the next sequence. */
4603 reset_this_command_keys (console, 1);
4604 }
4605 else /* key sequence is bound to a command */
4606 {
4607 Vthis_command = leaf;
4608 /* Don't push an undo boundary if the command set the prefix arg,
4609 or if we are executing a keyboard macro, or if in the
4610 minibuffer. If the command we are about to execute is
4611 self-insert, it's tricky: up to 20 consecutive self-inserts may
4612 be done without an undo boundary. This counter is reset as
4613 soon as a command other than self-insert-command is executed.
4614 */
4615 if (! EQ (leaf, Qself_insert_command))
4616 command_builder->self_insert_countdown = 0;
4617 if (NILP (XCONSOLE (console)->prefix_arg)
4618 && NILP (Vexecuting_macro)
4619 #if 0
4620 /* This was done in the days when there was no undo
4621 in the minibuffer. If we don't disable this code,
4622 then each instance of "undo" undoes everything in
4623 the minibuffer. */
4624 && !EQ (minibuf_window, Fselected_window (Qnil))
4625 #endif
4626 && command_builder->self_insert_countdown == 0)
4627 Fundo_boundary ();
4628
4629 if (EQ (leaf, Qself_insert_command))
4630 {
4631 if (--command_builder->self_insert_countdown < 0)
4632 command_builder->self_insert_countdown = 20;
4633 }
4634 execute_command_event
4635 (command_builder,
4636 internal_equal (event, command_builder-> most_current_event, 0)
4637 ? event
4638 /* Use the translated event that was most recently seen.
4639 This way, last-command-event becomes f1 instead of
4640 the P from ESC O P. But we must copy it, else we'll
4641 lose when the command-builder events are deallocated. */
4642 : Fcopy_event (command_builder-> most_current_event, Qnil));
4643 }
4644 break;
4645 }
4646 case misc_user_event:
4647 {
4648 /* Jamie said:
4649
4650 We could just always use the menu item entry, whatever it is, but
4651 this might break some Lisp code that expects `this-command' to
4652 always contain a symbol. So only store it if this is a simple
4653 `call-interactively' sort of menu item.
4654
4655 But this is bogus. `this-command' could be a string or vector
4656 anyway (for keyboard macros). There's even one instance
4657 (in pending-del.el) of `this-command' getting set to a cons
4658 (a lambda expression). So in the `eval' case I'll just
4659 convert it into a lambda expression.
4660 */
4661 if (EQ (XEVENT (event)->event.eval.function, Qcall_interactively)
4662 && SYMBOLP (XEVENT (event)->event.eval.object))
4663 Vthis_command = XEVENT (event)->event.eval.object;
4664 else if (EQ (XEVENT (event)->event.eval.function, Qeval))
4665 Vthis_command =
4666 Fcons (Qlambda, Fcons (Qnil, XEVENT (event)->event.eval.object));
4667 else if (SYMBOLP (XEVENT (event)->event.eval.function))
4668 /* A scrollbar command or the like. */
4669 Vthis_command = XEVENT (event)->event.eval.function;
4670 else
4671 /* Huh? */
4672 Vthis_command = Qnil;
4673
4674 /* clear the echo area */
4675 reset_key_echo (command_builder, 1);
4676
4677 command_builder->self_insert_countdown = 0;
4678 if (NILP (XCONSOLE (console)->prefix_arg)
4679 && NILP (Vexecuting_macro)
4680 && !EQ (minibuf_window, Fselected_window (Qnil)))
4681 Fundo_boundary ();
4682 execute_command_event (command_builder, event);
4683 break;
4684 }
4685 default:
4686 {
4687 execute_internal_event (event);
4688 break;
4689 }
4690 }
4691 return Qnil;
4692 }
4693
4694 DEFUN ("read-key-sequence", Fread_key_sequence, 1, 3, 0, /*
4695 Read a sequence of keystrokes or mouse clicks.
4696 Returns a vector of the event objects read. The vector and the event
4697 objects it contains are freshly created (and will not be side-effected
4698 by subsequent calls to this function).
4699
4700 The sequence read is sufficient to specify a non-prefix command starting
4701 from the current local and global keymaps. A C-g typed while in this
4702 function is treated like any other character, and `quit-flag' is not set.
4703
4704 First arg PROMPT is a prompt string. If nil, do not prompt specially.
4705 Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echoes
4706 as a continuation of the previous key.
4707
4708 The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not
4709 convert the last event to lower case. (Normally any upper case event
4710 is converted to lower case if the original event is undefined and the lower
4711 case equivalent is defined.) This argument is provided mostly for
4712 FSF compatibility; the equivalent effect can be achieved more generally
4713 by binding `retry-undefined-key-binding-unshifted' to nil around the
4714 call to `read-key-sequence'.
4715
4716 A C-g typed while in this function is treated like any other character,
4717 and `quit-flag' is not set.
4718
4719 If the user selects a menu item while we are prompting for a key-sequence,
4720 the returned value will be a vector of a single menu-selection event.
4721 An error will be signalled if you pass this value to `lookup-key' or a
4722 related function.
4723
4724 `read-key-sequence' checks `function-key-map' for function key
4725 sequences, where they wouldn't conflict with ordinary bindings. See
4726 `function-key-map' for more details.
4727 */
4728 (prompt, continue_echo, dont_downcase_last))
4729 {
4730 /* This function can GC */
4731 struct console *con = XCONSOLE (Vselected_console); /* #### correct?
4732 Probably not -- see
4733 comment in
4734 next-event */
4735 struct command_builder *command_builder =
4736 XCOMMAND_BUILDER (con->command_builder);
4737 Lisp_Object result;
4738 Lisp_Object event = Fmake_event (Qnil, Qnil);
4739 int speccount = specpdl_depth ();
4740 struct gcpro gcpro1;
4741 GCPRO1 (event);
4742
4743 if (!NILP (prompt))
4744 CHECK_STRING (prompt);
4745 /* else prompt = Fkeymap_prompt (current_buffer->keymap); may GC */
4746 QUIT;
4747
4748 if (NILP (continue_echo))
4749 reset_this_command_keys (make_console (con), 1);
4750
4751 specbind (Qinhibit_quit, Qt);
4752
4753 if (!NILP (dont_downcase_last))
4754 specbind (Qretry_undefined_key_binding_unshifted, Qnil);
4755
4756 for (;;)
4757 {
4758 Fnext_event (event, prompt);
4759 /* restore the selected-console damage */
4760 con = event_console_or_selected (event);
4761 command_builder = XCOMMAND_BUILDER (con->command_builder);
4762 if (! command_event_p (event))
4763 execute_internal_event (event);
4764 else
4765 {
4766 if (XEVENT (event)->event_type == misc_user_event)
4767 reset_current_events (command_builder);
4768 result = lookup_command_event (command_builder, event, 1);
4769 if (!KEYMAPP (result))
4770 {
4771 result = current_events_into_vector (command_builder);
4772 reset_key_echo (command_builder, 0);
4773 break;
4774 }
4775 prompt = Qnil;
4776 }
4777 }
4778
4779 Vquit_flag = Qnil; /* In case we read a ^G; do not call check_quit() here */
4780 Fdeallocate_event (event);
4781 RETURN_UNGCPRO (unbind_to (speccount, result));
4782 }
4783
4784 DEFUN ("this-command-keys", Fthis_command_keys, 0, 0, 0, /*
4785 Return a vector of the keyboard or mouse button events that were used
4786 to invoke this command. This copies the vector and the events; it is safe
4787 to keep and modify them.
4788 */
4789 ())
4790 {
4791 Lisp_Object event;
4792 Lisp_Object result;
4793 int len;
4794
4795 if (NILP (Vthis_command_keys))
4796 return make_vector (0, Qnil);
4797
4798 len = event_chain_count (Vthis_command_keys);
4799
4800 result = make_vector (len, Qnil);
4801 len = 0;
4802 EVENT_CHAIN_LOOP (event, Vthis_command_keys)
4803 XVECTOR_DATA (result)[len++] = Fcopy_event (event, Qnil);
4804 return result;
4805 }
4806
4807 DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, 0, 0, 0, /*
4808 Used for complicated reasons in `universal-argument-other-key'.
4809
4810 `universal-argument-other-key' rereads the event just typed.
4811 It then gets translated through `function-key-map'.
4812 The translated event gets included in the echo area and in
4813 the value of `this-command-keys' in addition to the raw original event.
4814 That is not right.
4815
4816 Calling this function directs the translated event to replace
4817 the original event, so that only one version of the event actually
4818 appears in the echo area and in the value of `this-command-keys.'.
4819 */
4820 ())
4821 {
4822 /* #### I don't understand this at all, so currently it does nothing.
4823 If there is ever a problem, maybe someone should investigate. */
4824 return Qnil;
4825 }
4826
4827
4828 static void
4829 dribble_out_event (Lisp_Object event)
4830 {
4831 if (NILP (Vdribble_file))
4832 return;
4833
4834 if (XEVENT (event)->event_type == key_press_event &&
4835 !XEVENT (event)->event.key.modifiers)
4836 {
4837 Lisp_Object keysym = XEVENT (event)->event.key.keysym;
4838 if (CHARP (XEVENT (event)->event.key.keysym))
4839 {
4840 Emchar ch = XCHAR (keysym);
4841 Bufbyte str[MAX_EMCHAR_LEN];
4842 Bytecount len = set_charptr_emchar (str, ch);
4843 Lstream_write (XLSTREAM (Vdribble_file), str, len);
4844 }
4845 else if (string_char_length (XSYMBOL (keysym)->name) == 1)
4846 /* one-char key events are printed with just the key name */
4847 Fprinc (keysym, Vdribble_file);
4848 else if (EQ (keysym, Qreturn))
4849 Lstream_putc (XLSTREAM (Vdribble_file), '\n');
4850 else if (EQ (keysym, Qspace))
4851 Lstream_putc (XLSTREAM (Vdribble_file), ' ');
4852 else
4853 Fprinc (event, Vdribble_file);
4854 }
4855 else
4856 Fprinc (event, Vdribble_file);
4857 Lstream_flush (XLSTREAM (Vdribble_file));
4858 }
4859
4860 DEFUN ("open-dribble-file", Fopen_dribble_file, 1, 1,
4861 "FOpen dribble file: ", /*
4862 Start writing all keyboard characters to a dribble file called FILE.
4863 If FILE is nil, close any open dribble file.
4864 */
4865 (file))
4866 {
4867 /* This function can GC */
4868 /* XEmacs change: always close existing dribble file. */
4869 /* FSFmacs uses FILE *'s here. With lstreams, that's unnecessary. */
4870 if (!NILP (Vdribble_file))
4871 {
4872 Lstream_close (XLSTREAM (Vdribble_file));
4873 Vdribble_file = Qnil;
4874 }
4875 if (!NILP (file))
4876 {
4877 int fd;
4878
4879 file = Fexpand_file_name (file, Qnil);
4880 fd = open ((char*) XSTRING_DATA (file),
4881 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4882 CREAT_MODE);
4883 if (fd < 0)
4884 error ("Unable to create dribble file");
4885 Vdribble_file = make_filedesc_output_stream (fd, 0, 0, LSTR_CLOSING);
4886 #ifdef MULE
4887 Vdribble_file =
4888 make_encoding_output_stream (XLSTREAM (Vdribble_file),
4889 Fget_coding_system (Qescape_quoted));
4890 #endif
4891 }
4892 return Qnil;
4893 }
4894
4895
4896 /************************************************************************/
4897 /* initialization */
4898 /************************************************************************/
4899
4900 void
4901 syms_of_event_stream (void)
4902 {
4903 defsymbol (&Qdisabled, "disabled");
4904 defsymbol (&Qcommand_event_p, "command-event-p");
4905
4906 deferror (&Qundefined_keystroke_sequence, "undefined-keystroke-sequence",
4907 "Undefined keystroke sequence", Qerror);
4908
4909 DEFSUBR (Frecent_keys);
4910 DEFSUBR (Frecent_keys_ring_size);
4911 DEFSUBR (Fset_recent_keys_ring_size);
4912 DEFSUBR (Finput_pending_p);
4913 DEFSUBR (Fenqueue_eval_event);
4914 DEFSUBR (Fnext_event);
4915 DEFSUBR (Fnext_command_event);
4916 DEFSUBR (Fdiscard_input);
4917 DEFSUBR (Fsit_for);
4918 DEFSUBR (Fsleep_for);
4919 DEFSUBR (Faccept_process_output);
4920 DEFSUBR (Fadd_timeout);
4921 DEFSUBR (Fdisable_timeout);
4922 DEFSUBR (Fadd_async_timeout);
4923 DEFSUBR (Fdisable_async_timeout);
4924 DEFSUBR (Fdispatch_event);
4925 DEFSUBR (Fread_key_sequence);
4926 DEFSUBR (Fthis_command_keys);
4927 DEFSUBR (Freset_this_command_lengths);
4928 DEFSUBR (Fopen_dribble_file);
4929 #if defined(HAVE_X_WINDOWS) && defined(LWLIB_MENUBARS_LUCID)
4930 DEFSUBR (Faccelerate_menu);
4931 #endif
4932
4933 defsymbol (&Qpre_command_hook, "pre-command-hook");
4934 defsymbol (&Qpost_command_hook, "post-command-hook");
4935 defsymbol (&Qunread_command_events, "unread-command-events");
4936 defsymbol (&Qunread_command_event, "unread-command-event");
4937 defsymbol (&Qpre_idle_hook, "pre-idle-hook");
4938 #ifdef ILL_CONCEIVED_HOOK
4939 defsymbol (&Qpost_command_idle_hook, "post-command-idle-hook");
4940 #endif
4941 #ifdef DEFERRED_ACTION_CRAP
4942 defsymbol (&Qdeferred_action_function, "deferred-action-function");
4943 #endif
4944 defsymbol (&Qretry_undefined_key_binding_unshifted,
4945 "retry-undefined-key-binding-unshifted");
4946 defsymbol (&Qauto_show_make_point_visible,
4947 "auto-show-make-point-visible");
4948
4949 defsymbol (&Qmenu_force, "menu-force");
4950 defsymbol (&Qmenu_fallback, "menu-fallback");
4951
4952 defsymbol (&Qmenu_quit, "menu-quit");
4953 defsymbol (&Qmenu_up, "menu-up");
4954 defsymbol (&Qmenu_down, "menu-down");
4955 defsymbol (&Qmenu_left, "menu-left");
4956 defsymbol (&Qmenu_right, "menu-right");
4957 defsymbol (&Qmenu_select, "menu-select");
4958 defsymbol (&Qmenu_escape, "menu-escape");
4959
4960 defsymbol (&Qcancel_mode_internal, "cancel-mode-internal");
4961 }
4962
4963 void
4964 reinit_vars_of_event_stream (void)
4965 {
4966 recent_keys_ring_index = 0;
4967 recent_keys_ring_size = 100;
4968 num_input_chars = 0;
4969 Vtimeout_free_list = make_lcrecord_list (sizeof (struct Lisp_Timeout),
4970 &lrecord_timeout);
4971 staticpro_nodump (&Vtimeout_free_list);
4972 the_low_level_timeout_blocktype =
4973 Blocktype_new (struct low_level_timeout_blocktype);
4974 something_happened = 0;
4975 recursive_sit_for = Qnil;
4976 }
4977
4978 void
4979 vars_of_event_stream (void)
4980 {
4981 reinit_vars_of_event_stream ();
4982 Vrecent_keys_ring = Qnil;
4983 staticpro (&Vrecent_keys_ring);
4984
4985 Vthis_command_keys = Qnil;
4986 staticpro (&Vthis_command_keys);
4987 Vthis_command_keys_tail = Qnil;
4988 pdump_wire (&Vthis_command_keys_tail);
4989
4990 command_event_queue = Qnil;
4991 staticpro (&command_event_queue);
4992 command_event_queue_tail = Qnil;
4993 pdump_wire (&command_event_queue_tail);
4994
4995 Vlast_selected_frame = Qnil;
4996 staticpro (&Vlast_selected_frame);
4997
4998 pending_timeout_list = Qnil;
4999 staticpro (&pending_timeout_list);
5000
5001 pending_async_timeout_list = Qnil;
5002 staticpro (&pending_async_timeout_list);
5003
5004 last_point_position_buffer = Qnil;
5005 staticpro (&last_point_position_buffer);
5006
5007 DEFVAR_LISP ("echo-keystrokes", &Vecho_keystrokes /*
5008 *Nonzero means echo unfinished commands after this many seconds of pause.
5009 */ );
5010 Vecho_keystrokes = make_int (1);
5011
5012 DEFVAR_INT ("auto-save-interval", &auto_save_interval /*
5013 *Number of keyboard input characters between auto-saves.
5014 Zero means disable autosaving due to number of characters typed.
5015 See also the variable `auto-save-timeout'.
5016 */ );
5017 auto_save_interval = 300;
5018
5019 DEFVAR_LISP ("pre-command-hook", &Vpre_command_hook /*
5020 Function or functions to run before every command.
5021 This may examine the `this-command' variable to find out what command
5022 is about to be run, or may change it to cause a different command to run.
5023 Function on this hook must be careful to avoid signalling errors!
5024 */ );
5025 Vpre_command_hook = Qnil;
5026
5027 DEFVAR_LISP ("post-command-hook", &Vpost_command_hook /*
5028 Function or functions to run after every command.
5029 This may examine the `this-command' variable to find out what command
5030 was just executed.
5031 */ );
5032 Vpost_command_hook = Qnil;
5033
5034 DEFVAR_LISP ("pre-idle-hook", &Vpre_idle_hook /*
5035 Normal hook run when XEmacs it about to be idle.
5036 This occurs whenever it is going to block, waiting for an event.
5037 This generally happens as a result of a call to `next-event',
5038 `next-command-event', `sit-for', `sleep-for', `accept-process-output',
5039 `x-get-selection', or various Energize-specific commands.
5040 Errors running the hook are caught and ignored.
5041 */ );
5042 Vpre_idle_hook = Qnil;
5043
5044 DEFVAR_BOOL ("focus-follows-mouse", &focus_follows_mouse /*
5045 *Variable to control XEmacs behavior with respect to focus changing.
5046 If this variable is set to t, then XEmacs will not gratuitously change
5047 the keyboard focus. XEmacs cannot in general detect when this mode is
5048 used by the window manager, so it is up to the user to set it.
5049 */ );
5050 focus_follows_mouse = 0;
5051
5052 #ifdef ILL_CONCEIVED_HOOK
5053 /* Ill-conceived because it's not run in all sorts of cases
5054 where XEmacs is blocking. That's what `pre-idle-hook'
5055 is designed to solve. */
5056 xxDEFVAR_LISP ("post-command-idle-hook", &Vpost_command_idle_hook /*
5057 Normal hook run after each command is executed, if idle.
5058 `post-command-idle-delay' specifies a time in microseconds that XEmacs
5059 must be idle for in order for the functions on this hook to be called.
5060 Errors running the hook are caught and ignored.
5061 */ );
5062 Vpost_command_idle_hook = Qnil;
5063
5064 xxDEFVAR_INT ("post-command-idle-delay", &post_command_idle_delay /*
5065 Delay time before running `post-command-idle-hook'.
5066 This is measured in microseconds.
5067 */ );
5068 post_command_idle_delay = 5000;
5069 #endif /* ILL_CONCEIVED_HOOK */
5070
5071 #ifdef DEFERRED_ACTION_CRAP
5072 /* Random FSFmacs crap. There is absolutely nothing to gain,
5073 and a great deal to lose, in using this in place of just
5074 setting `post-command-hook'. */
5075 xxDEFVAR_LISP ("deferred-action-list", &Vdeferred_action_list /*
5076 List of deferred actions to be performed at a later time.
5077 The precise format isn't relevant here; we just check whether it is nil.
5078 */ );
5079 Vdeferred_action_list = Qnil;
5080
5081 xxDEFVAR_LISP ("deferred-action-function", &Vdeferred_action_function /*
5082 Function to call to handle deferred actions, after each command.
5083 This function is called with no arguments after each command
5084 whenever `deferred-action-list' is non-nil.
5085 */ );
5086 Vdeferred_action_function = Qnil;
5087 #endif /* DEFERRED_ACTION_CRAP */
5088
5089 DEFVAR_LISP ("last-command-event", &Vlast_command_event /*
5090 Last keyboard or mouse button event that was part of a command. This
5091 variable is off limits: you may not set its value or modify the event that
5092 is its value, as it is destructively modified by `read-key-sequence'. If
5093 you want to keep a pointer to this value, you must use `copy-event'.
5094 */ );
5095 Vlast_command_event = Qnil;
5096
5097 DEFVAR_LISP ("last-command-char", &Vlast_command_char /*
5098 If the value of `last-command-event' is a keyboard event, then
5099 this is the nearest ASCII equivalent to it. This is the value that
5100 `self-insert-command' will put in the buffer. Remember that there is
5101 NOT a 1:1 mapping between keyboard events and ASCII characters: the set
5102 of keyboard events is much larger, so writing code that examines this
5103 variable to determine what key has been typed is bad practice, unless
5104 you are certain that it will be one of a small set of characters.
5105 */ );
5106 Vlast_command_char = Qnil;
5107
5108 DEFVAR_LISP ("last-input-event", &Vlast_input_event /*
5109 Last keyboard or mouse button event received. This variable is off
5110 limits: you may not set its value or modify the event that is its value, as
5111 it is destructively modified by `next-event'. If you want to keep a pointer
5112 to this value, you must use `copy-event'.
5113 */ );
5114 Vlast_input_event = Qnil;
5115
5116 DEFVAR_LISP ("current-mouse-event", &Vcurrent_mouse_event /*
5117 The mouse-button event which invoked this command, or nil.
5118 This is usually what `(interactive "e")' returns.
5119 */ );
5120 Vcurrent_mouse_event = Qnil;
5121
5122 DEFVAR_LISP ("last-input-char", &Vlast_input_char /*
5123 If the value of `last-input-event' is a keyboard event, then
5124 this is the nearest ASCII equivalent to it. Remember that there is
5125 NOT a 1:1 mapping between keyboard events and ASCII characters: the set
5126 of keyboard events is much larger, so writing code that examines this
5127 variable to determine what key has been typed is bad practice, unless
5128 you are certain that it will be one of a small set of characters.
5129 */ );
5130 Vlast_input_char = Qnil;
5131
5132 DEFVAR_LISP ("last-input-time", &Vlast_input_time /*
5133 The time (in seconds since Jan 1, 1970) of the last-command-event,
5134 represented as a cons of two 16-bit integers. This is destructively
5135 modified, so copy it if you want to keep it.
5136 */ );
5137 Vlast_input_time = Qnil;
5138
5139 DEFVAR_LISP ("last-command-event-time", &Vlast_command_event_time /*
5140 The time (in seconds since Jan 1, 1970) of the last-command-event,
5141 represented as a list of three integers. The first integer contains
5142 the most significant 16 bits of the number of seconds, and the second
5143 integer contains the least significant 16 bits. The third integer
5144 contains the remainder number of microseconds, if the current system
5145 supports microsecond clock resolution. This list is destructively
5146 modified, so copy it if you want to keep it.
5147 */ );
5148 Vlast_command_event_time = Qnil;
5149
5150 DEFVAR_LISP ("unread-command-events", &Vunread_command_events /*
5151 List of event objects to be read as next command input events.
5152 This can be used to simulate the receipt of events from the user.
5153 Normally this is nil.
5154 Events are removed from the front of this list.
5155 */ );
5156 Vunread_command_events = Qnil;
5157
5158 DEFVAR_LISP ("unread-command-event", &Vunread_command_event /*
5159 Obsolete. Use `unread-command-events' instead.
5160 */ );
5161 Vunread_command_event = Qnil;
5162
5163 DEFVAR_LISP ("last-command", &Vlast_command /*
5164 The last command executed. Normally a symbol with a function definition,
5165 but can be whatever was found in the keymap, or whatever the variable
5166 `this-command' was set to by that command.
5167 */ );
5168 Vlast_command = Qnil;
5169
5170 DEFVAR_LISP ("this-command", &Vthis_command /*
5171 The command now being executed.
5172 The command can set this variable; whatever is put here
5173 will be in `last-command' during the following command.
5174 */ );
5175 Vthis_command = Qnil;
5176
5177 DEFVAR_LISP ("help-char", &Vhelp_char /*
5178 Character to recognize as meaning Help.
5179 When it is read, do `(eval help-form)', and display result if it's a string.
5180 If the value of `help-form' is nil, this char can be read normally.
5181 This can be any form recognized as a single key specifier.
5182 The help-char cannot be a negative number in XEmacs.
5183 */ );
5184 Vhelp_char = make_char (8); /* C-h */
5185
5186 DEFVAR_LISP ("help-form", &Vhelp_form /*
5187 Form to execute when character help-char is read.
5188 If the form returns a string, that string is displayed.
5189 If `help-form' is nil, the help char is not recognized.
5190 */ );
5191 Vhelp_form = Qnil;
5192
5193 DEFVAR_LISP ("prefix-help-command", &Vprefix_help_command /*
5194 Command to run when `help-char' character follows a prefix key.
5195 This command is used only when there is no actual binding
5196 for that character after that prefix key.
5197 */ );
5198 Vprefix_help_command = Qnil;
5199
5200 DEFVAR_CONST_LISP ("keyboard-translate-table", &Vkeyboard_translate_table /*
5201 Hash table used as translate table for keyboard input.
5202 Use `keyboard-translate' to portably add entries to this table.
5203 Each key-press event is looked up in this table as follows:
5204
5205 -- If an entry maps a symbol to a symbol, then a key-press event whose
5206 keysym is the former symbol (with any modifiers at all) gets its
5207 keysym changed and its modifiers left alone. This is useful for
5208 dealing with non-standard X keyboards, such as the grievous damage
5209 that Sun has inflicted upon the world.
5210 -- If an entry maps a character to a character, then a key-press event
5211 matching the former character gets converted to a key-press event
5212 matching the latter character. This is useful on ASCII terminals
5213 for (e.g.) making C-\\ look like C-s, to get around flow-control
5214 problems.
5215 -- If an entry maps a character to a symbol, then a key-press event
5216 matching the character gets converted to a key-press event whose
5217 keysym is the given symbol and which has no modifiers.
5218 */ );
5219
5220 DEFVAR_LISP ("retry-undefined-key-binding-unshifted",
5221 &Vretry_undefined_key_binding_unshifted /*
5222 If a key-sequence which ends with a shifted keystroke is undefined
5223 and this variable is non-nil then the command lookup is retried again
5224 with the last key unshifted. (e.g. C-X C-F would be retried as C-X C-f.)
5225 If lookup still fails, a normal error is signalled. In general,
5226 you should *bind* this, not set it.
5227 */ );
5228 Vretry_undefined_key_binding_unshifted = Qt;
5229
5230 #ifdef HAVE_XIM
5231 DEFVAR_LISP ("composed-character-default-binding",
5232 &Vcomposed_character_default_binding /*
5233 The default keybinding to use for key events from composed input.
5234 Window systems frequently have ways to allow the user to compose
5235 single characters in a language using multiple keystrokes.
5236 XEmacs sees these as single character keypress events.
5237 */ );
5238 Vcomposed_character_default_binding = Qself_insert_command;
5239 #endif /* HAVE_XIM */
5240
5241 Vcontrolling_terminal = Qnil;
5242 staticpro (&Vcontrolling_terminal);
5243
5244 Vdribble_file = Qnil;
5245 staticpro (&Vdribble_file);
5246
5247 #ifdef DEBUG_XEMACS
5248 DEFVAR_INT ("debug-emacs-events", &debug_emacs_events /*
5249 If non-zero, display debug information about Emacs events that XEmacs sees.
5250 Information is displayed on stderr.
5251
5252 Before the event, the source of the event is displayed in parentheses,
5253 and is one of the following:
5254
5255 \(real) A real event from the window system or
5256 terminal driver, as far as XEmacs can tell.
5257
5258 \(keyboard macro) An event generated from a keyboard macro.
5259
5260 \(unread-command-events) An event taken from `unread-command-events'.
5261
5262 \(unread-command-event) An event taken from `unread-command-event'.
5263
5264 \(command event queue) An event taken from an internal queue.
5265 Events end up on this queue when
5266 `enqueue-eval-event' is called or when
5267 user or eval events are received while
5268 XEmacs is blocking (e.g. in `sit-for',
5269 `sleep-for', or `accept-process-output',
5270 or while waiting for the reply to an
5271 X selection).
5272
5273 \(->keyboard-translate-table) The result of an event translated through
5274 keyboard-translate-table. Note that in
5275 this case, two events are printed even
5276 though only one is really generated.
5277
5278 \(SIGINT) A faked C-g resulting when XEmacs receives
5279 a SIGINT (e.g. C-c was pressed in XEmacs'
5280 controlling terminal or the signal was
5281 explicitly sent to the XEmacs process).
5282 */ );
5283 debug_emacs_events = 0;
5284 #endif
5285
5286 DEFVAR_BOOL ("inhibit-input-event-recording", &inhibit_input_event_recording /*
5287 Non-nil inhibits recording of input-events to recent-keys ring.
5288 */ );
5289 inhibit_input_event_recording = 0;
5290
5291 DEFVAR_LISP("menu-accelerator-prefix", &Vmenu_accelerator_prefix /*
5292 Prefix key(s) that must be typed before menu accelerators will be activated.
5293 Set this to a value acceptable by define-key.
5294 */ );
5295 Vmenu_accelerator_prefix = Qnil;
5296
5297 DEFVAR_LISP ("menu-accelerator-modifiers", &Vmenu_accelerator_modifiers /*
5298 Modifier keys which must be pressed to get to the top level menu accelerators.
5299 This is a list of modifier key symbols. All modifier keys must be held down
5300 while a valid menu accelerator key is pressed in order for the top level
5301 menu to become active.
5302
5303 See also menu-accelerator-enabled and menu-accelerator-prefix.
5304 */ );
5305 Vmenu_accelerator_modifiers = list1 (Qmeta);
5306
5307 DEFVAR_LISP ("menu-accelerator-enabled", &Vmenu_accelerator_enabled /*
5308 Whether menu accelerator keys can cause the menubar to become active.
5309 If 'menu-force or 'menu-fallback, then menu accelerator keys can
5310 be used to activate the top level menu. Once the menubar becomes active, the
5311 accelerator keys can be used regardless of the value of this variable.
5312
5313 menu-force is used to indicate that the menu accelerator key takes
5314 precedence over bindings in the current keymap(s). menu-fallback means
5315 that bindings in the current keymap take precedence over menu accelerator keys.
5316 Thus a top level menu with an accelerator of "T" would be activated on a
5317 keypress of Meta-t if menu-accelerator-enabled is menu-force.
5318 However, if menu-accelerator-enabled is menu-fallback, then
5319 Meta-t will not activate the menubar and will instead run the function
5320 transpose-words, to which it is normally bound.
5321
5322 See also menu-accelerator-modifiers and menu-accelerator-prefix.
5323 */ );
5324 Vmenu_accelerator_enabled = Qnil;
5325 }
5326
5327 void
5328 complex_vars_of_event_stream (void)
5329 {
5330 Vkeyboard_translate_table =
5331 make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
5332
5333 DEFVAR_LISP ("menu-accelerator-map", &Vmenu_accelerator_map /*
5334 Keymap for use when the menubar is active.
5335 The actions menu-quit, menu-up, menu-down, menu-left, menu-right,
5336 menu-select and menu-escape can be mapped to keys in this map.
5337
5338 menu-quit Immediately deactivate the menubar and any open submenus without
5339 selecting an item.
5340 menu-up Move the menu cursor up one row in the current menu. If the
5341 move extends past the top of the menu, wrap around to the bottom.
5342 menu-down Move the menu cursor down one row in the current menu. If the
5343 move extends past the bottom of the menu, wrap around to the top.
5344 If executed while the cursor is in the top level menu, move down
5345 into the selected menu.
5346 menu-left Move the cursor from a submenu into the parent menu. If executed
5347 while the cursor is in the top level menu, move the cursor to the
5348 left. If the move extends past the left edge of the menu, wrap
5349 around to the right edge.
5350 menu-right Move the cursor into a submenu. If the cursor is located in the
5351 top level menu or is not currently on a submenu heading, then move
5352 the cursor to the next top level menu entry. If the move extends
5353 past the right edge of the menu, wrap around to the left edge.
5354 menu-select Activate the item under the cursor. If the cursor is located on
5355 a submenu heading, then move the cursor into the submenu.
5356 menu-escape Pop up to the next level of menus. Moves from a submenu into its
5357 parent menu. From the top level menu, this deactivates the
5358 menubar.
5359
5360 This keymap can also contain normal key-command bindings, in which case the
5361 menubar is deactivated and the corresponding command is executed.
5362
5363 The action bindings used by the menu accelerator code are designed to mimic
5364 the actions of menu traversal keys in a commonly used PC operating system.
5365 */ );
5366 Vmenu_accelerator_map = Fmake_keymap(Qnil);
5367 }
5368
5369 void
5370 init_event_stream (void)
5371 {
5372 if (initialized)
5373 {
5374 #ifdef HAVE_UNIXOID_EVENT_LOOP
5375 init_event_unixoid ();
5376 #endif
5377 #ifdef HAVE_X_WINDOWS
5378 if (!strcmp (display_use, "x"))
5379 init_event_Xt_late ();
5380 else
5381 #endif
5382 #ifdef HAVE_MS_WINDOWS
5383 if (!strcmp (display_use, "mswindows"))
5384 init_event_mswindows_late ();
5385 else
5386 #endif
5387 {
5388 /* For TTY's, use the Xt event loop if we can; it allows
5389 us to later open an X connection. */
5390 #if defined (HAVE_MS_WINDOWS) && (!defined (HAVE_TTY) \
5391 || (defined (HAVE_MSG_SELECT) \
5392 && !defined (DEBUG_TTY_EVENT_STREAM)))
5393 init_event_mswindows_late ();
5394 #elif defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM)
5395 init_event_Xt_late ();
5396 #elif defined (HAVE_TTY)
5397 init_event_tty_late ();
5398 #endif
5399 }
5400 init_interrupts_late ();
5401 }
5402 }
5403
5404
5405 /*
5406 useful testcases for v18/v19 compatibility:
5407
5408 (defun foo ()
5409 (interactive)
5410 (setq unread-command-event (character-to-event ?A (allocate-event)))
5411 (setq x (list (read-char)
5412 ; (read-key-sequence "") ; try it with and without this
5413 last-command-char last-input-char
5414 (recent-keys) (this-command-keys))))
5415 (global-set-key "\^Q" 'foo)
5416
5417 without the read-key-sequence:
5418 ^Q ==> (65 17 65 [... ^Q] [^Q])
5419 ^U^U^Q ==> (65 17 65 [... ^U ^U ^Q] [^U ^U ^Q])
5420 ^U^U^U^G^Q ==> (65 17 65 [... ^U ^U ^U ^G ^Q] [^Q])
5421
5422 with the read-key-sequence:
5423 ^Qb ==> (65 [b] 17 98 [... ^Q b] [b])
5424 ^U^U^Qb ==> (65 [b] 17 98 [... ^U ^U ^Q b] [b])
5425 ^U^U^U^G^Qb ==> (65 [b] 17 98 [... ^U ^U ^U ^G ^Q b] [b])
5426
5427 ;the evi-mode command "4dlj.j.j.j.j.j." is also a good testcase (gag)
5428
5429 ;(setq x (list (read-char) quit-flag))^J^G
5430 ;(let ((inhibit-quit t)) (setq x (list (read-char) quit-flag)))^J^G
5431 ;for BOTH, x should get set to (7 t), but no result should be printed.
5432
5433 ;also do this: make two frames, one viewing "*scratch*", the other "foo".
5434 ;in *scratch*, type (sit-for 20)^J
5435 ;wait a couple of seconds, move cursor to foo, type "a"
5436 ;a should be inserted in foo. Cursor highlighting should not change in
5437 ;the meantime.
5438
5439 ;do it with sleep-for. move cursor into foo, then back into *scratch*
5440 ;before typing.
5441 ;repeat also with (accept-process-output nil 20)
5442
5443 ;make sure ^G aborts sit-for, sleep-for and accept-process-output:
5444
5445 (defun tst ()
5446 (list (condition-case c
5447 (sleep-for 20)
5448 (quit c))
5449 (read-char)))
5450
5451 (tst)^Ja^G ==> ((quit) 97) with no signal
5452 (tst)^J^Ga ==> ((quit) 97) with no signal
5453 (tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer
5454
5455 ; with sit-for only do the 2nd test.
5456 ; Do all 3 tests with (accept-process-output nil 20)
5457
5458 Do this:
5459 (setq enable-recursive-minibuffers t
5460 minibuffer-max-depth nil)
5461 ESC ESC ESC ESC - there are now two minibuffers active
5462 C-g C-g C-g - there should be active 0, not 1
5463 Similarly:
5464 C-x C-f ~ / ? - wait for "Making completion list..." to display
5465 C-g - wait for "Quit" to display
5466 C-g - minibuffer should not be active
5467 however C-g before "Quit" is displayed should leave minibuffer active.
5468
5469 ;do it all in both v18 and v19 and make sure all results are the same.
5470 ;all of these cases matter a lot, but some in quite subtle ways.
5471 */
5472
5473 /*
5474 Additional test cases for accept-process-output, sleep-for, sit-for.
5475 Be sure you do all of the above checking for C-g and focus, too!
5476
5477 ; Make sure that timer handlers are run during, not after sit-for:
5478 (defun timer-check ()
5479 (add-timeout 2 '(lambda (ignore) (message "timer ran")) nil)
5480 (sit-for 5)
5481 (message "after sit-for"))
5482
5483 ; The first message should appear after 2 seconds, and the final message
5484 ; 3 seconds after that.
5485 ; repeat above test with (sleep-for 5) and (accept-process-output nil 5)
5486
5487
5488
5489 ; Make sure that process filters are run during, not after sit-for.
5490 (defun fubar ()
5491 (message "sit-for = %s" (sit-for 30)))
5492 (add-hook 'post-command-hook 'fubar)
5493
5494 ; Now type M-x shell RET
5495 ; wait for the shell prompt then send: ls RET
5496 ; the output of ls should fill immediately, and not wait 30 seconds.
5497
5498 ; repeat above test with (sleep-for 30) and (accept-process-output nil 30)
5499
5500
5501
5502 ; Make sure that recursive invocations return immediately:
5503 (defmacro test-diff-time (start end)
5504 `(+ (* (- (car ,end) (car ,start)) 65536.0)
5505 (- (cadr ,end) (cadr ,start))
5506 (/ (- (caddr ,end) (caddr ,start)) 1000000.0)))
5507
5508 (defun testee (ignore)
5509 (sit-for 10))
5510
5511 (defun test-them ()
5512 (let ((start (current-time))
5513 end)
5514 (add-timeout 2 'testee nil)
5515 (sit-for 5)
5516 (add-timeout 2 'testee nil)
5517 (sleep-for 5)
5518 (add-timeout 2 'testee nil)
5519 (accept-process-output nil 5)
5520 (setq end (current-time))
5521 (test-diff-time start end)))
5522
5523 (test-them) should sit for 15 seconds.
5524 Repeat with testee set to sleep-for and accept-process-output.
5525 These should each delay 36 seconds.
5526
5527 */