Mercurial > emacs
comparison lisp/emacs-lisp/levents.el @ 2034:8f940ad51dd0
Initial revision
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Sun, 07 Mar 1993 04:10:02 +0000 |
parents | |
children | e062b4567dc6 |
comparison
equal
deleted
inserted
replaced
2033:10cdd2928c7d | 2034:8f940ad51dd0 |
---|---|
1 ;; Emulate the Lucid event data type and associated functions. | |
2 ;; Copyright (C) 1993 Free Software Foundation, Inc. | |
3 | |
4 ;; This file is part of GNU Emacs. | |
5 | |
6 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
7 ;; it under the terms of the GNU General Public License as published by | |
8 ;; the Free Software Foundation; either version 2, or (at your option) | |
9 ;; any later version. | |
10 | |
11 ;; GNU Emacs is distributed in the hope that it will be useful, | |
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 ;; GNU General Public License for more details. | |
15 | |
16 ;; You should have received a copy of the GNU General Public License | |
17 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
19 | |
20 ;;; Notes: | |
21 | |
22 ;; Things we cannot emulate in Lisp: | |
23 ;; It is not possible to emulate current-mouse-event as a variable, | |
24 ;; though it is not hard to obtain the data from (this-command-keys). | |
25 | |
26 ;; We don't have variables last-command-event and last-input-event; | |
27 ;; instead, we made last-...-char have these values. | |
28 | |
29 ;; We do not have a variable unread-command-event; | |
30 ;; instead, we have the more general unread-command-events. | |
31 | |
32 ;; We could support those variables with C code as part of a merge. | |
33 | |
34 ;;current-mouse-event | |
35 | |
36 ;;The mouse-button event which invoked this command, or nil. | |
37 ;;This is what (interactive "e") returns. | |
38 | |
39 ;;------------------------------ | |
40 ;;last-command-event | |
41 | |
42 ;;Last keyboard or mouse button event that was part of a command. This | |
43 ;;variable is off limits: you may not set its value or modify the event that | |
44 ;;is its value, as it is destructively modified by read-key-sequence. If | |
45 ;;you want to keep a pointer to this value, you must use copy-event. | |
46 | |
47 ;;------------------------------ | |
48 ;;last-input-event | |
49 | |
50 ;;Last keyboard or mouse button event recieved. This variable is off | |
51 ;;limits: you may not set its value or modify the event that is its value, as | |
52 ;;it is destructively modified by next-event. If you want to keep a pointer | |
53 ;;to this value, you must use copy-event. | |
54 | |
55 ;;------------------------------ | |
56 ;;unread-command-event | |
57 | |
58 ;;Set this to an event object to simulate the reciept of an event from | |
59 ;;the user. Normally this is nil. | |
60 | |
61 ;;[The variable unread-command-char no longer exists, because with the new event | |
62 ;; model, it is incorrect for code to do (setq unread-command-char (read-char)), | |
63 ;; because all user-input can't be represented as ASCII characters. | |
64 | |
65 ;; A compatibility hack could be added to check unread-command-char as well as | |
66 ;; unread-command-event; or to only use unread-command-char and allow it to be | |
67 ;; an ASCII code or an event, but I think that's a bad idea because it would | |
68 ;; allow incorrect code to work so long as someone didn't type a character | |
69 ;; without an ASCII equivalent, making it likely that such code would not get | |
70 ;; fixed.] | |
71 | |
72 | |
73 ;;Other related functions: | |
74 ;;============================== | |
75 | |
76 ;;read-char () | |
77 | |
78 ;;Read a character from the command input (keyboard or macro). | |
79 ;;If a mouse click is detected, an error is signalled. The character typed | |
80 ;;is returned as an ASCII value. This is most likely the wrong thing for you | |
81 ;;to be using: consider using the `next-command-event' function instead. | |
82 | |
83 ;;------------------------------ | |
84 ;;read-key-sequence (prompt) | |
85 | |
86 ;;Read a sequence of keystrokes or mouse clicks and return a vector of the | |
87 ;;event objects read. The vector is newly created, but the event objects are | |
88 ;;reused: if you want to hold a pointer to them beyond the next call to this | |
89 ;;function, you must copy them first. | |
90 | |
91 ;;The sequence read is sufficient to specify a non-prefix command starting | |
92 ;;from the current local and global keymaps. A C-g typed while in this | |
93 ;;function is treated like any other character, and quit-flag is not set. | |
94 ;;One arg, PROMPT, is a prompt string, or nil meaning do not prompt specially. | |
95 | |
96 ;;If the user selects a menu item while we are prompting for a key-sequence, | |
97 ;;the returned value will be a vector of a single menu-selection event. | |
98 ;;An error will be signalled if you pass this value to lookup-key or a | |
99 ;;related function. | |
100 | |
101 ;;------------------------------ | |
102 ;;recent-keys () | |
103 | |
104 ;;Return vector of last 100 keyboard or mouse button events read. | |
105 ;;This copies 100 event objects and a vector; it is safe to keep and modify | |
106 ;;them. | |
107 ;;------------------------------ | |
108 | |
109 | |
110 ;;Other related variables: | |
111 ;;============================== | |
112 | |
113 ;;executing-kbd-macro | |
114 | |
115 ;;Currently executing keyboard macro (a vector of events); | |
116 ;;nil if none executing. | |
117 | |
118 ;;------------------------------ | |
119 ;;executing-macro | |
120 | |
121 ;;Currently executing keyboard macro (a vector of events); | |
122 ;;nil if none executing. | |
123 | |
124 ;;------------------------------ | |
125 ;;last-command-char | |
126 | |
127 ;;If the value of last-command-event is a keyboard event, then | |
128 ;;this is the nearest ASCII equivalent to it. This the the value that | |
129 ;;self-insert-command will put in the buffer. Remember that there is | |
130 ;;NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
131 ;;of keyboard events is much larger, so writing code that examines this | |
132 ;;variable to determine what key has been typed is bad practice, unless | |
133 ;;you are certain that it will be one of a small set of characters. | |
134 | |
135 ;;------------------------------ | |
136 ;;last-input-char | |
137 | |
138 ;;If the value of last-input-event is a keyboard event, then | |
139 ;;this is the nearest ASCII equivalent to it. Remember that there is | |
140 ;;NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
141 ;;of keyboard events is much larger, so writing code that examines this | |
142 ;;variable to determine what key has been typed is bad practice, unless | |
143 ;;you are certain that it will be one of a small set of characters. | |
144 | |
145 | |
146 ;;; Code: | |
147 | |
148 ;; Make events of type eval, menu and timeout | |
149 ;; execute properly. | |
150 | |
151 (define-key global-map [menu] 'execute-eval-event) | |
152 (define-key global-map [timeout] 'execute-eval-event) | |
153 (define-key global-map [eval] 'execute-eval-event) | |
154 | |
155 (defun execute-eval-event (event) | |
156 (interactive "e") | |
157 (funcall (nth 1 event) (nth 2 event))) | |
158 | |
159 (put 'eval 'event-symbol-elements '(eval)) | |
160 (put 'menu 'event-symbol-elements '(eval)) | |
161 (put 'timeout 'event-symbol-elements '(eval)) | |
162 | |
163 (defsubst eventp (obj) | |
164 "True if the argument is an event object." | |
165 (or (integerp obj) | |
166 (and (symbolp obj) | |
167 (get obj 'event-symbol-elements)) | |
168 (and (consp obj) | |
169 (symbolp (car obj)) | |
170 (get (car obj) 'event-symbol-elements)))) | |
171 | |
172 (defun allocate-event () | |
173 "Returns an empty event structure. | |
174 In this emulation, it returns nil." | |
175 nil) | |
176 | |
177 (defun button-press-event-p (obj) | |
178 "True if the argument is a mouse-button-press event object." | |
179 (and (consp obj) (symbolp (car obj)) | |
180 (memq 'down (get (car obj) 'event-symbol-elements)))) | |
181 | |
182 (defun button-release-event-p (obj) | |
183 "True if the argument is a mouse-button-release event object." | |
184 (and (consp obj) (symbolp (car obj)) | |
185 (or (memq 'click (get (car obj) 'event-symbol-elements)) | |
186 (memq 'drag (get (car obj) 'event-symbol-elements))))) | |
187 | |
188 (defun character-to-event (ch &optional event) | |
189 "Converts a numeric ASCII value to an event structure, replete with | |
190 bucky bits. The character is the first argument, and the event to fill | |
191 in is the second. This function contains knowledge about what the codes | |
192 mean -- for example, the number 9 is converted to the character Tab, | |
193 not the distinct character Control-I. | |
194 | |
195 Beware that character-to-event and event-to-character are not strictly | |
196 inverse functions, since events contain much more information than the | |
197 ASCII character set can encode." | |
198 ch) | |
199 | |
200 (defun copy-event (event1 &optional event2) | |
201 "Make a copy of the given event object. | |
202 In this emulation, `copy-event' just returns its argument." | |
203 event1) | |
204 | |
205 (defun deallocate-event (event) | |
206 "Allow the given event structure to be reused. | |
207 In actual Lucid Emacs, you MUST NOT use this event object after | |
208 calling this function with it. You will lose. It is not necessary to | |
209 call this function, as event objects are garbage- collected like all | |
210 other objects; however, it may be more efficient to explicitly | |
211 deallocate events when you are sure that that is safe. | |
212 | |
213 This emulation does not actually deallocate or reuse events | |
214 except via garbage collection and `cons'." | |
215 nil) | |
216 | |
217 (defun dispatch-event (event) | |
218 "Given an event object returned by next-event, execute it." | |
219 (let ((type (car-safe event))) | |
220 (cond ((eq type 'eval) | |
221 (funcall (nth 1 event) (nth 2 event))) | |
222 ((eq type 'menu) | |
223 (funcall (nth 1 event) (nth 2 event))) | |
224 ((eq type 'switch-frame) | |
225 (internal-select-frame (nth 1 event))) | |
226 (t (error "keyboard and mouse events not allowed in `dispatch-event'"))))) | |
227 | |
228 (defun enqueue-eval-event: (function object) | |
229 "Add an eval event to the back of the queue. | |
230 It will be the next event read after all pending events." | |
231 (setq unread-command-events | |
232 (nconc unread-command-events | |
233 (list (list 'eval function object))))) | |
234 | |
235 (defun eval-event-p (obj) | |
236 "True if the argument is an eval or menu event object." | |
237 (eq (car-safe obj) 'eval)) | |
238 | |
239 (defun event-button (event) | |
240 "Return the button-number of the given mouse-button-press event." | |
241 (let ((sym (car (get (car event) 'event-symbol-elements)))) | |
242 (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3) | |
243 (mouse-4 . 4) (mouse-5 . 5)))))) | |
244 | |
245 (defun event-function (event) | |
246 "Return the callback function of the given timeout, menu, or eval event." | |
247 (nth 1 event)) | |
248 | |
249 (defun event-key (event) | |
250 "Returns the KeySym of the given key-press event. | |
251 The value is an ASCII printing character (not upper case) or a symbol." | |
252 (if (symbolp event) | |
253 (car (get event 'event-symbol-elements)) | |
254 (let ((base (logand event (1- (lsh 1 18))))) | |
255 (downcase (if (< base 32) (logior base 64) base))))) | |
256 | |
257 (defun event-modifiers (event) | |
258 "Returns a list of symbols representing the modifier keys in event EVENT. | |
259 The elements of the list may include `meta', `control', | |
260 `shift', `hyper', `super', `alt'. | |
261 See also the function `event-modifier-bits'." | |
262 (let ((type event)) | |
263 (if (listp type) | |
264 (setq type (car type))) | |
265 (if (symbolp type) | |
266 (cdr (get type 'event-symbol-elements)) | |
267 (let ((list nil)) | |
268 (or (zerop (logand type (lsh 1 23))) | |
269 (setq list (cons 'meta list))) | |
270 (or (and (zerop (logand type (lsh 1 22))) | |
271 (>= (logand type 127) 32)) | |
272 (setq list (cons 'control list))) | |
273 (or (and (zerop (logand type (lsh 1 21))) | |
274 (= (logand type 255) (downcase (logand type 255)))) | |
275 (setq list (cons 'shift list))) | |
276 (or (zerop (logand type (lsh 1 20))) | |
277 (setq list (cons 'hyper list))) | |
278 (or (zerop (logand type (lsh 1 19))) | |
279 (setq list (cons 'super list))) | |
280 (or (zerop (logand type (lsh 1 18))) | |
281 (setq list (cons 'alt list))) | |
282 list)))) | |
283 | |
284 (defun event-modifier-bits (event) | |
285 "Returns a number representing the modifier keys in event EVENT. | |
286 See also the function `event-modifiers'." | |
287 (let ((type event)) | |
288 (if (listp type) | |
289 (setq type (car type))) | |
290 (if (symbolp type) | |
291 (logand (lsh 63 18) | |
292 (nth 1 (get type 'event-symbol-element-mask))) | |
293 (let ((bits (logand type (lsh 63 18))) | |
294 (base (logand type 127))) | |
295 ;; Put in Control and Shift bits | |
296 ;; in the cases where the basic code expresses them. | |
297 (if (< base 32) | |
298 (setq bits (logior (lsh 1 22) bits))) | |
299 (if (/= base (downcase base)) | |
300 (setq bits (logior (lsh 1 21) bits))) | |
301 bits)))) | |
302 | |
303 (defun event-object (event) | |
304 "Returns the function argument of the given timeout, menu, or eval event." | |
305 (nth 2 event)) | |
306 | |
307 (defun event-point (event) | |
308 "Returns the character position of the given mouse-related event. | |
309 If the event did not occur over a window, or did | |
310 not occur over text, then this returns nil. Otherwise, it returns an index | |
311 into the buffer visible in the event's window." | |
312 (posn-point (event-end event))) | |
313 | |
314 (defun event-process (event) | |
315 "Returns the process of the given process-output event." | |
316 (nth 1 event)) | |
317 | |
318 (defun event-timestamp (event) | |
319 "Returns the timestamp of the given event object. | |
320 In Lucid Emacs, this works for any kind of event. | |
321 In this emulation, it returns nil for non-mouse-related events." | |
322 (and (listp event) | |
323 (posn-timestamp (event-end event)))) | |
324 | |
325 (defun event-to-character (event &optional lenient) | |
326 "Returns the closest ASCII approximation to the given event object. | |
327 If the event isn't a keypress, this returns nil. | |
328 If the second argument is non-nil, then this is lenient in its | |
329 translation; it will ignore modifier keys other than control and meta, | |
330 and will ignore the shift modifier on those characters which have no | |
331 shifted ASCII equivalent (Control-Shift-A for example, will be mapped to | |
332 the same ASCII code as Control-A.) If the second arg is nil, then nil | |
333 will be returned for events which have no direct ASCII equivalent." | |
334 (if (symbolp event) | |
335 (and lenient | |
336 (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9) | |
337 (return . 10) (enter . 10))))) | |
338 ;; Our interpretation is, ASCII means anything a number can represent. | |
339 (if (integerp event) | |
340 event nil))) | |
341 | |
342 (defun event-window (event) | |
343 "Returns the window of the given mouse-related event object." | |
344 (posn-window (event-end event))) | |
345 | |
346 (defun event-x (event) | |
347 "Returns the X position in characters of the given mouse-related event." | |
348 (/ (car (posn-col-row (event-end event))) | |
349 (character-width (window-frame (event-window event))))) | |
350 | |
351 (defun event-x-pixel (event) | |
352 "Returns the X position in pixels of the given mouse-related event." | |
353 (car (posn-col-row (event-end event)))) | |
354 | |
355 (defun event-y (event) | |
356 "Returns the Y position in characters of the given mouse-related event." | |
357 (/ (cdr (posn-col-row (event-end event))) | |
358 (character-width (window-frame (event-window event))))) | |
359 | |
360 (defun event-y-pixel (event) | |
361 "Returns the Y position in pixels of the given mouse-related event." | |
362 (cdr (posn-col-row (event-end event)))) | |
363 | |
364 (defun key-press-event-p (obj) | |
365 "True if the argument is a keyboard event object." | |
366 (or (integerp obj) | |
367 (and (symbolp obj) | |
368 (get obj 'event-symbol-elements)))) | |
369 | |
370 (defun menu-event-p (obj) | |
371 "True if the argument is a menu event object." | |
372 (eq (car-safe obj) 'menu)) | |
373 | |
374 (defun motion-event-p (obj) | |
375 "True if the argument is a mouse-motion event object." | |
376 (eq (car-safe obj) 'mouse-movement)) | |
377 | |
378 (defun next-command-event (event) | |
379 "Given an event structure, fills it in with the next keyboard, mouse | |
380 press, or mouse release event available from the user. If there are | |
381 non-command events available (mouse motion, sub-process output, etc) then | |
382 these will be executed (with dispatch-event) and discarded." | |
383 (while (progn | |
384 (next-event event) | |
385 (not (or (key-press-event-p event) | |
386 (button-press-event-p event) | |
387 (button-release-event-p event) | |
388 (menu-event-p event)))) | |
389 (dispatch-event event))) | |
390 | |
391 (defun next-event (event &optional ignore) | |
392 "Given an event structure, fills it in with the next event available | |
393 from the window system or terminal driver. Pass this object to | |
394 `dispatch-event' to handle it. | |
395 | |
396 See also the function `next-command-event'. | |
397 | |
398 If the second optional argument is non-nil, then this will never return | |
399 key-press and mouse-click events, but will delay them until later. You | |
400 should probably never need to use this option; it is used for implementing | |
401 the `wait-reading-process-input' function." | |
402 (read-event)) | |
403 | |
404 (defun process-event-p (obj) | |
405 "True if the argument is a process-output event object. | |
406 GNU Emacs 19 does not currently generate process-output events." | |
407 (eq (car-safe obj) 'process)) | |
408 | |
409 (defun timeout-event-p (obj) | |
410 "True if the argument is a timeout event object. | |
411 GNU Emacs 19 does not currently generate timeout events." | |
412 (eq (car-safe obj) 'timeout)) | |
413 | |
414 ;;; levents.el ends here |