Mercurial > hg > xemacs-beta
diff src/events.c @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | ac2d302a0011 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/events.c Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,2003 @@ +/* Events: printing them, converting them to and from characters. + Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* This file has been Mule-ized. */ + +#include <config.h> +#include "lisp.h" +#include "buffer.h" +#include "console.h" +#include "console-tty.h" /* for stuff in character_to_event */ +#include "device.h" +#include "console-x.h" /* for x_event_name prototype */ +#include "extents.h" /* Just for the EXTENTP abort check... */ +#include "events.h" +#include "frame.h" +#include "glyphs.h" +#include "keymap.h" /* for key_desc_list_to_event() */ +#include "redisplay.h" +#include "window.h" + +/* Where old events go when they are explicitly deallocated. + The event chain here is cut loose before GC, so these will be freed + eventually. + */ +static Lisp_Object Vevent_resource; + +Lisp_Object Qeventp; +Lisp_Object Qevent_live_p; +Lisp_Object Qkey_press_event_p; +Lisp_Object Qbutton_event_p; +Lisp_Object Qmouse_event_p; +Lisp_Object Qprocess_event_p; + +Lisp_Object Qkey_press, Qbutton_press, Qbutton_release, Qmisc_user; +Lisp_Object Qascii_character; + +/* #### Ad-hoc hack. Should be part of define_lrecord_implementation */ +void +clear_event_resource (void) +{ + Vevent_resource = Qnil; +} + +static Lisp_Object mark_event (Lisp_Object, void (*) (Lisp_Object)); +static void print_event (Lisp_Object, Lisp_Object, int); +static int event_equal (Lisp_Object, Lisp_Object, int); +static unsigned long event_hash (Lisp_Object obj, int depth); +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("event", event, + mark_event, print_event, 0, event_equal, + event_hash, struct Lisp_Event); + +/* Make sure we lose quickly if we try to use this event */ +static void +deinitialize_event (Lisp_Object ev) +{ + int i; + struct Lisp_Event *event = XEVENT (ev); + + for (i = 0; i < ((sizeof (struct Lisp_Event)) / sizeof (int)); i++) + ((int *) event) [i] = 0xdeadbeef; + event->event_type = dead_event; + event->channel = Qnil; + set_lheader_implementation (&(event->lheader), lrecord_event); + XSET_EVENT_NEXT (ev, Qnil); +} + +/* Set everything to zero or nil so that it's predictable. */ +void +zero_event (struct Lisp_Event *e) +{ + memset (e, 0, sizeof (*e)); + set_lheader_implementation (&(e->lheader), lrecord_event); + e->event_type = empty_event; + e->next = Qnil; + e->channel = Qnil; +} + +static Lisp_Object +mark_event (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + struct Lisp_Event *event = XEVENT (obj); + + switch (event->event_type) + { + case key_press_event: + ((markobj) (event->event.key.keysym)); + break; + case process_event: + ((markobj) (event->event.process.process)); + break; + case timeout_event: + ((markobj) (event->event.timeout.function)); + ((markobj) (event->event.timeout.object)); + break; + case eval_event: + case misc_user_event: + ((markobj) (event->event.eval.function)); + ((markobj) (event->event.eval.object)); + break; + case magic_eval_event: + ((markobj) (event->event.magic_eval.object)); + break; + case button_press_event: + case button_release_event: + case pointer_motion_event: + case magic_event: + case empty_event: + case dead_event: + break; + default: + abort (); + } + ((markobj) (event->channel)); + return event->next; +} + +static void +print_event_1 (CONST char *str, Lisp_Object obj, Lisp_Object printcharfun) +{ + char buf[255]; + write_c_string (str, printcharfun); + format_event_object (buf, XEVENT (obj), 0); + write_c_string (buf, printcharfun); +} + +static void +print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + if (print_readably) + error ("printing unreadable object #<event>"); + + switch (XEVENT (obj)->event_type) + { + case key_press_event: + print_event_1 ("#<keypress-event ", obj, printcharfun); + break; + case button_press_event: + print_event_1 ("#<buttondown-event ", obj, printcharfun); + break; + case button_release_event: + print_event_1 ("#<buttonup-event ", obj, printcharfun); + break; + case magic_event: + case magic_eval_event: + print_event_1 ("#<magic-event ", obj, printcharfun); + break; + case pointer_motion_event: + { + char buf[100]; + sprintf (buf, "#<motion-event %d, %d", + XEVENT (obj)->event.motion.x, XEVENT (obj)->event.motion.y); + write_c_string (buf, printcharfun); + break; + } + case process_event: + { + write_c_string ("#<process-event ", printcharfun); + print_internal (XEVENT (obj)->event.process.process, printcharfun, 1); + break; + } + case timeout_event: + { + write_c_string ("#<timeout-event ", printcharfun); + print_internal (XEVENT (obj)->event.timeout.object, printcharfun, 1); + break; + } + case empty_event: + { + write_c_string ("#<empty-event", printcharfun); + break; + } + case misc_user_event: + case eval_event: + { + write_c_string ("#<", printcharfun); + if (XEVENT (obj)->event_type == misc_user_event) + write_c_string ("misc-user", printcharfun); + else + write_c_string ("eval", printcharfun); + write_c_string ("-event (", printcharfun); + print_internal (XEVENT (obj)->event.eval.function, printcharfun, 1); + write_c_string (" ", printcharfun); + print_internal (XEVENT (obj)->event.eval.object, printcharfun, 1); + write_c_string (")", printcharfun); + break; + } + case dead_event: + { + write_c_string ("#<DEALLOCATED-EVENT", printcharfun); + break; + } + default: + { + write_c_string ("#<UNKNOWN-EVENT-TYPE", printcharfun); + break; + } + } + write_c_string (">", printcharfun); +} + +static int +event_equal (Lisp_Object o1, Lisp_Object o2, int depth) +{ + struct Lisp_Event *e1 = XEVENT (o1); + struct Lisp_Event *e2 = XEVENT (o2); + + if (e1->event_type != e2->event_type) return 0; + if (!EQ (e1->channel, e2->channel)) return 0; +/* if (e1->timestamp != e2->timestamp) return 0; */ + switch (e1->event_type) + { + case process_event: + return (EQ (e1->event.process.process, + e2->event.process.process)); + + case timeout_event: + if (NILP (Fequal (e1->event.timeout.function, + e2->event.timeout.function))) + return 0; + if (NILP (Fequal (e1->event.timeout.object, + e2->event.timeout.object))) + return 0; + return 1; + + case key_press_event: + return ((EQ (e1->event.key.keysym, + e2->event.key.keysym) + && (e1->event.key.modifiers + == e2->event.key.modifiers))); + + case button_press_event: + case button_release_event: + return (((e1->event.button.button + == e2->event.button.button) + && (e1->event.button.modifiers + == e2->event.button.modifiers))); + + case pointer_motion_event: + return ((e1->event.motion.x == e2->event.motion.x + && e1->event.motion.y == e2->event.motion.y)); + + case misc_user_event: + case eval_event: + if (NILP (Fequal (e1->event.eval.function, + e2->event.eval.function))) + return 0; + if (NILP (Fequal (e1->event.eval.object, + e2->event.eval.object))) + return 0; + return 1; + + case magic_eval_event: + if (e1->event.magic_eval.internal_function != + e2->event.magic_eval.internal_function) + return 0; + if (NILP (Fequal (e1->event.magic_eval.object, + e2->event.magic_eval.object))) + return 0; + return 1; + + case magic_event: + { + Lisp_Object console; + + console = CDFW_CONSOLE (e1->channel); + +#ifdef HAVE_X_WINDOWS + /* XEvent is actually a union which means that we can't just use == */ + if (CONSOLE_X_P (XCONSOLE (console))) + return (!memcmp ((XEvent *) &e1->event.magic.underlying_x_event, + (XEvent *) &e2->event.magic.underlying_x_event, + sizeof (e1->event.magic.underlying_x_event))); +#endif +#ifdef HAVE_NEXTSTEP + if (CONSOLE_NS_P (XCONSOLE (console))) + return (e1->event.magic.underlying_ns_event == + e2->event.magic.underlying_ns_event); +#endif + return (e1->event.magic.underlying_tty_event == + e2->event.magic.underlying_tty_event); + } + + case empty_event: /* Empty and deallocated events are equal. */ + case dead_event: + return 1; + + default: + abort (); + return 0; /* not reached; warning suppression */ + } +} + +static unsigned long +event_hash (Lisp_Object obj, int depth) +{ + struct Lisp_Event *e = XEVENT (obj); + unsigned long hash; + + hash = HASH2 (e->event_type, LISP_HASH (e->channel)); + switch (e->event_type) + { + case process_event: + return HASH2 (hash, LISP_HASH (e->event.process.process)); + + case timeout_event: + return HASH3 (hash, internal_hash (e->event.timeout.function, depth + 1), + internal_hash (e->event.timeout.object, depth + 1)); + + case key_press_event: + return HASH3 (hash, LISP_HASH (e->event.key.keysym), + e->event.key.modifiers); + + case button_press_event: + case button_release_event: + return HASH3 (hash, e->event.button.button, e->event.button.modifiers); + + case pointer_motion_event: + return HASH3 (hash, e->event.motion.x, e->event.motion.y); + + case misc_user_event: + case eval_event: + return HASH3 (hash, internal_hash (e->event.eval.function, depth + 1), + internal_hash (e->event.eval.object, depth + 1)); + + case magic_eval_event: + return HASH3 (hash, + (unsigned long) e->event.magic_eval.internal_function, + internal_hash (e->event.magic_eval.object, depth + 1)); + + case magic_event: + { + Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (e)); +#ifdef HAVE_X_WINDOWS + if (CONSOLE_X_P (XCONSOLE (console))) + return + HASH2 (hash, + memory_hash (&e->event.magic.underlying_x_event, + sizeof (e->event.magic.underlying_x_event))); +#endif +#ifdef HAVE_NEXTSTEP + if (CONSOLE_NS_P (XCONSOLE (console))) + return + HASH2 (hash, + memory_hash (&e->event.magic.underlying_ns_event, + sizeof (e->event.magic.underlying_ns_event))); +#endif + return + HASH2 (hash, + memory_hash (&e->event.magic.underlying_tty_event, + sizeof (e->event.magic.underlying_tty_event))); + } + + case empty_event: + case dead_event: + return hash; + + default: + abort (); + } + + return 0; +} + + +/* #### This should accept a type and props (as returned by + event-properties) to allow creation of any type of event. + This is useful, for example, in Lisp code that might want + to determine if, for a given button-down event, what the + binding for the corresponding button-up event is. */ + +DEFUN ("make-event", Fmake_event, Smake_event, 0, 0, 0 /* +Create a new empty event. +WARNING, the event object returned may be a reused one; see the function +`deallocate-event'. +*/ ) + () +{ + Lisp_Object event; + + if (!NILP (Vevent_resource)) + { + event = Vevent_resource; + Vevent_resource = XEVENT_NEXT (event); + } + else + { + event = allocate_event (); + } + zero_event (XEVENT (event)); + return event; +} + +DEFUN ("deallocate-event", Fdeallocate_event, Sdeallocate_event, 1, 1, 0 /* +Allow the given event structure to be reused. +You MUST NOT use this event object after calling this function with it. +You will lose. It is not necessary to call this function, as event +objects are garbage-collected like all other objects; however, it may +be more efficient to explicitly deallocate events when you are sure +that that is safe. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_EVENT (event); + + if (XEVENT_TYPE (event) == dead_event) + error ("this event is already deallocated!"); + + assert (XEVENT_TYPE (event) <= last_event_type); + +#if 0 + { + int i; + extern Lisp_Object Vlast_command_event; + extern Lisp_Object Vlast_input_event, Vunread_command_event; + extern Lisp_Object Vthis_command_keys, Vrecent_keys_ring; + + if (EQ (event, Vlast_command_event)) + abort (); + if (EQ (event, Vlast_input_event)) + abort (); + if (EQ (event, Vunread_command_event)) + abort (); + for (i = 0; i < XVECTOR (Vthis_command_keys)->size; i++) + if (EQ (event, vector_data (XVECTOR (Vthis_command_keys)) [i])) + abort (); + for (i = 0; i < XVECTOR (Vrecent_keys_ring)->size; i++) + if (EQ (event, vector_data (XVECTOR (Vrecent_keys_ring)) [i])) + abort (); + } +#endif /* 0 */ + + assert (!EQ (event, Vevent_resource)); + deinitialize_event (event); +#ifndef ALLOC_NO_POOLS + XSET_EVENT_NEXT (event, Vevent_resource); + Vevent_resource = event; +#endif + return Qnil; +} + +DEFUN ("copy-event", Fcopy_event, Scopy_event, 1, 2, 0 /* +Make a copy of the given event object. +If a second argument is given, the first event is copied into the second +and the second is returned. If the second argument is not supplied (or +is nil) then a new event will be made as with `allocate-event.' See also +the function `deallocate-event'. +*/ ) + (event1, event2) + Lisp_Object event1, event2; +{ + CHECK_LIVE_EVENT (event1); + if (NILP (event2)) + event2 = Fmake_event (); + else CHECK_LIVE_EVENT (event2); + if (EQ (event1, event2)) + return signal_simple_continuable_error_2 + ("copy-event called with `eq' events", event1, event2); + + assert (XEVENT_TYPE (event1) <= last_event_type); + assert (XEVENT_TYPE (event2) <= last_event_type); + + { + Lisp_Object save_next = XEVENT_NEXT (event2); + + *XEVENT (event2) = *XEVENT (event1); + XSET_EVENT_NEXT (event2, save_next); + return (event2); + } +} + + + +/* Given a chain of events (or possibly nil), deallocate them all. */ + +void +deallocate_event_chain (Lisp_Object event_chain) +{ + while (!NILP (event_chain)) + { + Lisp_Object next = XEVENT_NEXT (event_chain); + Fdeallocate_event (event_chain); + event_chain = next; + } +} + +/* Return the last event in a chain. + NOTE: You cannot pass nil as a value here! The routine will + abort if you do. */ + +Lisp_Object +event_chain_tail (Lisp_Object event_chain) +{ + while (1) + { + Lisp_Object next = XEVENT_NEXT (event_chain); + if (NILP (next)) + return event_chain; + event_chain = next; + } +} + +/* Enqueue a single event onto the end of a chain of events. + HEAD points to the first event in the chain, TAIL to the last event. + If the chain is empty, both values should be nil. */ + +void +enqueue_event (Lisp_Object event, Lisp_Object *head, Lisp_Object *tail) +{ + assert (NILP (XEVENT_NEXT (event))); + assert (!EQ (*tail, event)); + + if (!NILP (*tail)) + XSET_EVENT_NEXT (*tail, event); + else + *head = event; + *tail = event; + + assert (!EQ (event, XEVENT_NEXT (event))); +} + +/* Remove an event off the head of a chain of events and return it. + HEAD points to the first event in the chain, TAIL to the last event. */ + +Lisp_Object +dequeue_event (Lisp_Object *head, Lisp_Object *tail) +{ + Lisp_Object event; + + event = *head; + *head = XEVENT_NEXT (event); + XSET_EVENT_NEXT (event, Qnil); + if (NILP (*head)) + *tail = Qnil; + return event; +} + +/* Enqueue a chain of events (or possibly nil) onto the end of another + chain of events. HEAD points to the first event in the chain being + queued onto, TAIL to the last event. If the chain is empty, both values + should be nil. */ + +void +enqueue_event_chain (Lisp_Object event_chain, Lisp_Object *head, + Lisp_Object *tail) +{ + if (NILP (event_chain)) + return; + + if (NILP (*head)) + { + *head = event_chain; + *tail = event_chain; + } + else + { + XSET_EVENT_NEXT (*tail, event_chain); + *tail = event_chain_tail (event_chain); + } +} + +/* Return the number of events (possibly 0) on an event chain. */ + +int +event_chain_count (Lisp_Object event_chain) +{ + Lisp_Object event; + int n = 0; + + EVENT_CHAIN_LOOP (event, event_chain) + n++; + + return n; +} + +/* Find the event before EVENT in an event chain. This aborts + if the event is not in the chain. */ + +Lisp_Object +event_chain_find_previous (Lisp_Object event_chain, Lisp_Object event) +{ + Lisp_Object previous = Qnil; + + while (!NILP (event_chain)) + { + if (EQ (event_chain, event)) + return previous; + previous = event_chain; + event_chain = XEVENT_NEXT (event_chain); + } + + abort (); + return Qnil; +} + +Lisp_Object +event_chain_nth (Lisp_Object event_chain, int n) +{ + Lisp_Object event; + EVENT_CHAIN_LOOP (event, event_chain) + { + if (!n) + return event; + n--; + } + return Qnil; +} + +Lisp_Object +copy_event_chain (Lisp_Object event_chain) +{ + Lisp_Object new_chain = Qnil; + Lisp_Object new_chain_tail = Qnil; + Lisp_Object event; + + EVENT_CHAIN_LOOP (event, event_chain) + { + Lisp_Object copy = Fcopy_event (event, Qnil); + enqueue_event (copy, &new_chain, &new_chain_tail); + } + + return new_chain; +} + + + +Lisp_Object QKbackspace, QKtab, QKlinefeed, QKreturn, QKescape, + QKspace, QKdelete; + +int +command_event_p (Lisp_Object event) +{ + switch (XEVENT_TYPE (event)) + { + case key_press_event: + case button_press_event: + case button_release_event: + case misc_user_event: + return (1); + default: + return (0); + } +} + + +void +character_to_event (Emchar c, struct Lisp_Event *event, struct console *con, + int use_console_meta_flag) +{ + Lisp_Object k = Qnil; + unsigned int m = 0; + if (event->event_type == dead_event) + error ("character-to-event called with a deallocated event!"); + + c &= 255; + + if (c > 127 && c <= 255) + { + int meta_flag = 1; + if (use_console_meta_flag && CONSOLE_TTY_P (con)) + meta_flag = TTY_FLAGS (con).meta_key; + switch (meta_flag) + { + case 0: /* ignore top bit; it's parity */ + c -= 128; + break; + case 1: /* top bit is meta */ + c -= 128; + m = MOD_META; + break; + default: /* this is a real character */ + break; + } + } + if (c < ' ') c += '@', m |= MOD_CONTROL; + if (m & MOD_CONTROL) + { + switch (c) + { + case 'I': k = QKtab; m &= ~MOD_CONTROL; break; + case 'J': k = QKlinefeed; m &= ~MOD_CONTROL; break; + case 'M': k = QKreturn; m &= ~MOD_CONTROL; break; + case '[': k = QKescape; m &= ~MOD_CONTROL; break; +# if 0 + /* This is probably too controversial... */ + case 'H': k = QKbackspace; m &= ~MOD_CONTROL; break; +# endif + } + if (c >= 'A' && c <= 'Z') c -= 'A'-'a'; + } + else if (c == 127) + k = QKdelete; + else if (c == ' ') + k = QKspace; + + event->event_type = key_press_event; + event->timestamp = 0; /* #### */ + event->channel = make_console (con); + event->event.key.keysym = (!NILP (k) ? k : make_char (c)); + event->event.key.modifiers = m; +} + + +/* This variable controls what character name -> character code mapping + we are using. Window-system-specific code sets this to some symbol, + and we use that symbol as the plist key to convert keysyms into 8-bit + codes. In this way one can have several character sets predefined and + switch them by changing this. + */ +Lisp_Object Vcharacter_set_property; + +Emchar +event_to_character (struct Lisp_Event *event, + int allow_extra_modifiers, + int allow_meta, + int allow_non_ascii) +{ + Emchar c = 0; + Lisp_Object code; + + if (event->event_type != key_press_event) + { + if (event->event_type == dead_event) abort (); + return -1; + } + if (!allow_extra_modifiers && + event->event.key.modifiers & (MOD_SUPER|MOD_HYPER|MOD_ALT)) + return -1; + if (CHAR_OR_CHAR_INTP (event->event.key.keysym)) + c = XCHAR_OR_CHAR_INT (event->event.key.keysym); + else if (!SYMBOLP (event->event.key.keysym)) + abort (); + else if (allow_non_ascii && !NILP (Vcharacter_set_property) + /* Allow window-system-specific extensibility of + keysym->code mapping */ + && CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym, + Vcharacter_set_property, + Qnil))) + c = XCHAR_OR_CHAR_INT (code); + else if (CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym, + Qascii_character, Qnil))) + c = XCHAR_OR_CHAR_INT (code); + else + return -1; + + if (event->event.key.modifiers & MOD_CONTROL) + { + if (c >= 'a' && c <= 'z') + c -= ('a' - 'A'); + else + /* reject Control-Shift- keys */ + if (c >= 'A' && c <= 'Z' && !allow_extra_modifiers) + return -1; + + if (c >= '@' && c <= '_') + c -= '@'; + else if (c == ' ') /* C-space and C-@ are the same. */ + c = 0; + else + /* reject keys that can't take Control- modifiers */ + if (! allow_extra_modifiers) return -1; + } + + if (event->event.key.modifiers & MOD_META) + { + if (! allow_meta) return -1; + if (c & 0200) return -1; /* don't allow M-oslash (overlap) */ + c |= 0200; + } + return c; +} + + +DEFUN ("event-to-character", Fevent_to_character, Sevent_to_character, + 1, 4, 0 /* +Return the closest ASCII approximation to the given event object. +If the event isn't a keypress, this returns nil. +If the ALLOW-EXTRA-MODIFIERS argument is non-nil, then this is lenient in + its translation; it will ignore modifier keys other than control and meta, + and will ignore the shift modifier on those characters which have no + shifted ASCII equivalent (Control-Shift-A for example, will be mapped to + the same ASCII code as Control-A). +If the ALLOW-META argument is non-nil, then the Meta modifier will be + represented by turning on the high bit of the byte returned; otherwise, nil + will be returned for events containing the Meta modifier. +If the ALLOW-NON-ASCII argument is non-nil, then characters which are + present in the prevailing character set (see the `character-set-property' + variable) will be returned as their code in that character set, instead of + the return value being restricted to ASCII. +Note that specifying both ALLOW-META and ALLOW-NON-ASCII is ambiguous, as + both use the high bit; `M-x' and `oslash' will be indistinguishable. +*/ ) + (event, allow_extra_modifiers, allow_meta, allow_non_ascii) + Lisp_Object event, allow_extra_modifiers, allow_meta, allow_non_ascii; +{ + Emchar c; + CHECK_LIVE_EVENT (event); + c = event_to_character (XEVENT (event), + !NILP (allow_extra_modifiers), + !NILP (allow_meta), + !NILP (allow_non_ascii)); + return (c < 0 ? Qnil : make_char (c)); +} + +DEFUN ("character-to-event", Fcharacter_to_event, Scharacter_to_event, + 1, 4, 0 /* +Converts a keystroke specifier intoto an event structure, replete with +bucky bits. The keystroke is the first argument, and the event to fill +in is the second. This function contains knowledge about what the codes +``mean'' -- for example, the number 9 is converted to the character ``Tab'', +not the distinct character ``Control-I''. + +Note that CH (the keystroke specifier) can be an integer, a character, + a symbol such as 'clear, or a list such as '(control backspace). + +If the optional second argument is an event, it is modified; otherwise, a + new event object is created. + +Optional third arg CONSOLE is the console to store in the event, and defaults + to the selected console. + +If CH is an integer or character, the high bit may be interpreted as the + meta key. (This is done for backward compatibility in lots of places.) + If USE-CONSOLE-META-FLAG is nil, this will always be the case. If + USE-CONSOLE-META-FLAG is non-nil, the `meta' flag for CONSOLE affects + whether the high bit is interpreted as a meta key. (See `set-input-mode'.) + If you don't want this silly meta interpretation done, you should pass + in a list containing the character. + +Beware that character-to-event and event-to-character are not strictly + inverse functions, since events contain much more information than the + ASCII character set can encode. +*/ ) + (ch, event, console, use_console_meta_flag) + Lisp_Object ch, event, console, use_console_meta_flag; +{ + struct console *con = decode_console (console); + if (NILP (event)) + event = Fmake_event (); + else + CHECK_LIVE_EVENT (event); + if (CONSP (ch) || SYMBOLP (ch)) + key_desc_list_to_event (ch, event, 1); + else + { + CHECK_CHAR_COERCE_INT (ch); + character_to_event (XCHAR (ch), XEVENT (event), con, + !NILP (use_console_meta_flag)); + } + return event; +} + +void +nth_of_key_sequence_as_event (Lisp_Object seq, int n, Lisp_Object event) +{ + assert (STRINGP (seq) || VECTORP (seq)); + assert (n < XINT (Flength (seq))); + + if (STRINGP (seq)) + { + Emchar ch = string_char (XSTRING (seq), n); + Fcharacter_to_event (make_char (ch), event, Qnil, Qnil); + } + else + { + Lisp_Object keystroke = vector_data (XVECTOR (seq))[n]; + if (EVENTP (keystroke)) + Fcopy_event (keystroke, event); + else + Fcharacter_to_event (keystroke, event, Qnil, Qnil); + } +} + +Lisp_Object +key_sequence_to_event_chain (Lisp_Object seq) +{ + int len = XINT (Flength (seq)); + int i; + Lisp_Object head = Qnil, tail = Qnil; + + for (i = 0; i < len; i++) + { + Lisp_Object event = Fmake_event (); + nth_of_key_sequence_as_event (seq, i, event); + enqueue_event (event, &head, &tail); + } + + return head; +} + +void +format_event_object (char *buf, struct Lisp_Event *event, int brief) +{ + int mouse_p = 0; + int mod = 0; + Lisp_Object key; + + switch (event->event_type) + { + case key_press_event: + { + mod = event->event.key.modifiers; + key = event->event.key.keysym; + /* Hack. */ + if (! brief && CHARP (key) && + mod & (MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER)) + { + int k = XCHAR (key); + if (k >= 'a' && k <= 'z') + key = make_char (k - ('a' - 'A')); + else if (k >= 'A' && k <= 'Z') + mod |= MOD_SHIFT; + } + break; + } + case button_release_event: + mouse_p++; + /* Fall through */ + case button_press_event: + { + mouse_p++; + mod = event->event.button.modifiers; + key = make_char (event->event.button.button + '0'); + break; + } + case magic_event: + { + CONST char *name = 0; + Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (event)); + +#ifdef HAVE_X_WINDOWS + if (CONSOLE_X_P (XCONSOLE (console))) + name = + x_event_name (event->event.magic.underlying_x_event.xany.type); +#endif +#ifdef HAVE_NEXTSTEP + if (CONSOLE_NS_P (XCONSOLE (console))) + name = ns_event_name (event->event.magic.underlying_ns_event); +#endif + if (name) strcpy (buf, name); + else strcpy (buf, "???"); + return; + } + case magic_eval_event: strcpy (buf, "magic-eval"); return; + case pointer_motion_event: strcpy (buf, "motion"); return; + case misc_user_event: strcpy (buf, "misc-user"); return; + case eval_event: strcpy (buf, "eval"); return; + case process_event: strcpy (buf, "process");return; + case timeout_event: strcpy (buf, "timeout");return; + case empty_event: strcpy (buf, "EMPTY-EVENT"); return; + case dead_event: strcpy (buf, "DEAD-EVENT"); return; + default: + abort (); + } +#define modprint1(x) { strcpy (buf, (x)); buf += sizeof (x)-1; } +#define modprint(x,y) { if (brief) modprint1 (y) else modprint1 (x) } + if (mod & MOD_CONTROL) modprint ("control-", "C-"); + if (mod & MOD_META) modprint ("meta-", "M-"); + if (mod & MOD_SUPER) modprint ("super-", "S-"); + if (mod & MOD_HYPER) modprint ("hyper-", "H-"); + if (mod & MOD_ALT) modprint ("alt-", "A-"); + if (mod & MOD_SHIFT) modprint ("shift-", "Sh-"); + if (mouse_p) + { + modprint1 ("button"); + --mouse_p; + } +#undef modprint +#undef modprint1 + + if (CHARP (key)) + { + buf += set_charptr_emchar ((Bufbyte *) buf, XCHAR (key)); + *buf = 0; + } + else if (SYMBOLP (key)) + { + CONST char *str = 0; + if (brief) + { + if (EQ (key, QKlinefeed)) str = "LFD"; + else if (EQ (key, QKtab)) str = "TAB"; + else if (EQ (key, QKreturn)) str = "RET"; + else if (EQ (key, QKescape)) str = "ESC"; + else if (EQ (key, QKdelete)) str = "DEL"; + else if (EQ (key, QKspace)) str = "SPC"; + else if (EQ (key, QKbackspace)) str = "BS"; + } + if (str) + { + int i = strlen (str); + memcpy (buf, str, i+1); + str += i; + } + else + { + memcpy (buf, string_data (XSYMBOL (key)->name), + string_length (XSYMBOL (key)->name) + 1); + str += string_length (XSYMBOL (key)->name); + } + } + else + abort (); + if (mouse_p) + strncpy (buf, "up", 4); +} + +DEFUN ("eventp", Feventp, Seventp, 1, 1, 0 /* +True if OBJECT is an event object. +*/ ) + (object) + Lisp_Object object; +{ + return ((EVENTP (object)) ? Qt : Qnil); +} + +DEFUN ("event-live-p", Fevent_live_p, Sevent_live_p, 1, 1, 0 /* +True if OBJECT is an event object that has not been deallocated. +*/ ) + (object) + Lisp_Object object; +{ + return ((EVENTP (object) && XEVENT (object)->event_type != dead_event) + ? Qt : Qnil); +} + +#if 0 /* debugging functions */ + +xxDEFUN ("event-next", Fevent_next, Sevent_next, 1, 1, 0 /* +Return the event object's `next' event, or nil if it has none. +The `next-event' field is changed by calling `set-next-event'. +*/ ) + (event) + Lisp_Object event; +{ + struct Lisp_Event *e; + CHECK_LIVE_EVENT (event); + + return XEVENT_NEXT (event); +} + +xxDEFUN ("set-event-next", Fset_event_next, Sset_event_next, 2, 2, 0 /* +Set the `next event' of EVENT to NEXT-EVENT. +NEXT-EVENT must be an event object or nil. +*/ ) + (event, next_event) + Lisp_Object event, next_event; +{ + Lisp_Object ev; + + CHECK_LIVE_EVENT (event); + if (NILP (next_event)) + { + XSET_EVENT_NEXT (event, Qnil); + return (Qnil); + } + + CHECK_LIVE_EVENT (next_event); + + EVENT_CHAIN_LOOP (ev, XEVENT_NEXT (event)) + { + QUIT; + if (EQ (ev, event)) + signal_error (Qerror, + list3 (build_string ("Cyclic event-next"), + event, + next_event)); + } + XSET_EVENT_NEXT (event, next_event); + return (next_event); +} + +#endif /* 0 */ + +DEFUN ("event-type", Fevent_type, Sevent_type, 1, 1, 0 /* +Return the type of EVENT. +This will be a symbol; one of + +key-press A key was pressed. +button-press A mouse button was pressed. +button-release A mouse button was released. +misc-user Some other user action happened; typically, this is + a menu selection or scrollbar action. +motion The mouse moved. +process Input is available from a subprocess. +timeout A timeout has expired. +eval This causes a specified action to occur when dispatched. +magic Some window-system-specific event has occurred. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_LIVE_EVENT (event); + switch (XEVENT (event)->event_type) + { + case key_press_event: + return Qkey_press; + + case button_press_event: + return Qbutton_press; + + case button_release_event: + return Qbutton_release; + + case misc_user_event: + return Qmisc_user; + + case pointer_motion_event: + return Qmotion; + + case process_event: + return Qprocess; + + case timeout_event: + return Qtimeout; + + case eval_event: + return Qeval; + + case magic_event: + case magic_eval_event: + return Qmagic; + + default: + abort (); + return Qnil; + } +} + +DEFUN ("event-timestamp", Fevent_timestamp, Sevent_timestamp, 1, 1, 0 /* +Return the timestamp of the given event object. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_LIVE_EVENT (event); + /* This junk is so that timestamps don't get to be negative, but contain + as many bits as this particular emacs will allow. + */ + return make_int (((1L << (VALBITS - 1)) - 1) & + XEVENT (event)->timestamp); +} + +#define CHECK_EVENT_TYPE(e,t1,sym) \ +{ CHECK_LIVE_EVENT (e); \ + if (XEVENT(e)->event_type != (t1)) \ + e = wrong_type_argument ((sym),(e)); \ +} + +#define CHECK_EVENT_TYPE2(e,t1,t2,sym) \ +{ CHECK_LIVE_EVENT (e); \ + if (XEVENT(e)->event_type != (t1) && XEVENT(e)->event_type != (t2)) \ + e = wrong_type_argument ((sym),(e)); \ +} + +DEFUN ("event-key", Fevent_key, Sevent_key, 1, 1, 0 /* +Return the Keysym of the given key-press event. +This will be the ASCII code of a printing character, or a symbol. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_EVENT_TYPE (event, key_press_event, Qkey_press_event_p); + return (XEVENT (event)->event.key.keysym); +} + +DEFUN ("event-button", Fevent_button, Sevent_button, 1, 1, 0 /* +Return the button-number of the given mouse-button-press event. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_EVENT_TYPE2 (event, button_press_event, button_release_event, + Qbutton_event_p); +#ifdef HAVE_WINDOW_SYSTEM + return make_int (XEVENT (event)->event.button.button); +#else /* !HAVE_WINDOW_SYSTEM */ + return Qzero; +#endif /* !HAVE_WINDOW_SYSTEM */ +} + +DEFUN ("event-modifier-bits", Fevent_modifier_bits, Sevent_modifier_bits, + 1, 1, 0 /* +Return a number representing the modifier keys which were down +when the given mouse or keyboard event was produced. See also the function +event-modifiers. +*/ ) + (event) + Lisp_Object event; +{ + again: + CHECK_LIVE_EVENT (event); + if (XEVENT (event)->event_type == key_press_event) + return make_int (XEVENT (event)->event.key.modifiers); + else if (XEVENT (event)->event_type == button_press_event || + XEVENT (event)->event_type == button_release_event) + return make_int (XEVENT (event)->event.button.modifiers); + else if (XEVENT (event)->event_type == pointer_motion_event) + return make_int (XEVENT (event)->event.motion.modifiers); + else + { + event = wrong_type_argument (intern ("key-or-mouse-event-p"), event); + goto again; + } +} + +DEFUN ("event-modifiers", Fevent_modifiers, Sevent_modifiers, 1, 1, 0 /* +Return a list of symbols, the names of the modifier keys +which were down when the given mouse or keyboard event was produced. +See also the function event-modifier-bits. +*/ ) + (event) + Lisp_Object event; +{ + int mod = XINT (Fevent_modifier_bits (event)); + Lisp_Object result = Qnil; + if (mod & MOD_SHIFT) result = Fcons (Qshift, result); + if (mod & MOD_ALT) result = Fcons (Qalt, result); + if (mod & MOD_HYPER) result = Fcons (Qhyper, result); + if (mod & MOD_SUPER) result = Fcons (Qsuper, result); + if (mod & MOD_META) result = Fcons (Qmeta, result); + if (mod & MOD_CONTROL) result = Fcons (Qcontrol, result); + return result; +} + +static int +event_x_y_pixel_internal (Lisp_Object event, int *x, int *y, int relative) +{ + struct window *w; + struct frame *f; + + if (XEVENT (event)->event_type == pointer_motion_event) + { + *x = XEVENT (event)->event.motion.x; + *y = XEVENT (event)->event.motion.y; + } + else if (XEVENT (event)->event_type == button_press_event || + XEVENT (event)->event_type == button_release_event) + { + *x = XEVENT (event)->event.button.x; + *y = XEVENT (event)->event.button.y; + } + else + return 0; + + f = XFRAME (EVENT_CHANNEL (XEVENT (event))); + + if (relative) + { + w = find_window_by_pixel_pos (*x, *y, f->root_window); + + if (!w) + return 1; /* #### What should really happen here. */ + + *x -= w->pixel_left; + *y -= w->pixel_top; + } + else + { + *y -= FRAME_REAL_TOP_TOOLBAR_HEIGHT (f); + *x -= FRAME_REAL_LEFT_TOOLBAR_WIDTH (f); + } + + return 1; +} + +DEFUN ("event-window-x-pixel", Fevent_window_x_pixel, Sevent_window_x_pixel, + 1, 1, 0 /* +Return the X position in pixels of the given mouse event. +The value returned is relative to the window the event occurred in. +This will signal an error if the event is not a mouse-motion, button-press, +or button-release event. See also `event-x-pixel'. +*/ ) + (event) + Lisp_Object event; +{ + int x, y; + + CHECK_LIVE_EVENT (event); + + if (!event_x_y_pixel_internal (event, &x, &y, 1)) + return wrong_type_argument (Qmouse_event_p, event); + else + return make_int (x); +} + +DEFUN ("event-window-y-pixel", Fevent_window_y_pixel, Sevent_window_y_pixel, + 1, 1, 0 /* +Return the Y position in pixels of the given mouse event. +The value returned is relative to the window the event occurred in. +This will signal an error if the event is not a mouse-motion, button-press, +or button-release event. See also `event-y-pixel'. +*/ ) + (event) + Lisp_Object event; +{ + int x, y; + + CHECK_LIVE_EVENT (event); + + if (!event_x_y_pixel_internal (event, &x, &y, 1)) + return wrong_type_argument (Qmouse_event_p, event); + else + return make_int (y); +} + +DEFUN ("event-x-pixel", Fevent_x_pixel, Sevent_x_pixel, + 1, 1, 0 /* +Return the X position in pixels of the given mouse event. +The value returned is relative to the frame the event occurred in. +This will signal an error if the event is not a mouse-motion, button-press, +or button-release event. See also `event-window-x-pixel'. +*/ ) + (event) + Lisp_Object event; +{ + int x, y; + + CHECK_LIVE_EVENT (event); + + if (!event_x_y_pixel_internal (event, &x, &y, 0)) + return wrong_type_argument (Qmouse_event_p, event); + else + return make_int (x); +} + +DEFUN ("event-y-pixel", Fevent_y_pixel, Sevent_y_pixel, + 1, 1, 0 /* +Return the Y position in pixels of the given mouse event. +The value returned is relative to the frame the event occurred in. +This will signal an error if the event is not a mouse-motion, button-press, +or button-release event. See also `event-window-y-pixel'. +*/ ) + (event) + Lisp_Object event; +{ + int x, y; + + CHECK_LIVE_EVENT (event); + + if (!event_x_y_pixel_internal (event, &x, &y, 0)) + return wrong_type_argument (Qmouse_event_p, event); + else + return make_int (y); +} + +/* Given an event, return a value: + + OVER_TOOLBAR: over one of the 4 frame toolbars + OVER_MODELINE: over a modeline + OVER_BORDER: over an internal border + OVER_NOTHING: over the text area, but not over text + OVER_OUTSIDE: outside of the frame border + OVER_TEXT: over text in the text area + + and return: + + The X char position in CHAR_X, if not a null pointer. + The Y char position in CHAR_Y, if not a null pointer. + (These last two values are relative to the window the event is over.) + The window it's over in W, if not a null pointer. + The buffer position it's over in BUFP, if not a null pointer. + The closest buffer position in CLOSEST, if not a null pointer. + + OBJ_X, OBJ_Y, OBJ1, and OBJ2 are as in pixel_to_glyph_translation(). +*/ + +static int +event_pixel_translation (Lisp_Object event, int *char_x, int *char_y, + int *obj_x, int *obj_y, + struct window **w, Bufpos *bufp, Bufpos *closest, + Charcount *modeline_closest, + Lisp_Object *obj1, Lisp_Object *obj2) +{ + int pix_x = 0; + int pix_y = 0; + int result; + Lisp_Object frame; + + int ret_x, ret_y, ret_obj_x, ret_obj_y; + struct window *ret_w; + Bufpos ret_bufp, ret_closest; + Charcount ret_modeline_closest; + Lisp_Object ret_obj1, ret_obj2; + + CHECK_LIVE_EVENT (event); + if (XEVENT (event)->event_type == pointer_motion_event) + { + pix_x = XEVENT (event)->event.motion.x; + pix_y = XEVENT (event)->event.motion.y; + frame = XEVENT (event)->channel; + } + else if (XEVENT (event)->event_type == button_press_event || + XEVENT (event)->event_type == button_release_event) + { + pix_x = XEVENT (event)->event.button.x; + pix_y = XEVENT (event)->event.button.y; + frame = XEVENT (event)->channel; + } + else + wrong_type_argument (Qmouse_event_p, event); + + result = pixel_to_glyph_translation (XFRAME (frame), pix_x, pix_y, + &ret_x, &ret_y, &ret_obj_x, &ret_obj_y, + &ret_w, &ret_bufp, &ret_closest, + &ret_modeline_closest, + &ret_obj1, &ret_obj2); + + if (result == OVER_NOTHING || result == OVER_OUTSIDE) + ret_bufp = 0; + else if (ret_w && NILP (ret_w->buffer)) + /* Why does this happen? (Does it still happen?) + I guess the window has gotten reused as a non-leaf... */ + ret_w = 0; + + /* #### pixel_to_glyph_translation() sometimes returns garbage... + The word has type Lisp_Record (presumably meaning `extent') but the + pointer points to random memory, often filled with 0, sometimes not. + */ + /* #### Chuck, do we still need this crap? */ + if (!NILP (ret_obj1) && !(GLYPHP (ret_obj1) +#ifdef HAVE_TOOLBARS + || TOOLBAR_BUTTONP (ret_obj1) +#endif + )) + abort (); + if (!NILP (ret_obj2) && !(EXTENTP (ret_obj2) + || CONSP (ret_obj2))) + abort (); + + if (char_x) + *char_x = ret_x; + if (char_y) + *char_y = ret_y; + if (obj_x) + *obj_x = ret_obj_x; + if (obj_y) + *obj_y = ret_obj_y; + if (w) + *w = ret_w; + if (bufp) + *bufp = ret_bufp; + if (closest) + *closest = ret_closest; + if (modeline_closest) + *modeline_closest = ret_modeline_closest; + if (obj1) + *obj1 = ret_obj1; + if (obj2) + *obj2 = ret_obj2; + + return result; +} + +DEFUN ("event-over-text-area-p", Fevent_over_text_area_p, + Sevent_over_text_area_p, 1, 1, 0 /* +Return whether the given mouse event occurred over the text area of a window. +The modeline is not considered to be part of the text area. +*/ ) + (event) + Lisp_Object event; +{ + int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + if (result == OVER_TEXT || result == OVER_NOTHING) + return Qt; + else + return Qnil; +} + +DEFUN ("event-over-modeline-p", Fevent_over_modeline_p, Sevent_over_modeline_p, + 1, 1, 0 /* +Return whether the given mouse event occurred over the modeline of a window. +*/ ) + (event) + Lisp_Object event; +{ + int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + if (result == OVER_MODELINE) + return Qt; + else + return Qnil; +} + +DEFUN ("event-over-border-p", Fevent_over_border_p, Sevent_over_border_p, + 1, 1, 0 /* +Return whether the given mouse event occurred over an internal border. +*/ ) + (event) + Lisp_Object event; +{ + int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + if (result == OVER_BORDER) + return Qt; + else + return Qnil; +} + +DEFUN ("event-over-toolbar-p", Fevent_over_toolbar_p, Sevent_over_toolbar_p, + 1, 1, 0 /* +Return whether the given mouse event occurred over a toolbar. +*/ ) + (event) + Lisp_Object event; +{ + int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + if (result == OVER_TOOLBAR) + return Qt; + else + return Qnil; +} + +struct console * +event_console_or_selected (Lisp_Object event) +{ + Lisp_Object channel = EVENT_CHANNEL (XEVENT (event)); + Lisp_Object console = CDFW_CONSOLE (channel); + + if (NILP (console)) + console = Vselected_console; + + return XCONSOLE (console); +} + +DEFUN ("event-channel", Fevent_channel, Sevent_channel, 1, 1, 0 /* +Return the channel that the given event occurred on. +This will be a frame, device, console, or nil for some types +of events (e.g. eval events). +*/ ) + (event) + Lisp_Object event; +{ + CHECK_LIVE_EVENT (event); + return EVENT_CHANNEL (XEVENT (event)); +} + +DEFUN ("event-window", Fevent_window, Sevent_window, 1, 1, 0 /* +Return the window of the given mouse event. +This may be nil if the event occurred in the border or over a toolbar. +The modeline is considered to be in the window it represents. +*/ ) + (event) + Lisp_Object event; +{ + struct window *w; + Lisp_Object window; + + event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, 0); + + if (!w) + return Qnil; + else + { + XSETWINDOW (window, w); + return window; + } +} + +DEFUN ("event-point", Fevent_point, Sevent_point, 1, 1, 0 /* +Return the character position of the given mouse event. +If the event did not occur over a window, or did not occur over text, +then this returns nil. Otherwise, it returns an index into the buffer +visible in the event's window. +*/ ) + (event) + Lisp_Object event; +{ + Bufpos bufp; + struct window *w; + + event_pixel_translation (event, 0, 0, 0, 0, &w, &bufp, 0, 0, 0, 0); + + if (!w) + return Qnil; + else if (!bufp) + return Qnil; + else + return make_int (bufp); +} + +DEFUN ("event-closest-point", Fevent_closest_point, Sevent_closest_point, + 1, 1, 0 /* +Return the character position of the given mouse event. +If the event did not occur over a window or over text, return the +closest point to the location of the event. If the Y pixel position +overlaps a window and the X pixel position is to the left of that +window, the closest point is the beginning of the line containing the +Y position. If the Y pixel position overlaps a window and the X pixel +position is to the right of that window, the closest point is the end +of the line containing the Y position. If the Y pixel position is +above a window, return 0. If it is below a window, return the value +of (window-end). +*/ ) + (event) + Lisp_Object event; +{ + Bufpos bufp; + + event_pixel_translation (event, 0, 0, 0, 0, 0, 0, &bufp, 0, 0, 0); + + if (!bufp) + return Qnil; + else + return make_int (bufp); +} + +DEFUN ("event-x", Fevent_x, Sevent_x, 1, 1, 0 /* +Return the X position of the given mouse event in characters. +This is relative to the window the event occurred over. +*/ ) + (event) + Lisp_Object event; +{ + int char_x; + + event_pixel_translation (event, &char_x, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + return make_int (char_x); +} + +DEFUN ("event-y", Fevent_y, Sevent_y, 1, 1, 0 /* +Return the Y position of the given mouse event in characters. +This is relative to the window the event occurred over. +*/ ) + (event) + Lisp_Object event; +{ + int char_y; + + event_pixel_translation (event, 0, &char_y, 0, 0, 0, 0, 0, 0, 0, 0); + + return make_int (char_y); +} + +DEFUN ("event-modeline-position", Fevent_modeline_position, + Sevent_modeline_position, 1, 1, 0 /* +Return the character position in the modeline that EVENT occurred over. +EVENT should be a mouse event. If EVENT did not occur over a modeline, +nil is returned. You can determine the actual character that the +event occurred over by looking in `generated-modeline-string' at the +returned character position. Note that `generated-modeline-string' +is buffer-local, and you must use EVENT's buffer when retrieving +`generated-modeline-string' in order to get accurate results. +*/ ) + (event) + Lisp_Object event; +{ + Charcount mbufp; + + event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, &mbufp, 0, 0); + + if (mbufp < 0) + return Qnil; + else + return make_int (mbufp); +} + +DEFUN ("event-glyph", Fevent_glyph, Sevent_glyph, + 1, 1, 0 /* +Return the glyph that the given mouse event occurred over, or nil. +*/ ) + (event) + Lisp_Object event; +{ + Lisp_Object glyph; + struct window *w; + + event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, &glyph, 0); + + if (!w) + return Qnil; + else if (GLYPHP (glyph)) + return glyph; + else + return Qnil; +} + +DEFUN ("event-glyph-extent", Fevent_glyph_extent, Sevent_glyph_extent, + 1, 1, 0 /* +Return the extent of the glyph that the given mouse event occurred over. +If the event did not occur over a glyph, nil is returned. +*/ ) + (event) + Lisp_Object event; +{ + Lisp_Object extent; + struct window *w; + + event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, &extent); + + if (!w) + return Qnil; + else if (EXTENTP (extent)) + return extent; + else + return Qnil; +} + +DEFUN ("event-glyph-x-pixel", Fevent_glyph_x_pixel, Sevent_glyph_x_pixel, + 1, 1, 0 /* +Return the X pixel position of EVENT relative to the glyph it occurred over. +EVENT should be a mouse event. If the event did not occur over a glyph, +nil is returned. +*/ ) + (event) + Lisp_Object event; +{ + Lisp_Object extent; + struct window *w; + int obj_x; + + event_pixel_translation (event, 0, 0, &obj_x, 0, &w, 0, 0, 0, 0, &extent); + + if (w && EXTENTP (extent)) + return make_int (obj_x); + else + return Qnil; +} + +DEFUN ("event-glyph-y-pixel", Fevent_glyph_y_pixel, Sevent_glyph_y_pixel, + 1, 1, 0 /* +Return the Y pixel position of EVENT relative to the glyph it occurred over. +EVENT should be a mouse event. If the event did not occur over a glyph, +nil is returned. +*/ ) + (event) + Lisp_Object event; +{ + Lisp_Object extent; + struct window *w; + int obj_y; + + event_pixel_translation (event, 0, 0, 0, &obj_y, &w, 0, 0, 0, 0, &extent); + + if (w && EXTENTP (extent)) + return make_int (obj_y); + else + return Qnil; +} + +DEFUN ("event-toolbar-button", Fevent_toolbar_button, Sevent_toolbar_button, + 1, 1, 0 /* +Return the toolbar button that the given mouse event occurred over. +If the event did not occur over a toolbar, nil is returned. +*/ ) + (event) + Lisp_Object event; +{ +#ifdef HAVE_TOOLBARS + Lisp_Object button; + int result; + + result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, &button, 0); + + if (result == OVER_TOOLBAR) + { + if (TOOLBAR_BUTTONP (button)) + return button; + else + return Qnil; + } + else +#endif + return Qnil; +} + +DEFUN ("event-process", Fevent_process, Sevent_process, 1, 1, 0 /* +Return the process of the given process-output event. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_EVENT_TYPE (event, process_event, Qprocess_event_p); + return (XEVENT (event)->event.process.process); +} + +DEFUN ("event-function", Fevent_function, Sevent_function, 1, 1, 0 /* +Return the callback function of EVENT. +EVENT should be a timeout, misc-user, or eval event. +*/ ) + (event) + Lisp_Object event; +{ + CHECK_LIVE_EVENT (event); + switch (XEVENT (event)->event_type) + { + case timeout_event: + return (XEVENT (event)->event.timeout.function); + case misc_user_event: + case eval_event: + return (XEVENT (event)->event.eval.function); + default: + return wrong_type_argument (intern ("timeout-or-eval-event-p"), event); + } +} + +DEFUN ("event-object", Fevent_object, Sevent_object, 1, 1, 0 /* +Return the callback function argument of EVENT. +EVENT should be a timeout, misc-user, or eval event. +*/ ) + (event) + Lisp_Object event; +{ + again: + CHECK_LIVE_EVENT (event); + switch (XEVENT (event)->event_type) + { + case timeout_event: + return (XEVENT (event)->event.timeout.object); + case misc_user_event: + case eval_event: + return (XEVENT (event)->event.eval.object); + default: + event = wrong_type_argument (intern ("timeout-or-eval-event-p"), event); + goto again; + } +} + +DEFUN ("event-properties", Fevent_properties, Sevent_properties, 1, 1, 0 /* +Return a list of all of the properties of EVENT. +This is in the form of a property list (alternating keyword/value pairs). +*/ ) + (event) + Lisp_Object event; +{ + Lisp_Object props = Qnil; + struct Lisp_Event *e; + struct gcpro gcpro1; + + CHECK_LIVE_EVENT (event); + e = XEVENT (event); + GCPRO1 (props); + + props = Fcons (Qtimestamp, Fcons (Fevent_timestamp (event), props)); + + switch (e->event_type) + { + case process_event: + props = Fcons (Qprocess, Fcons (e->event.process.process, props)); + break; + + case timeout_event: + props = Fcons (Qobject, Fcons (Fevent_object (event), props)); + props = Fcons (Qfunction, Fcons (Fevent_function (event), props)); + props = Fcons (Qid, Fcons (make_int (e->event.timeout.id_number), + props)); + break; + + case key_press_event: + props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props)); + props = Fcons (Qkey, Fcons (Fevent_key (event), props)); + break; + + case button_press_event: + case button_release_event: + props = Fcons (Qy, Fcons (Fevent_y_pixel (event), props)); + props = Fcons (Qx, Fcons (Fevent_x_pixel (event), props)); + props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props)); + props = Fcons (Qbutton, Fcons (Fevent_button (event), props)); + break; + + case pointer_motion_event: + props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props)); + props = Fcons (Qy, Fcons (Fevent_y_pixel (event), props)); + props = Fcons (Qx, Fcons (Fevent_x_pixel (event), props)); + break; + + case misc_user_event: + case eval_event: + props = Fcons (Qobject, Fcons (Fevent_object (event), props)); + props = Fcons (Qfunction, Fcons (Fevent_function (event), props)); + break; + + case magic_eval_event: + case magic_event: + break; + + default: + abort (); + break; /* not reached; warning suppression */ + } + + props = Fcons (Qchannel, Fcons (Fevent_channel (event), props)); + UNGCPRO; + + return props; +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_events (void) +{ + defsubr (&Scharacter_to_event); + defsubr (&Sevent_to_character); + + defsubr (&Smake_event); + defsubr (&Sdeallocate_event); + defsubr (&Scopy_event); + defsubr (&Seventp); + defsubr (&Sevent_live_p); + defsubr (&Sevent_type); + defsubr (&Sevent_properties); + + defsubr (&Sevent_timestamp); + defsubr (&Sevent_key); + defsubr (&Sevent_button); + defsubr (&Sevent_modifier_bits); + defsubr (&Sevent_modifiers); + defsubr (&Sevent_x_pixel); + defsubr (&Sevent_y_pixel); + defsubr (&Sevent_window_x_pixel); + defsubr (&Sevent_window_y_pixel); + defsubr (&Sevent_over_text_area_p); + defsubr (&Sevent_over_modeline_p); + defsubr (&Sevent_over_border_p); + defsubr (&Sevent_over_toolbar_p); + defsubr (&Sevent_channel); + defsubr (&Sevent_window); + defsubr (&Sevent_point); + defsubr (&Sevent_closest_point); + defsubr (&Sevent_x); + defsubr (&Sevent_y); + defsubr (&Sevent_modeline_position); + defsubr (&Sevent_glyph); + defsubr (&Sevent_glyph_extent); + defsubr (&Sevent_glyph_x_pixel); + defsubr (&Sevent_glyph_y_pixel); + defsubr (&Sevent_toolbar_button); + defsubr (&Sevent_process); + defsubr (&Sevent_function); + defsubr (&Sevent_object); + + defsymbol (&Qeventp, "eventp"); + defsymbol (&Qevent_live_p, "event-live-p"); + defsymbol (&Qkey_press_event_p, "key-press-event-p"); + defsymbol (&Qbutton_event_p, "button-event-p"); + defsymbol (&Qmouse_event_p, "mouse-event-p"); + defsymbol (&Qprocess_event_p, "process-event-p"); + defsymbol (&Qkey_press, "key-press"); + defsymbol (&Qbutton_press, "button-press"); + defsymbol (&Qbutton_release, "button-release"); + defsymbol (&Qmisc_user, "misc-user"); + defsymbol (&Qascii_character, "ascii-character"); +} + +void +vars_of_events (void) +{ + DEFVAR_LISP ("character-set-property", &Vcharacter_set_property /* +A symbol used to look up the 8-bit character of a keysym. +To convert a keysym symbol to an 8-bit code, as when that key is +bound to self-insert-command, we will look up the property that this +variable names on the property list of the keysym-symbol. The window- +system-specific code will set up appropriate properties and set this +variable. +*/ ); + Vcharacter_set_property = Qnil; + + Vevent_resource = Qnil; + + QKbackspace = KEYSYM ("backspace"); + QKtab = KEYSYM ("tab"); + QKlinefeed = KEYSYM ("linefeed"); + QKreturn = KEYSYM ("return"); + QKescape = KEYSYM ("escape"); + QKspace = KEYSYM ("space"); + QKdelete = KEYSYM ("delete"); + + staticpro (&QKbackspace); + staticpro (&QKtab); + staticpro (&QKlinefeed); + staticpro (&QKreturn); + staticpro (&QKescape); + staticpro (&QKspace); + staticpro (&QKdelete); +}