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