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