Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Events: printing them, converting them to and from characters.
2 Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Not in FSF. */
23
24 /* This file has been Mule-ized. */
25
26 #include <config.h>
27 #include "lisp.h"
28 #include "buffer.h"
29 #include "console.h"
30 #include "console-tty.h" /* for stuff in character_to_event */
31 #include "device.h"
32 #include "console-x.h" /* for x_event_name prototype */
33 #include "extents.h" /* Just for the EXTENTP abort check... */
34 #include "events.h"
35 #include "frame.h"
36 #include "glyphs.h"
37 #include "keymap.h" /* for key_desc_list_to_event() */
38 #include "redisplay.h"
39 #include "window.h"
40
41 /* Where old events go when they are explicitly deallocated.
42 The event chain here is cut loose before GC, so these will be freed
43 eventually.
44 */
45 static Lisp_Object Vevent_resource;
46
47 Lisp_Object Qeventp;
48 Lisp_Object Qevent_live_p;
49 Lisp_Object Qkey_press_event_p;
50 Lisp_Object Qbutton_event_p;
51 Lisp_Object Qmouse_event_p;
52 Lisp_Object Qprocess_event_p;
53
54 Lisp_Object Qkey_press, Qbutton_press, Qbutton_release, Qmisc_user;
55 Lisp_Object Qascii_character;
56
57 /* #### Ad-hoc hack. Should be part of define_lrecord_implementation */
58 void
59 clear_event_resource (void)
60 {
61 Vevent_resource = Qnil;
62 }
63
64 static Lisp_Object mark_event (Lisp_Object, void (*) (Lisp_Object));
65 static void print_event (Lisp_Object, Lisp_Object, int);
66 static int event_equal (Lisp_Object, Lisp_Object, int);
67 static unsigned long event_hash (Lisp_Object obj, int depth);
68 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("event", event,
69 mark_event, print_event, 0, event_equal,
70 event_hash, struct Lisp_Event);
71
72 /* Make sure we lose quickly if we try to use this event */
73 static void
74 deinitialize_event (Lisp_Object ev)
75 {
76 int i;
77 struct Lisp_Event *event = XEVENT (ev);
78
79 for (i = 0; i < ((sizeof (struct Lisp_Event)) / sizeof (int)); i++)
80 ((int *) event) [i] = 0xdeadbeef;
81 event->event_type = dead_event;
82 event->channel = Qnil;
83 set_lheader_implementation (&(event->lheader), lrecord_event);
84 XSET_EVENT_NEXT (ev, Qnil);
85 }
86
87 /* Set everything to zero or nil so that it's predictable. */
88 void
89 zero_event (struct Lisp_Event *e)
90 {
91 memset (e, 0, sizeof (*e));
92 set_lheader_implementation (&(e->lheader), lrecord_event);
93 e->event_type = empty_event;
94 e->next = Qnil;
95 e->channel = Qnil;
96 }
97
98 static Lisp_Object
99 mark_event (Lisp_Object obj, void (*markobj) (Lisp_Object))
100 {
101 struct Lisp_Event *event = XEVENT (obj);
102
103 switch (event->event_type)
104 {
105 case key_press_event:
106 ((markobj) (event->event.key.keysym));
107 break;
108 case process_event:
109 ((markobj) (event->event.process.process));
110 break;
111 case timeout_event:
112 ((markobj) (event->event.timeout.function));
113 ((markobj) (event->event.timeout.object));
114 break;
115 case eval_event:
116 case misc_user_event:
117 ((markobj) (event->event.eval.function));
118 ((markobj) (event->event.eval.object));
119 break;
120 case magic_eval_event:
121 ((markobj) (event->event.magic_eval.object));
122 break;
123 case button_press_event:
124 case button_release_event:
125 case pointer_motion_event:
126 case magic_event:
127 case empty_event:
128 case dead_event:
129 break;
130 default:
131 abort ();
132 }
133 ((markobj) (event->channel));
134 return event->next;
135 }
136
137 static void
138 print_event_1 (CONST char *str, Lisp_Object obj, Lisp_Object printcharfun)
139 {
140 char buf[255];
141 write_c_string (str, printcharfun);
142 format_event_object (buf, XEVENT (obj), 0);
143 write_c_string (buf, printcharfun);
144 }
145
146 static void
147 print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
148 {
149 if (print_readably)
150 error ("printing unreadable object #<event>");
151
152 switch (XEVENT (obj)->event_type)
153 {
154 case key_press_event:
155 print_event_1 ("#<keypress-event ", obj, printcharfun);
156 break;
157 case button_press_event:
158 print_event_1 ("#<buttondown-event ", obj, printcharfun);
159 break;
160 case button_release_event:
161 print_event_1 ("#<buttonup-event ", obj, printcharfun);
162 break;
163 case magic_event:
164 case magic_eval_event:
165 print_event_1 ("#<magic-event ", obj, printcharfun);
166 break;
167 case pointer_motion_event:
168 {
169 char buf[100];
170 sprintf (buf, "#<motion-event %d, %d",
171 XEVENT (obj)->event.motion.x, XEVENT (obj)->event.motion.y);
172 write_c_string (buf, printcharfun);
173 break;
174 }
175 case process_event:
176 {
177 write_c_string ("#<process-event ", printcharfun);
178 print_internal (XEVENT (obj)->event.process.process, printcharfun, 1);
179 break;
180 }
181 case timeout_event:
182 {
183 write_c_string ("#<timeout-event ", printcharfun);
184 print_internal (XEVENT (obj)->event.timeout.object, printcharfun, 1);
185 break;
186 }
187 case empty_event:
188 {
189 write_c_string ("#<empty-event", printcharfun);
190 break;
191 }
192 case misc_user_event:
193 case eval_event:
194 {
195 write_c_string ("#<", printcharfun);
196 if (XEVENT (obj)->event_type == misc_user_event)
197 write_c_string ("misc-user", printcharfun);
198 else
199 write_c_string ("eval", printcharfun);
200 write_c_string ("-event (", printcharfun);
201 print_internal (XEVENT (obj)->event.eval.function, printcharfun, 1);
202 write_c_string (" ", printcharfun);
203 print_internal (XEVENT (obj)->event.eval.object, printcharfun, 1);
204 write_c_string (")", printcharfun);
205 break;
206 }
207 case dead_event:
208 {
209 write_c_string ("#<DEALLOCATED-EVENT", printcharfun);
210 break;
211 }
212 default:
213 {
214 write_c_string ("#<UNKNOWN-EVENT-TYPE", printcharfun);
215 break;
216 }
217 }
218 write_c_string (">", printcharfun);
219 }
220
221 static int
222 event_equal (Lisp_Object o1, Lisp_Object o2, int depth)
223 {
224 struct Lisp_Event *e1 = XEVENT (o1);
225 struct Lisp_Event *e2 = XEVENT (o2);
226
227 if (e1->event_type != e2->event_type) return 0;
228 if (!EQ (e1->channel, e2->channel)) return 0;
229 /* if (e1->timestamp != e2->timestamp) return 0; */
230 switch (e1->event_type)
231 {
232 case process_event:
233 return (EQ (e1->event.process.process,
234 e2->event.process.process));
235
236 case timeout_event:
237 if (NILP (Fequal (e1->event.timeout.function,
238 e2->event.timeout.function)))
239 return 0;
240 if (NILP (Fequal (e1->event.timeout.object,
241 e2->event.timeout.object)))
242 return 0;
243 return 1;
244
245 case key_press_event:
246 return ((EQ (e1->event.key.keysym,
247 e2->event.key.keysym)
248 && (e1->event.key.modifiers
249 == e2->event.key.modifiers)));
250
251 case button_press_event:
252 case button_release_event:
253 return (((e1->event.button.button
254 == e2->event.button.button)
255 && (e1->event.button.modifiers
256 == e2->event.button.modifiers)));
257
258 case pointer_motion_event:
259 return ((e1->event.motion.x == e2->event.motion.x
260 && e1->event.motion.y == e2->event.motion.y));
261
262 case misc_user_event:
263 case eval_event:
264 if (NILP (Fequal (e1->event.eval.function,
265 e2->event.eval.function)))
266 return 0;
267 if (NILP (Fequal (e1->event.eval.object,
268 e2->event.eval.object)))
269 return 0;
270 return 1;
271
272 case magic_eval_event:
273 if (e1->event.magic_eval.internal_function !=
274 e2->event.magic_eval.internal_function)
275 return 0;
276 if (NILP (Fequal (e1->event.magic_eval.object,
277 e2->event.magic_eval.object)))
278 return 0;
279 return 1;
280
281 case magic_event:
282 {
283 Lisp_Object console;
284
285 console = CDFW_CONSOLE (e1->channel);
286
287 #ifdef HAVE_X_WINDOWS
288 /* XEvent is actually a union which means that we can't just use == */
289 if (CONSOLE_X_P (XCONSOLE (console)))
290 return (!memcmp ((XEvent *) &e1->event.magic.underlying_x_event,
291 (XEvent *) &e2->event.magic.underlying_x_event,
292 sizeof (e1->event.magic.underlying_x_event)));
293 #endif
294 #ifdef HAVE_NEXTSTEP
295 if (CONSOLE_NS_P (XCONSOLE (console)))
296 return (e1->event.magic.underlying_ns_event ==
297 e2->event.magic.underlying_ns_event);
298 #endif
299 return (e1->event.magic.underlying_tty_event ==
300 e2->event.magic.underlying_tty_event);
301 }
302
303 case empty_event: /* Empty and deallocated events are equal. */
304 case dead_event:
305 return 1;
306
307 default:
308 abort ();
309 return 0; /* not reached; warning suppression */
310 }
311 }
312
313 static unsigned long
314 event_hash (Lisp_Object obj, int depth)
315 {
316 struct Lisp_Event *e = XEVENT (obj);
317 unsigned long hash;
318
319 hash = HASH2 (e->event_type, LISP_HASH (e->channel));
320 switch (e->event_type)
321 {
322 case process_event:
323 return HASH2 (hash, LISP_HASH (e->event.process.process));
324
325 case timeout_event:
326 return HASH3 (hash, internal_hash (e->event.timeout.function, depth + 1),
327 internal_hash (e->event.timeout.object, depth + 1));
328
329 case key_press_event:
330 return HASH3 (hash, LISP_HASH (e->event.key.keysym),
331 e->event.key.modifiers);
332
333 case button_press_event:
334 case button_release_event:
335 return HASH3 (hash, e->event.button.button, e->event.button.modifiers);
336
337 case pointer_motion_event:
338 return HASH3 (hash, e->event.motion.x, e->event.motion.y);
339
340 case misc_user_event:
341 case eval_event:
342 return HASH3 (hash, internal_hash (e->event.eval.function, depth + 1),
343 internal_hash (e->event.eval.object, depth + 1));
344
345 case magic_eval_event:
346 return HASH3 (hash,
347 (unsigned long) e->event.magic_eval.internal_function,
348 internal_hash (e->event.magic_eval.object, depth + 1));
349
350 case magic_event:
351 {
352 Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (e));
353 #ifdef HAVE_X_WINDOWS
354 if (CONSOLE_X_P (XCONSOLE (console)))
355 return
356 HASH2 (hash,
357 memory_hash (&e->event.magic.underlying_x_event,
358 sizeof (e->event.magic.underlying_x_event)));
359 #endif
360 #ifdef HAVE_NEXTSTEP
361 if (CONSOLE_NS_P (XCONSOLE (console)))
362 return
363 HASH2 (hash,
364 memory_hash (&e->event.magic.underlying_ns_event,
365 sizeof (e->event.magic.underlying_ns_event)));
366 #endif
367 return
368 HASH2 (hash,
369 memory_hash (&e->event.magic.underlying_tty_event,
370 sizeof (e->event.magic.underlying_tty_event)));
371 }
372
373 case empty_event:
374 case dead_event:
375 return hash;
376
377 default:
378 abort ();
379 }
380
381 return 0;
382 }
383
384
385 /* #### This should accept a type and props (as returned by
386 event-properties) to allow creation of any type of event.
387 This is useful, for example, in Lisp code that might want
388 to determine if, for a given button-down event, what the
389 binding for the corresponding button-up event is. */
390
391 DEFUN ("make-event", Fmake_event, Smake_event, 0, 0, 0 /*
392 Create a new empty event.
393 WARNING, the event object returned may be a reused one; see the function
394 `deallocate-event'.
395 */ )
396 ()
397 {
398 Lisp_Object event;
399
400 if (!NILP (Vevent_resource))
401 {
402 event = Vevent_resource;
403 Vevent_resource = XEVENT_NEXT (event);
404 }
405 else
406 {
407 event = allocate_event ();
408 }
409 zero_event (XEVENT (event));
410 return event;
411 }
412
413 DEFUN ("deallocate-event", Fdeallocate_event, Sdeallocate_event, 1, 1, 0 /*
414 Allow the given event structure to be reused.
415 You MUST NOT use this event object after calling this function with it.
416 You will lose. It is not necessary to call this function, as event
417 objects are garbage-collected like all other objects; however, it may
418 be more efficient to explicitly deallocate events when you are sure
419 that that is safe.
420 */ )
421 (event)
422 Lisp_Object event;
423 {
424 CHECK_EVENT (event);
425
426 if (XEVENT_TYPE (event) == dead_event)
427 error ("this event is already deallocated!");
428
429 assert (XEVENT_TYPE (event) <= last_event_type);
430
431 #if 0
432 {
433 int i;
434 extern Lisp_Object Vlast_command_event;
435 extern Lisp_Object Vlast_input_event, Vunread_command_event;
436 extern Lisp_Object Vthis_command_keys, Vrecent_keys_ring;
437
438 if (EQ (event, Vlast_command_event))
439 abort ();
440 if (EQ (event, Vlast_input_event))
441 abort ();
442 if (EQ (event, Vunread_command_event))
443 abort ();
444 for (i = 0; i < XVECTOR (Vthis_command_keys)->size; i++)
445 if (EQ (event, vector_data (XVECTOR (Vthis_command_keys)) [i]))
446 abort ();
447 for (i = 0; i < XVECTOR (Vrecent_keys_ring)->size; i++)
448 if (EQ (event, vector_data (XVECTOR (Vrecent_keys_ring)) [i]))
449 abort ();
450 }
451 #endif /* 0 */
452
453 assert (!EQ (event, Vevent_resource));
454 deinitialize_event (event);
455 #ifndef ALLOC_NO_POOLS
456 XSET_EVENT_NEXT (event, Vevent_resource);
457 Vevent_resource = event;
458 #endif
459 return Qnil;
460 }
461
462 DEFUN ("copy-event", Fcopy_event, Scopy_event, 1, 2, 0 /*
463 Make a copy of the given event object.
464 If a second argument is given, the first event is copied into the second
465 and the second is returned. If the second argument is not supplied (or
466 is nil) then a new event will be made as with `allocate-event.' See also
467 the function `deallocate-event'.
468 */ )
469 (event1, event2)
470 Lisp_Object event1, event2;
471 {
472 CHECK_LIVE_EVENT (event1);
473 if (NILP (event2))
474 event2 = Fmake_event ();
475 else CHECK_LIVE_EVENT (event2);
476 if (EQ (event1, event2))
477 return signal_simple_continuable_error_2
478 ("copy-event called with `eq' events", event1, event2);
479
480 assert (XEVENT_TYPE (event1) <= last_event_type);
481 assert (XEVENT_TYPE (event2) <= last_event_type);
482
483 {
484 Lisp_Object save_next = XEVENT_NEXT (event2);
485
486 *XEVENT (event2) = *XEVENT (event1);
487 XSET_EVENT_NEXT (event2, save_next);
488 return (event2);
489 }
490 }
491
492
493
494 /* Given a chain of events (or possibly nil), deallocate them all. */
495
496 void
497 deallocate_event_chain (Lisp_Object event_chain)
498 {
499 while (!NILP (event_chain))
500 {
501 Lisp_Object next = XEVENT_NEXT (event_chain);
502 Fdeallocate_event (event_chain);
503 event_chain = next;
504 }
505 }
506
507 /* Return the last event in a chain.
508 NOTE: You cannot pass nil as a value here! The routine will
509 abort if you do. */
510
511 Lisp_Object
512 event_chain_tail (Lisp_Object event_chain)
513 {
514 while (1)
515 {
516 Lisp_Object next = XEVENT_NEXT (event_chain);
517 if (NILP (next))
518 return event_chain;
519 event_chain = next;
520 }
521 }
522
523 /* Enqueue a single event onto the end of a chain of events.
524 HEAD points to the first event in the chain, TAIL to the last event.
525 If the chain is empty, both values should be nil. */
526
527 void
528 enqueue_event (Lisp_Object event, Lisp_Object *head, Lisp_Object *tail)
529 {
530 assert (NILP (XEVENT_NEXT (event)));
531 assert (!EQ (*tail, event));
532
533 if (!NILP (*tail))
534 XSET_EVENT_NEXT (*tail, event);
535 else
536 *head = event;
537 *tail = event;
538
539 assert (!EQ (event, XEVENT_NEXT (event)));
540 }
541
542 /* Remove an event off the head of a chain of events and return it.
543 HEAD points to the first event in the chain, TAIL to the last event. */
544
545 Lisp_Object
546 dequeue_event (Lisp_Object *head, Lisp_Object *tail)
547 {
548 Lisp_Object event;
549
550 event = *head;
551 *head = XEVENT_NEXT (event);
552 XSET_EVENT_NEXT (event, Qnil);
553 if (NILP (*head))
554 *tail = Qnil;
555 return event;
556 }
557
558 /* Enqueue a chain of events (or possibly nil) onto the end of another
559 chain of events. HEAD points to the first event in the chain being
560 queued onto, TAIL to the last event. If the chain is empty, both values
561 should be nil. */
562
563 void
564 enqueue_event_chain (Lisp_Object event_chain, Lisp_Object *head,
565 Lisp_Object *tail)
566 {
567 if (NILP (event_chain))
568 return;
569
570 if (NILP (*head))
571 {
572 *head = event_chain;
573 *tail = event_chain;
574 }
575 else
576 {
577 XSET_EVENT_NEXT (*tail, event_chain);
578 *tail = event_chain_tail (event_chain);
579 }
580 }
581
582 /* Return the number of events (possibly 0) on an event chain. */
583
584 int
585 event_chain_count (Lisp_Object event_chain)
586 {
587 Lisp_Object event;
588 int n = 0;
589
590 EVENT_CHAIN_LOOP (event, event_chain)
591 n++;
592
593 return n;
594 }
595
596 /* Find the event before EVENT in an event chain. This aborts
597 if the event is not in the chain. */
598
599 Lisp_Object
600 event_chain_find_previous (Lisp_Object event_chain, Lisp_Object event)
601 {
602 Lisp_Object previous = Qnil;
603
604 while (!NILP (event_chain))
605 {
606 if (EQ (event_chain, event))
607 return previous;
608 previous = event_chain;
609 event_chain = XEVENT_NEXT (event_chain);
610 }
611
612 abort ();
613 return Qnil;
614 }
615
616 Lisp_Object
617 event_chain_nth (Lisp_Object event_chain, int n)
618 {
619 Lisp_Object event;
620 EVENT_CHAIN_LOOP (event, event_chain)
621 {
622 if (!n)
623 return event;
624 n--;
625 }
626 return Qnil;
627 }
628
629 Lisp_Object
630 copy_event_chain (Lisp_Object event_chain)
631 {
632 Lisp_Object new_chain = Qnil;
633 Lisp_Object new_chain_tail = Qnil;
634 Lisp_Object event;
635
636 EVENT_CHAIN_LOOP (event, event_chain)
637 {
638 Lisp_Object copy = Fcopy_event (event, Qnil);
639 enqueue_event (copy, &new_chain, &new_chain_tail);
640 }
641
642 return new_chain;
643 }
644
645
646
647 Lisp_Object QKbackspace, QKtab, QKlinefeed, QKreturn, QKescape,
648 QKspace, QKdelete;
649
650 int
651 command_event_p (Lisp_Object event)
652 {
653 switch (XEVENT_TYPE (event))
654 {
655 case key_press_event:
656 case button_press_event:
657 case button_release_event:
658 case misc_user_event:
659 return (1);
660 default:
661 return (0);
662 }
663 }
664
665
666 void
667 character_to_event (Emchar c, struct Lisp_Event *event, struct console *con,
668 int use_console_meta_flag)
669 {
670 Lisp_Object k = Qnil;
671 unsigned int m = 0;
672 if (event->event_type == dead_event)
673 error ("character-to-event called with a deallocated event!");
674
675 c &= 255;
676
677 if (c > 127 && c <= 255)
678 {
679 int meta_flag = 1;
680 if (use_console_meta_flag && CONSOLE_TTY_P (con))
681 meta_flag = TTY_FLAGS (con).meta_key;
682 switch (meta_flag)
683 {
684 case 0: /* ignore top bit; it's parity */
685 c -= 128;
686 break;
687 case 1: /* top bit is meta */
688 c -= 128;
689 m = MOD_META;
690 break;
691 default: /* this is a real character */
692 break;
693 }
694 }
695 if (c < ' ') c += '@', m |= MOD_CONTROL;
696 if (m & MOD_CONTROL)
697 {
698 switch (c)
699 {
700 case 'I': k = QKtab; m &= ~MOD_CONTROL; break;
701 case 'J': k = QKlinefeed; m &= ~MOD_CONTROL; break;
702 case 'M': k = QKreturn; m &= ~MOD_CONTROL; break;
703 case '[': k = QKescape; m &= ~MOD_CONTROL; break;
704 # if 0
705 /* This is probably too controversial... */
706 case 'H': k = QKbackspace; m &= ~MOD_CONTROL; break;
707 # endif
708 }
709 if (c >= 'A' && c <= 'Z') c -= 'A'-'a';
710 }
711 else if (c == 127)
712 k = QKdelete;
713 else if (c == ' ')
714 k = QKspace;
715
716 event->event_type = key_press_event;
717 event->timestamp = 0; /* #### */
718 event->channel = make_console (con);
719 event->event.key.keysym = (!NILP (k) ? k : make_char (c));
720 event->event.key.modifiers = m;
721 }
722
723
724 /* This variable controls what character name -> character code mapping
725 we are using. Window-system-specific code sets this to some symbol,
726 and we use that symbol as the plist key to convert keysyms into 8-bit
727 codes. In this way one can have several character sets predefined and
728 switch them by changing this.
729 */
730 Lisp_Object Vcharacter_set_property;
731
732 Emchar
733 event_to_character (struct Lisp_Event *event,
734 int allow_extra_modifiers,
735 int allow_meta,
736 int allow_non_ascii)
737 {
738 Emchar c = 0;
739 Lisp_Object code;
740
741 if (event->event_type != key_press_event)
742 {
743 if (event->event_type == dead_event) abort ();
744 return -1;
745 }
746 if (!allow_extra_modifiers &&
747 event->event.key.modifiers & (MOD_SUPER|MOD_HYPER|MOD_ALT))
748 return -1;
749 if (CHAR_OR_CHAR_INTP (event->event.key.keysym))
750 c = XCHAR_OR_CHAR_INT (event->event.key.keysym);
751 else if (!SYMBOLP (event->event.key.keysym))
752 abort ();
753 else if (allow_non_ascii && !NILP (Vcharacter_set_property)
754 /* Allow window-system-specific extensibility of
755 keysym->code mapping */
756 && CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym,
757 Vcharacter_set_property,
758 Qnil)))
759 c = XCHAR_OR_CHAR_INT (code);
760 else if (CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym,
761 Qascii_character, Qnil)))
762 c = XCHAR_OR_CHAR_INT (code);
763 else
764 return -1;
765
766 if (event->event.key.modifiers & MOD_CONTROL)
767 {
768 if (c >= 'a' && c <= 'z')
769 c -= ('a' - 'A');
770 else
771 /* reject Control-Shift- keys */
772 if (c >= 'A' && c <= 'Z' && !allow_extra_modifiers)
773 return -1;
774
775 if (c >= '@' && c <= '_')
776 c -= '@';
777 else if (c == ' ') /* C-space and C-@ are the same. */
778 c = 0;
779 else
780 /* reject keys that can't take Control- modifiers */
781 if (! allow_extra_modifiers) return -1;
782 }
783
784 if (event->event.key.modifiers & MOD_META)
785 {
786 if (! allow_meta) return -1;
787 if (c & 0200) return -1; /* don't allow M-oslash (overlap) */
788 c |= 0200;
789 }
790 return c;
791 }
792
793
794 DEFUN ("event-to-character", Fevent_to_character, Sevent_to_character,
795 1, 4, 0 /*
796 Return the closest ASCII approximation to the given event object.
797 If the event isn't a keypress, this returns nil.
798 If the ALLOW-EXTRA-MODIFIERS argument is non-nil, then this is lenient in
799 its translation; it will ignore modifier keys other than control and meta,
800 and will ignore the shift modifier on those characters which have no
801 shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
802 the same ASCII code as Control-A).
803 If the ALLOW-META argument is non-nil, then the Meta modifier will be
804 represented by turning on the high bit of the byte returned; otherwise, nil
805 will be returned for events containing the Meta modifier.
806 If the ALLOW-NON-ASCII argument is non-nil, then characters which are
807 present in the prevailing character set (see the `character-set-property'
808 variable) will be returned as their code in that character set, instead of
809 the return value being restricted to ASCII.
810 Note that specifying both ALLOW-META and ALLOW-NON-ASCII is ambiguous, as
811 both use the high bit; `M-x' and `oslash' will be indistinguishable.
812 */ )
813 (event, allow_extra_modifiers, allow_meta, allow_non_ascii)
814 Lisp_Object event, allow_extra_modifiers, allow_meta, allow_non_ascii;
815 {
816 Emchar c;
817 CHECK_LIVE_EVENT (event);
818 c = event_to_character (XEVENT (event),
819 !NILP (allow_extra_modifiers),
820 !NILP (allow_meta),
821 !NILP (allow_non_ascii));
822 return (c < 0 ? Qnil : make_char (c));
823 }
824
825 DEFUN ("character-to-event", Fcharacter_to_event, Scharacter_to_event,
826 1, 4, 0 /*
827 Converts a keystroke specifier intoto an event structure, replete with
828 bucky bits. The keystroke is the first argument, and the event to fill
829 in is the second. This function contains knowledge about what the codes
830 ``mean'' -- for example, the number 9 is converted to the character ``Tab'',
831 not the distinct character ``Control-I''.
832
833 Note that CH (the keystroke specifier) can be an integer, a character,
834 a symbol such as 'clear, or a list such as '(control backspace).
835
836 If the optional second argument is an event, it is modified; otherwise, a
837 new event object is created.
838
839 Optional third arg CONSOLE is the console to store in the event, and defaults
840 to the selected console.
841
842 If CH is an integer or character, the high bit may be interpreted as the
843 meta key. (This is done for backward compatibility in lots of places.)
844 If USE-CONSOLE-META-FLAG is nil, this will always be the case. If
845 USE-CONSOLE-META-FLAG is non-nil, the `meta' flag for CONSOLE affects
846 whether the high bit is interpreted as a meta key. (See `set-input-mode'.)
847 If you don't want this silly meta interpretation done, you should pass
848 in a list containing the character.
849
850 Beware that character-to-event and event-to-character are not strictly
851 inverse functions, since events contain much more information than the
852 ASCII character set can encode.
853 */ )
854 (ch, event, console, use_console_meta_flag)
855 Lisp_Object ch, event, console, use_console_meta_flag;
856 {
857 struct console *con = decode_console (console);
858 if (NILP (event))
859 event = Fmake_event ();
860 else
861 CHECK_LIVE_EVENT (event);
862 if (CONSP (ch) || SYMBOLP (ch))
863 key_desc_list_to_event (ch, event, 1);
864 else
865 {
866 CHECK_CHAR_COERCE_INT (ch);
867 character_to_event (XCHAR (ch), XEVENT (event), con,
868 !NILP (use_console_meta_flag));
869 }
870 return event;
871 }
872
873 void
874 nth_of_key_sequence_as_event (Lisp_Object seq, int n, Lisp_Object event)
875 {
876 assert (STRINGP (seq) || VECTORP (seq));
877 assert (n < XINT (Flength (seq)));
878
879 if (STRINGP (seq))
880 {
881 Emchar ch = string_char (XSTRING (seq), n);
882 Fcharacter_to_event (make_char (ch), event, Qnil, Qnil);
883 }
884 else
885 {
886 Lisp_Object keystroke = vector_data (XVECTOR (seq))[n];
887 if (EVENTP (keystroke))
888 Fcopy_event (keystroke, event);
889 else
890 Fcharacter_to_event (keystroke, event, Qnil, Qnil);
891 }
892 }
893
894 Lisp_Object
895 key_sequence_to_event_chain (Lisp_Object seq)
896 {
897 int len = XINT (Flength (seq));
898 int i;
899 Lisp_Object head = Qnil, tail = Qnil;
900
901 for (i = 0; i < len; i++)
902 {
903 Lisp_Object event = Fmake_event ();
904 nth_of_key_sequence_as_event (seq, i, event);
905 enqueue_event (event, &head, &tail);
906 }
907
908 return head;
909 }
910
911 void
912 format_event_object (char *buf, struct Lisp_Event *event, int brief)
913 {
914 int mouse_p = 0;
915 int mod = 0;
916 Lisp_Object key;
917
918 switch (event->event_type)
919 {
920 case key_press_event:
921 {
922 mod = event->event.key.modifiers;
923 key = event->event.key.keysym;
924 /* Hack. */
925 if (! brief && CHARP (key) &&
926 mod & (MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER))
927 {
928 int k = XCHAR (key);
929 if (k >= 'a' && k <= 'z')
930 key = make_char (k - ('a' - 'A'));
931 else if (k >= 'A' && k <= 'Z')
932 mod |= MOD_SHIFT;
933 }
934 break;
935 }
936 case button_release_event:
937 mouse_p++;
938 /* Fall through */
939 case button_press_event:
940 {
941 mouse_p++;
942 mod = event->event.button.modifiers;
943 key = make_char (event->event.button.button + '0');
944 break;
945 }
946 case magic_event:
947 {
948 CONST char *name = 0;
949 Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (event));
950
951 #ifdef HAVE_X_WINDOWS
952 if (CONSOLE_X_P (XCONSOLE (console)))
953 name =
954 x_event_name (event->event.magic.underlying_x_event.xany.type);
955 #endif
956 #ifdef HAVE_NEXTSTEP
957 if (CONSOLE_NS_P (XCONSOLE (console)))
958 name = ns_event_name (event->event.magic.underlying_ns_event);
959 #endif
960 if (name) strcpy (buf, name);
961 else strcpy (buf, "???");
962 return;
963 }
964 case magic_eval_event: strcpy (buf, "magic-eval"); return;
965 case pointer_motion_event: strcpy (buf, "motion"); return;
966 case misc_user_event: strcpy (buf, "misc-user"); return;
967 case eval_event: strcpy (buf, "eval"); return;
968 case process_event: strcpy (buf, "process");return;
969 case timeout_event: strcpy (buf, "timeout");return;
970 case empty_event: strcpy (buf, "EMPTY-EVENT"); return;
971 case dead_event: strcpy (buf, "DEAD-EVENT"); return;
972 default:
973 abort ();
974 }
975 #define modprint1(x) { strcpy (buf, (x)); buf += sizeof (x)-1; }
976 #define modprint(x,y) { if (brief) modprint1 (y) else modprint1 (x) }
977 if (mod & MOD_CONTROL) modprint ("control-", "C-");
978 if (mod & MOD_META) modprint ("meta-", "M-");
979 if (mod & MOD_SUPER) modprint ("super-", "S-");
980 if (mod & MOD_HYPER) modprint ("hyper-", "H-");
981 if (mod & MOD_ALT) modprint ("alt-", "A-");
982 if (mod & MOD_SHIFT) modprint ("shift-", "Sh-");
983 if (mouse_p)
984 {
985 modprint1 ("button");
986 --mouse_p;
987 }
988 #undef modprint
989 #undef modprint1
990
991 if (CHARP (key))
992 {
993 buf += set_charptr_emchar ((Bufbyte *) buf, XCHAR (key));
994 *buf = 0;
995 }
996 else if (SYMBOLP (key))
997 {
998 CONST char *str = 0;
999 if (brief)
1000 {
1001 if (EQ (key, QKlinefeed)) str = "LFD";
1002 else if (EQ (key, QKtab)) str = "TAB";
1003 else if (EQ (key, QKreturn)) str = "RET";
1004 else if (EQ (key, QKescape)) str = "ESC";
1005 else if (EQ (key, QKdelete)) str = "DEL";
1006 else if (EQ (key, QKspace)) str = "SPC";
1007 else if (EQ (key, QKbackspace)) str = "BS";
1008 }
1009 if (str)
1010 {
1011 int i = strlen (str);
1012 memcpy (buf, str, i+1);
1013 str += i;
1014 }
1015 else
1016 {
1017 memcpy (buf, string_data (XSYMBOL (key)->name),
1018 string_length (XSYMBOL (key)->name) + 1);
1019 str += string_length (XSYMBOL (key)->name);
1020 }
1021 }
1022 else
1023 abort ();
1024 if (mouse_p)
1025 strncpy (buf, "up", 4);
1026 }
1027
1028 DEFUN ("eventp", Feventp, Seventp, 1, 1, 0 /*
1029 True if OBJECT is an event object.
1030 */ )
1031 (object)
1032 Lisp_Object object;
1033 {
1034 return ((EVENTP (object)) ? Qt : Qnil);
1035 }
1036
1037 DEFUN ("event-live-p", Fevent_live_p, Sevent_live_p, 1, 1, 0 /*
1038 True if OBJECT is an event object that has not been deallocated.
1039 */ )
1040 (object)
1041 Lisp_Object object;
1042 {
1043 return ((EVENTP (object) && XEVENT (object)->event_type != dead_event)
1044 ? Qt : Qnil);
1045 }
1046
1047 #if 0 /* debugging functions */
1048
1049 xxDEFUN ("event-next", Fevent_next, Sevent_next, 1, 1, 0 /*
1050 Return the event object's `next' event, or nil if it has none.
1051 The `next-event' field is changed by calling `set-next-event'.
1052 */ )
1053 (event)
1054 Lisp_Object event;
1055 {
1056 struct Lisp_Event *e;
1057 CHECK_LIVE_EVENT (event);
1058
1059 return XEVENT_NEXT (event);
1060 }
1061
1062 xxDEFUN ("set-event-next", Fset_event_next, Sset_event_next, 2, 2, 0 /*
1063 Set the `next event' of EVENT to NEXT-EVENT.
1064 NEXT-EVENT must be an event object or nil.
1065 */ )
1066 (event, next_event)
1067 Lisp_Object event, next_event;
1068 {
1069 Lisp_Object ev;
1070
1071 CHECK_LIVE_EVENT (event);
1072 if (NILP (next_event))
1073 {
1074 XSET_EVENT_NEXT (event, Qnil);
1075 return (Qnil);
1076 }
1077
1078 CHECK_LIVE_EVENT (next_event);
1079
1080 EVENT_CHAIN_LOOP (ev, XEVENT_NEXT (event))
1081 {
1082 QUIT;
1083 if (EQ (ev, event))
1084 signal_error (Qerror,
1085 list3 (build_string ("Cyclic event-next"),
1086 event,
1087 next_event));
1088 }
1089 XSET_EVENT_NEXT (event, next_event);
1090 return (next_event);
1091 }
1092
1093 #endif /* 0 */
1094
1095 DEFUN ("event-type", Fevent_type, Sevent_type, 1, 1, 0 /*
1096 Return the type of EVENT.
1097 This will be a symbol; one of
1098
1099 key-press A key was pressed.
1100 button-press A mouse button was pressed.
1101 button-release A mouse button was released.
1102 misc-user Some other user action happened; typically, this is
1103 a menu selection or scrollbar action.
1104 motion The mouse moved.
1105 process Input is available from a subprocess.
1106 timeout A timeout has expired.
1107 eval This causes a specified action to occur when dispatched.
1108 magic Some window-system-specific event has occurred.
1109 */ )
1110 (event)
1111 Lisp_Object event;
1112 {
1113 CHECK_LIVE_EVENT (event);
1114 switch (XEVENT (event)->event_type)
1115 {
1116 case key_press_event:
1117 return Qkey_press;
1118
1119 case button_press_event:
1120 return Qbutton_press;
1121
1122 case button_release_event:
1123 return Qbutton_release;
1124
1125 case misc_user_event:
1126 return Qmisc_user;
1127
1128 case pointer_motion_event:
1129 return Qmotion;
1130
1131 case process_event:
1132 return Qprocess;
1133
1134 case timeout_event:
1135 return Qtimeout;
1136
1137 case eval_event:
1138 return Qeval;
1139
1140 case magic_event:
1141 case magic_eval_event:
1142 return Qmagic;
1143
1144 default:
1145 abort ();
1146 return Qnil;
1147 }
1148 }
1149
1150 DEFUN ("event-timestamp", Fevent_timestamp, Sevent_timestamp, 1, 1, 0 /*
1151 Return the timestamp of the given event object.
1152 */ )
1153 (event)
1154 Lisp_Object event;
1155 {
1156 CHECK_LIVE_EVENT (event);
1157 /* This junk is so that timestamps don't get to be negative, but contain
1158 as many bits as this particular emacs will allow.
1159 */
1160 return make_int (((1L << (VALBITS - 1)) - 1) &
1161 XEVENT (event)->timestamp);
1162 }
1163
1164 #define CHECK_EVENT_TYPE(e,t1,sym) \
1165 { CHECK_LIVE_EVENT (e); \
1166 if (XEVENT(e)->event_type != (t1)) \
1167 e = wrong_type_argument ((sym),(e)); \
1168 }
1169
1170 #define CHECK_EVENT_TYPE2(e,t1,t2,sym) \
1171 { CHECK_LIVE_EVENT (e); \
1172 if (XEVENT(e)->event_type != (t1) && XEVENT(e)->event_type != (t2)) \
1173 e = wrong_type_argument ((sym),(e)); \
1174 }
1175
1176 DEFUN ("event-key", Fevent_key, Sevent_key, 1, 1, 0 /*
1177 Return the Keysym of the given key-press event.
1178 This will be the ASCII code of a printing character, or a symbol.
1179 */ )
1180 (event)
1181 Lisp_Object event;
1182 {
1183 CHECK_EVENT_TYPE (event, key_press_event, Qkey_press_event_p);
1184 return (XEVENT (event)->event.key.keysym);
1185 }
1186
1187 DEFUN ("event-button", Fevent_button, Sevent_button, 1, 1, 0 /*
1188 Return the button-number of the given mouse-button-press event.
1189 */ )
1190 (event)
1191 Lisp_Object event;
1192 {
1193 CHECK_EVENT_TYPE2 (event, button_press_event, button_release_event,
1194 Qbutton_event_p);
1195 #ifdef HAVE_WINDOW_SYSTEM
1196 return make_int (XEVENT (event)->event.button.button);
1197 #else /* !HAVE_WINDOW_SYSTEM */
1198 return Qzero;
1199 #endif /* !HAVE_WINDOW_SYSTEM */
1200 }
1201
1202 DEFUN ("event-modifier-bits", Fevent_modifier_bits, Sevent_modifier_bits,
1203 1, 1, 0 /*
1204 Return a number representing the modifier keys which were down
1205 when the given mouse or keyboard event was produced. See also the function
1206 event-modifiers.
1207 */ )
1208 (event)
1209 Lisp_Object event;
1210 {
1211 again:
1212 CHECK_LIVE_EVENT (event);
1213 if (XEVENT (event)->event_type == key_press_event)
1214 return make_int (XEVENT (event)->event.key.modifiers);
1215 else if (XEVENT (event)->event_type == button_press_event ||
1216 XEVENT (event)->event_type == button_release_event)
1217 return make_int (XEVENT (event)->event.button.modifiers);
1218 else if (XEVENT (event)->event_type == pointer_motion_event)
1219 return make_int (XEVENT (event)->event.motion.modifiers);
1220 else
1221 {
1222 event = wrong_type_argument (intern ("key-or-mouse-event-p"), event);
1223 goto again;
1224 }
1225 }
1226
1227 DEFUN ("event-modifiers", Fevent_modifiers, Sevent_modifiers, 1, 1, 0 /*
1228 Return a list of symbols, the names of the modifier keys
1229 which were down when the given mouse or keyboard event was produced.
1230 See also the function event-modifier-bits.
1231 */ )
1232 (event)
1233 Lisp_Object event;
1234 {
1235 int mod = XINT (Fevent_modifier_bits (event));
1236 Lisp_Object result = Qnil;
1237 if (mod & MOD_SHIFT) result = Fcons (Qshift, result);
1238 if (mod & MOD_ALT) result = Fcons (Qalt, result);
1239 if (mod & MOD_HYPER) result = Fcons (Qhyper, result);
1240 if (mod & MOD_SUPER) result = Fcons (Qsuper, result);
1241 if (mod & MOD_META) result = Fcons (Qmeta, result);
1242 if (mod & MOD_CONTROL) result = Fcons (Qcontrol, result);
1243 return result;
1244 }
1245
1246 static int
1247 event_x_y_pixel_internal (Lisp_Object event, int *x, int *y, int relative)
1248 {
1249 struct window *w;
1250 struct frame *f;
1251
1252 if (XEVENT (event)->event_type == pointer_motion_event)
1253 {
1254 *x = XEVENT (event)->event.motion.x;
1255 *y = XEVENT (event)->event.motion.y;
1256 }
1257 else if (XEVENT (event)->event_type == button_press_event ||
1258 XEVENT (event)->event_type == button_release_event)
1259 {
1260 *x = XEVENT (event)->event.button.x;
1261 *y = XEVENT (event)->event.button.y;
1262 }
1263 else
1264 return 0;
1265
1266 f = XFRAME (EVENT_CHANNEL (XEVENT (event)));
1267
1268 if (relative)
1269 {
1270 w = find_window_by_pixel_pos (*x, *y, f->root_window);
1271
1272 if (!w)
1273 return 1; /* #### What should really happen here. */
1274
1275 *x -= w->pixel_left;
1276 *y -= w->pixel_top;
1277 }
1278 else
1279 {
1280 *y -= FRAME_REAL_TOP_TOOLBAR_HEIGHT (f);
1281 *x -= FRAME_REAL_LEFT_TOOLBAR_WIDTH (f);
1282 }
1283
1284 return 1;
1285 }
1286
1287 DEFUN ("event-window-x-pixel", Fevent_window_x_pixel, Sevent_window_x_pixel,
1288 1, 1, 0 /*
1289 Return the X position in pixels of the given mouse event.
1290 The value returned is relative to the window the event occurred in.
1291 This will signal an error if the event is not a mouse-motion, button-press,
1292 or button-release event. See also `event-x-pixel'.
1293 */ )
1294 (event)
1295 Lisp_Object event;
1296 {
1297 int x, y;
1298
1299 CHECK_LIVE_EVENT (event);
1300
1301 if (!event_x_y_pixel_internal (event, &x, &y, 1))
1302 return wrong_type_argument (Qmouse_event_p, event);
1303 else
1304 return make_int (x);
1305 }
1306
1307 DEFUN ("event-window-y-pixel", Fevent_window_y_pixel, Sevent_window_y_pixel,
1308 1, 1, 0 /*
1309 Return the Y position in pixels of the given mouse event.
1310 The value returned is relative to the window the event occurred in.
1311 This will signal an error if the event is not a mouse-motion, button-press,
1312 or button-release event. See also `event-y-pixel'.
1313 */ )
1314 (event)
1315 Lisp_Object event;
1316 {
1317 int x, y;
1318
1319 CHECK_LIVE_EVENT (event);
1320
1321 if (!event_x_y_pixel_internal (event, &x, &y, 1))
1322 return wrong_type_argument (Qmouse_event_p, event);
1323 else
1324 return make_int (y);
1325 }
1326
1327 DEFUN ("event-x-pixel", Fevent_x_pixel, Sevent_x_pixel,
1328 1, 1, 0 /*
1329 Return the X position in pixels of the given mouse event.
1330 The value returned is relative to the frame the event occurred in.
1331 This will signal an error if the event is not a mouse-motion, button-press,
1332 or button-release event. See also `event-window-x-pixel'.
1333 */ )
1334 (event)
1335 Lisp_Object event;
1336 {
1337 int x, y;
1338
1339 CHECK_LIVE_EVENT (event);
1340
1341 if (!event_x_y_pixel_internal (event, &x, &y, 0))
1342 return wrong_type_argument (Qmouse_event_p, event);
1343 else
1344 return make_int (x);
1345 }
1346
1347 DEFUN ("event-y-pixel", Fevent_y_pixel, Sevent_y_pixel,
1348 1, 1, 0 /*
1349 Return the Y position in pixels of the given mouse event.
1350 The value returned is relative to the frame the event occurred in.
1351 This will signal an error if the event is not a mouse-motion, button-press,
1352 or button-release event. See also `event-window-y-pixel'.
1353 */ )
1354 (event)
1355 Lisp_Object event;
1356 {
1357 int x, y;
1358
1359 CHECK_LIVE_EVENT (event);
1360
1361 if (!event_x_y_pixel_internal (event, &x, &y, 0))
1362 return wrong_type_argument (Qmouse_event_p, event);
1363 else
1364 return make_int (y);
1365 }
1366
1367 /* Given an event, return a value:
1368
1369 OVER_TOOLBAR: over one of the 4 frame toolbars
1370 OVER_MODELINE: over a modeline
1371 OVER_BORDER: over an internal border
1372 OVER_NOTHING: over the text area, but not over text
1373 OVER_OUTSIDE: outside of the frame border
1374 OVER_TEXT: over text in the text area
1375
1376 and return:
1377
1378 The X char position in CHAR_X, if not a null pointer.
1379 The Y char position in CHAR_Y, if not a null pointer.
1380 (These last two values are relative to the window the event is over.)
1381 The window it's over in W, if not a null pointer.
1382 The buffer position it's over in BUFP, if not a null pointer.
1383 The closest buffer position in CLOSEST, if not a null pointer.
1384
1385 OBJ_X, OBJ_Y, OBJ1, and OBJ2 are as in pixel_to_glyph_translation().
1386 */
1387
1388 static int
1389 event_pixel_translation (Lisp_Object event, int *char_x, int *char_y,
1390 int *obj_x, int *obj_y,
1391 struct window **w, Bufpos *bufp, Bufpos *closest,
1392 Charcount *modeline_closest,
1393 Lisp_Object *obj1, Lisp_Object *obj2)
1394 {
1395 int pix_x = 0;
1396 int pix_y = 0;
1397 int result;
1398 Lisp_Object frame;
1399
1400 int ret_x, ret_y, ret_obj_x, ret_obj_y;
1401 struct window *ret_w;
1402 Bufpos ret_bufp, ret_closest;
1403 Charcount ret_modeline_closest;
1404 Lisp_Object ret_obj1, ret_obj2;
1405
1406 CHECK_LIVE_EVENT (event);
1407 if (XEVENT (event)->event_type == pointer_motion_event)
1408 {
1409 pix_x = XEVENT (event)->event.motion.x;
1410 pix_y = XEVENT (event)->event.motion.y;
1411 frame = XEVENT (event)->channel;
1412 }
1413 else if (XEVENT (event)->event_type == button_press_event ||
1414 XEVENT (event)->event_type == button_release_event)
1415 {
1416 pix_x = XEVENT (event)->event.button.x;
1417 pix_y = XEVENT (event)->event.button.y;
1418 frame = XEVENT (event)->channel;
1419 }
1420 else
1421 wrong_type_argument (Qmouse_event_p, event);
1422
1423 result = pixel_to_glyph_translation (XFRAME (frame), pix_x, pix_y,
1424 &ret_x, &ret_y, &ret_obj_x, &ret_obj_y,
1425 &ret_w, &ret_bufp, &ret_closest,
1426 &ret_modeline_closest,
1427 &ret_obj1, &ret_obj2);
1428
1429 if (result == OVER_NOTHING || result == OVER_OUTSIDE)
1430 ret_bufp = 0;
1431 else if (ret_w && NILP (ret_w->buffer))
1432 /* Why does this happen? (Does it still happen?)
1433 I guess the window has gotten reused as a non-leaf... */
1434 ret_w = 0;
1435
1436 /* #### pixel_to_glyph_translation() sometimes returns garbage...
1437 The word has type Lisp_Record (presumably meaning `extent') but the
1438 pointer points to random memory, often filled with 0, sometimes not.
1439 */
1440 /* #### Chuck, do we still need this crap? */
1441 if (!NILP (ret_obj1) && !(GLYPHP (ret_obj1)
1442 #ifdef HAVE_TOOLBARS
1443 || TOOLBAR_BUTTONP (ret_obj1)
1444 #endif
1445 ))
1446 abort ();
1447 if (!NILP (ret_obj2) && !(EXTENTP (ret_obj2)
1448 || CONSP (ret_obj2)))
1449 abort ();
1450
1451 if (char_x)
1452 *char_x = ret_x;
1453 if (char_y)
1454 *char_y = ret_y;
1455 if (obj_x)
1456 *obj_x = ret_obj_x;
1457 if (obj_y)
1458 *obj_y = ret_obj_y;
1459 if (w)
1460 *w = ret_w;
1461 if (bufp)
1462 *bufp = ret_bufp;
1463 if (closest)
1464 *closest = ret_closest;
1465 if (modeline_closest)
1466 *modeline_closest = ret_modeline_closest;
1467 if (obj1)
1468 *obj1 = ret_obj1;
1469 if (obj2)
1470 *obj2 = ret_obj2;
1471
1472 return result;
1473 }
1474
1475 DEFUN ("event-over-text-area-p", Fevent_over_text_area_p,
1476 Sevent_over_text_area_p, 1, 1, 0 /*
1477 Return whether the given mouse event occurred over the text area of a window.
1478 The modeline is not considered to be part of the text area.
1479 */ )
1480 (event)
1481 Lisp_Object event;
1482 {
1483 int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1484
1485 if (result == OVER_TEXT || result == OVER_NOTHING)
1486 return Qt;
1487 else
1488 return Qnil;
1489 }
1490
1491 DEFUN ("event-over-modeline-p", Fevent_over_modeline_p, Sevent_over_modeline_p,
1492 1, 1, 0 /*
1493 Return whether the given mouse event occurred over the modeline of a window.
1494 */ )
1495 (event)
1496 Lisp_Object event;
1497 {
1498 int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1499
1500 if (result == OVER_MODELINE)
1501 return Qt;
1502 else
1503 return Qnil;
1504 }
1505
1506 DEFUN ("event-over-border-p", Fevent_over_border_p, Sevent_over_border_p,
1507 1, 1, 0 /*
1508 Return whether the given mouse event occurred over an internal border.
1509 */ )
1510 (event)
1511 Lisp_Object event;
1512 {
1513 int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1514
1515 if (result == OVER_BORDER)
1516 return Qt;
1517 else
1518 return Qnil;
1519 }
1520
1521 DEFUN ("event-over-toolbar-p", Fevent_over_toolbar_p, Sevent_over_toolbar_p,
1522 1, 1, 0 /*
1523 Return whether the given mouse event occurred over a toolbar.
1524 */ )
1525 (event)
1526 Lisp_Object event;
1527 {
1528 int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1529
1530 if (result == OVER_TOOLBAR)
1531 return Qt;
1532 else
1533 return Qnil;
1534 }
1535
1536 struct console *
1537 event_console_or_selected (Lisp_Object event)
1538 {
1539 Lisp_Object channel = EVENT_CHANNEL (XEVENT (event));
1540 Lisp_Object console = CDFW_CONSOLE (channel);
1541
1542 if (NILP (console))
1543 console = Vselected_console;
1544
1545 return XCONSOLE (console);
1546 }
1547
1548 DEFUN ("event-channel", Fevent_channel, Sevent_channel, 1, 1, 0 /*
1549 Return the channel that the given event occurred on.
1550 This will be a frame, device, console, or nil for some types
1551 of events (e.g. eval events).
1552 */ )
1553 (event)
1554 Lisp_Object event;
1555 {
1556 CHECK_LIVE_EVENT (event);
1557 return EVENT_CHANNEL (XEVENT (event));
1558 }
1559
1560 DEFUN ("event-window", Fevent_window, Sevent_window, 1, 1, 0 /*
1561 Return the window of the given mouse event.
1562 This may be nil if the event occurred in the border or over a toolbar.
1563 The modeline is considered to be in the window it represents.
1564 */ )
1565 (event)
1566 Lisp_Object event;
1567 {
1568 struct window *w;
1569 Lisp_Object window;
1570
1571 event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, 0);
1572
1573 if (!w)
1574 return Qnil;
1575 else
1576 {
1577 XSETWINDOW (window, w);
1578 return window;
1579 }
1580 }
1581
1582 DEFUN ("event-point", Fevent_point, Sevent_point, 1, 1, 0 /*
1583 Return the character position of the given mouse event.
1584 If the event did not occur over a window, or did not occur over text,
1585 then this returns nil. Otherwise, it returns an index into the buffer
1586 visible in the event's window.
1587 */ )
1588 (event)
1589 Lisp_Object event;
1590 {
1591 Bufpos bufp;
1592 struct window *w;
1593
1594 event_pixel_translation (event, 0, 0, 0, 0, &w, &bufp, 0, 0, 0, 0);
1595
1596 if (!w)
1597 return Qnil;
1598 else if (!bufp)
1599 return Qnil;
1600 else
1601 return make_int (bufp);
1602 }
1603
1604 DEFUN ("event-closest-point", Fevent_closest_point, Sevent_closest_point,
1605 1, 1, 0 /*
1606 Return the character position of the given mouse event.
1607 If the event did not occur over a window or over text, return the
1608 closest point to the location of the event. If the Y pixel position
1609 overlaps a window and the X pixel position is to the left of that
1610 window, the closest point is the beginning of the line containing the
1611 Y position. If the Y pixel position overlaps a window and the X pixel
1612 position is to the right of that window, the closest point is the end
1613 of the line containing the Y position. If the Y pixel position is
1614 above a window, return 0. If it is below a window, return the value
1615 of (window-end).
1616 */ )
1617 (event)
1618 Lisp_Object event;
1619 {
1620 Bufpos bufp;
1621
1622 event_pixel_translation (event, 0, 0, 0, 0, 0, 0, &bufp, 0, 0, 0);
1623
1624 if (!bufp)
1625 return Qnil;
1626 else
1627 return make_int (bufp);
1628 }
1629
1630 DEFUN ("event-x", Fevent_x, Sevent_x, 1, 1, 0 /*
1631 Return the X position of the given mouse event in characters.
1632 This is relative to the window the event occurred over.
1633 */ )
1634 (event)
1635 Lisp_Object event;
1636 {
1637 int char_x;
1638
1639 event_pixel_translation (event, &char_x, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1640
1641 return make_int (char_x);
1642 }
1643
1644 DEFUN ("event-y", Fevent_y, Sevent_y, 1, 1, 0 /*
1645 Return the Y position of the given mouse event in characters.
1646 This is relative to the window the event occurred over.
1647 */ )
1648 (event)
1649 Lisp_Object event;
1650 {
1651 int char_y;
1652
1653 event_pixel_translation (event, 0, &char_y, 0, 0, 0, 0, 0, 0, 0, 0);
1654
1655 return make_int (char_y);
1656 }
1657
1658 DEFUN ("event-modeline-position", Fevent_modeline_position,
1659 Sevent_modeline_position, 1, 1, 0 /*
1660 Return the character position in the modeline that EVENT occurred over.
1661 EVENT should be a mouse event. If EVENT did not occur over a modeline,
1662 nil is returned. You can determine the actual character that the
1663 event occurred over by looking in `generated-modeline-string' at the
1664 returned character position. Note that `generated-modeline-string'
1665 is buffer-local, and you must use EVENT's buffer when retrieving
1666 `generated-modeline-string' in order to get accurate results.
1667 */ )
1668 (event)
1669 Lisp_Object event;
1670 {
1671 Charcount mbufp;
1672
1673 event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, &mbufp, 0, 0);
1674
1675 if (mbufp < 0)
1676 return Qnil;
1677 else
1678 return make_int (mbufp);
1679 }
1680
1681 DEFUN ("event-glyph", Fevent_glyph, Sevent_glyph,
1682 1, 1, 0 /*
1683 Return the glyph that the given mouse event occurred over, or nil.
1684 */ )
1685 (event)
1686 Lisp_Object event;
1687 {
1688 Lisp_Object glyph;
1689 struct window *w;
1690
1691 event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, &glyph, 0);
1692
1693 if (!w)
1694 return Qnil;
1695 else if (GLYPHP (glyph))
1696 return glyph;
1697 else
1698 return Qnil;
1699 }
1700
1701 DEFUN ("event-glyph-extent", Fevent_glyph_extent, Sevent_glyph_extent,
1702 1, 1, 0 /*
1703 Return the extent of the glyph that the given mouse event occurred over.
1704 If the event did not occur over a glyph, nil is returned.
1705 */ )
1706 (event)
1707 Lisp_Object event;
1708 {
1709 Lisp_Object extent;
1710 struct window *w;
1711
1712 event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, &extent);
1713
1714 if (!w)
1715 return Qnil;
1716 else if (EXTENTP (extent))
1717 return extent;
1718 else
1719 return Qnil;
1720 }
1721
1722 DEFUN ("event-glyph-x-pixel", Fevent_glyph_x_pixel, Sevent_glyph_x_pixel,
1723 1, 1, 0 /*
1724 Return the X pixel position of EVENT relative to the glyph it occurred over.
1725 EVENT should be a mouse event. If the event did not occur over a glyph,
1726 nil is returned.
1727 */ )
1728 (event)
1729 Lisp_Object event;
1730 {
1731 Lisp_Object extent;
1732 struct window *w;
1733 int obj_x;
1734
1735 event_pixel_translation (event, 0, 0, &obj_x, 0, &w, 0, 0, 0, 0, &extent);
1736
1737 if (w && EXTENTP (extent))
1738 return make_int (obj_x);
1739 else
1740 return Qnil;
1741 }
1742
1743 DEFUN ("event-glyph-y-pixel", Fevent_glyph_y_pixel, Sevent_glyph_y_pixel,
1744 1, 1, 0 /*
1745 Return the Y pixel position of EVENT relative to the glyph it occurred over.
1746 EVENT should be a mouse event. If the event did not occur over a glyph,
1747 nil is returned.
1748 */ )
1749 (event)
1750 Lisp_Object event;
1751 {
1752 Lisp_Object extent;
1753 struct window *w;
1754 int obj_y;
1755
1756 event_pixel_translation (event, 0, 0, 0, &obj_y, &w, 0, 0, 0, 0, &extent);
1757
1758 if (w && EXTENTP (extent))
1759 return make_int (obj_y);
1760 else
1761 return Qnil;
1762 }
1763
1764 DEFUN ("event-toolbar-button", Fevent_toolbar_button, Sevent_toolbar_button,
1765 1, 1, 0 /*
1766 Return the toolbar button that the given mouse event occurred over.
1767 If the event did not occur over a toolbar, nil is returned.
1768 */ )
1769 (event)
1770 Lisp_Object event;
1771 {
1772 #ifdef HAVE_TOOLBARS
1773 Lisp_Object button;
1774 int result;
1775
1776 result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, &button, 0);
1777
1778 if (result == OVER_TOOLBAR)
1779 {
1780 if (TOOLBAR_BUTTONP (button))
1781 return button;
1782 else
1783 return Qnil;
1784 }
1785 else
1786 #endif
1787 return Qnil;
1788 }
1789
1790 DEFUN ("event-process", Fevent_process, Sevent_process, 1, 1, 0 /*
1791 Return the process of the given process-output event.
1792 */ )
1793 (event)
1794 Lisp_Object event;
1795 {
1796 CHECK_EVENT_TYPE (event, process_event, Qprocess_event_p);
1797 return (XEVENT (event)->event.process.process);
1798 }
1799
1800 DEFUN ("event-function", Fevent_function, Sevent_function, 1, 1, 0 /*
1801 Return the callback function of EVENT.
1802 EVENT should be a timeout, misc-user, or eval event.
1803 */ )
1804 (event)
1805 Lisp_Object event;
1806 {
1807 CHECK_LIVE_EVENT (event);
1808 switch (XEVENT (event)->event_type)
1809 {
1810 case timeout_event:
1811 return (XEVENT (event)->event.timeout.function);
1812 case misc_user_event:
1813 case eval_event:
1814 return (XEVENT (event)->event.eval.function);
1815 default:
1816 return wrong_type_argument (intern ("timeout-or-eval-event-p"), event);
1817 }
1818 }
1819
1820 DEFUN ("event-object", Fevent_object, Sevent_object, 1, 1, 0 /*
1821 Return the callback function argument of EVENT.
1822 EVENT should be a timeout, misc-user, or eval event.
1823 */ )
1824 (event)
1825 Lisp_Object event;
1826 {
1827 again:
1828 CHECK_LIVE_EVENT (event);
1829 switch (XEVENT (event)->event_type)
1830 {
1831 case timeout_event:
1832 return (XEVENT (event)->event.timeout.object);
1833 case misc_user_event:
1834 case eval_event:
1835 return (XEVENT (event)->event.eval.object);
1836 default:
1837 event = wrong_type_argument (intern ("timeout-or-eval-event-p"), event);
1838 goto again;
1839 }
1840 }
1841
1842 DEFUN ("event-properties", Fevent_properties, Sevent_properties, 1, 1, 0 /*
1843 Return a list of all of the properties of EVENT.
1844 This is in the form of a property list (alternating keyword/value pairs).
1845 */ )
1846 (event)
1847 Lisp_Object event;
1848 {
1849 Lisp_Object props = Qnil;
1850 struct Lisp_Event *e;
1851 struct gcpro gcpro1;
1852
1853 CHECK_LIVE_EVENT (event);
1854 e = XEVENT (event);
1855 GCPRO1 (props);
1856
1857 props = Fcons (Qtimestamp, Fcons (Fevent_timestamp (event), props));
1858
1859 switch (e->event_type)
1860 {
1861 case process_event:
1862 props = Fcons (Qprocess, Fcons (e->event.process.process, props));
1863 break;
1864
1865 case timeout_event:
1866 props = Fcons (Qobject, Fcons (Fevent_object (event), props));
1867 props = Fcons (Qfunction, Fcons (Fevent_function (event), props));
1868 props = Fcons (Qid, Fcons (make_int (e->event.timeout.id_number),
1869 props));
1870 break;
1871
1872 case key_press_event:
1873 props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props));
1874 props = Fcons (Qkey, Fcons (Fevent_key (event), props));
1875 break;
1876
1877 case button_press_event:
1878 case button_release_event:
1879 props = Fcons (Qy, Fcons (Fevent_y_pixel (event), props));
1880 props = Fcons (Qx, Fcons (Fevent_x_pixel (event), props));
1881 props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props));
1882 props = Fcons (Qbutton, Fcons (Fevent_button (event), props));
1883 break;
1884
1885 case pointer_motion_event:
1886 props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props));
1887 props = Fcons (Qy, Fcons (Fevent_y_pixel (event), props));
1888 props = Fcons (Qx, Fcons (Fevent_x_pixel (event), props));
1889 break;
1890
1891 case misc_user_event:
1892 case eval_event:
1893 props = Fcons (Qobject, Fcons (Fevent_object (event), props));
1894 props = Fcons (Qfunction, Fcons (Fevent_function (event), props));
1895 break;
1896
1897 case magic_eval_event:
1898 case magic_event:
1899 break;
1900
1901 default:
1902 abort ();
1903 break; /* not reached; warning suppression */
1904 }
1905
1906 props = Fcons (Qchannel, Fcons (Fevent_channel (event), props));
1907 UNGCPRO;
1908
1909 return props;
1910 }
1911
1912
1913 /************************************************************************/
1914 /* initialization */
1915 /************************************************************************/
1916
1917 void
1918 syms_of_events (void)
1919 {
1920 defsubr (&Scharacter_to_event);
1921 defsubr (&Sevent_to_character);
1922
1923 defsubr (&Smake_event);
1924 defsubr (&Sdeallocate_event);
1925 defsubr (&Scopy_event);
1926 defsubr (&Seventp);
1927 defsubr (&Sevent_live_p);
1928 defsubr (&Sevent_type);
1929 defsubr (&Sevent_properties);
1930
1931 defsubr (&Sevent_timestamp);
1932 defsubr (&Sevent_key);
1933 defsubr (&Sevent_button);
1934 defsubr (&Sevent_modifier_bits);
1935 defsubr (&Sevent_modifiers);
1936 defsubr (&Sevent_x_pixel);
1937 defsubr (&Sevent_y_pixel);
1938 defsubr (&Sevent_window_x_pixel);
1939 defsubr (&Sevent_window_y_pixel);
1940 defsubr (&Sevent_over_text_area_p);
1941 defsubr (&Sevent_over_modeline_p);
1942 defsubr (&Sevent_over_border_p);
1943 defsubr (&Sevent_over_toolbar_p);
1944 defsubr (&Sevent_channel);
1945 defsubr (&Sevent_window);
1946 defsubr (&Sevent_point);
1947 defsubr (&Sevent_closest_point);
1948 defsubr (&Sevent_x);
1949 defsubr (&Sevent_y);
1950 defsubr (&Sevent_modeline_position);
1951 defsubr (&Sevent_glyph);
1952 defsubr (&Sevent_glyph_extent);
1953 defsubr (&Sevent_glyph_x_pixel);
1954 defsubr (&Sevent_glyph_y_pixel);
1955 defsubr (&Sevent_toolbar_button);
1956 defsubr (&Sevent_process);
1957 defsubr (&Sevent_function);
1958 defsubr (&Sevent_object);
1959
1960 defsymbol (&Qeventp, "eventp");
1961 defsymbol (&Qevent_live_p, "event-live-p");
1962 defsymbol (&Qkey_press_event_p, "key-press-event-p");
1963 defsymbol (&Qbutton_event_p, "button-event-p");
1964 defsymbol (&Qmouse_event_p, "mouse-event-p");
1965 defsymbol (&Qprocess_event_p, "process-event-p");
1966 defsymbol (&Qkey_press, "key-press");
1967 defsymbol (&Qbutton_press, "button-press");
1968 defsymbol (&Qbutton_release, "button-release");
1969 defsymbol (&Qmisc_user, "misc-user");
1970 defsymbol (&Qascii_character, "ascii-character");
1971 }
1972
1973 void
1974 vars_of_events (void)
1975 {
1976 DEFVAR_LISP ("character-set-property", &Vcharacter_set_property /*
1977 A symbol used to look up the 8-bit character of a keysym.
1978 To convert a keysym symbol to an 8-bit code, as when that key is
1979 bound to self-insert-command, we will look up the property that this
1980 variable names on the property list of the keysym-symbol. The window-
1981 system-specific code will set up appropriate properties and set this
1982 variable.
1983 */ );
1984 Vcharacter_set_property = Qnil;
1985
1986 Vevent_resource = Qnil;
1987
1988 QKbackspace = KEYSYM ("backspace");
1989 QKtab = KEYSYM ("tab");
1990 QKlinefeed = KEYSYM ("linefeed");
1991 QKreturn = KEYSYM ("return");
1992 QKescape = KEYSYM ("escape");
1993 QKspace = KEYSYM ("space");
1994 QKdelete = KEYSYM ("delete");
1995
1996 staticpro (&QKbackspace);
1997 staticpro (&QKtab);
1998 staticpro (&QKlinefeed);
1999 staticpro (&QKreturn);
2000 staticpro (&QKescape);
2001 staticpro (&QKspace);
2002 staticpro (&QKdelete);
2003 }