comparison src/event-stream.c @ 0:376386a54a3c r19-14

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