Mercurial > hg > xemacs-beta
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 */ |