annotate lisp/emacs-lisp/levents.el @ 72863:526dc1f36b09

(produce_image_glyph): Automatically crop wide images at right window edge so we can draw the cursor on the same row to avoid confusing redisplay by placing the cursor outside the visible window area.
author Kim F. Storm <storm@cua.dk>
date Thu, 14 Sep 2006 09:37:44 +0000
parents 067115a6e738
children 7a3f13e2dd57 c5406394f567
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
38414
67b464da13ec Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents: 18383
diff changeset
1 ;;; levents.el --- emulate the Lucid event data type and associated functions
2232
4f9d60f7de9d Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 2066
diff changeset
2
64751
5b1a238fcbb4 Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents: 64085
diff changeset
3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004,
68648
067115a6e738 Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents: 64751
diff changeset
4 ;; 2005, 2006 Free Software Foundation, Inc.
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
5
38961
5b23575286e6 Add the Maintainer keyword. From Pavel Janik.
Eli Zaretskii <eliz@gnu.org>
parents: 38414
diff changeset
6 ;; Maintainer: FSF
39117
abd085bfec0c Add Keywords header.
Gerd Moellmann <gerd@gnu.org>
parents: 38961
diff changeset
7 ;; Keywords: emulations
38961
5b23575286e6 Add the Maintainer keyword. From Pavel Janik.
Eli Zaretskii <eliz@gnu.org>
parents: 38414
diff changeset
8
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
9 ;; This file is part of GNU Emacs.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
10
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
12 ;; it under the terms of the GNU General Public License as published by
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
13 ;; the Free Software Foundation; either version 2, or (at your option)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
14 ;; any later version.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
15
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
16 ;; GNU Emacs is distributed in the hope that it will be useful,
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
19 ;; GNU General Public License for more details.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
20
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
21 ;; You should have received a copy of the GNU General Public License
14169
83f275dcd93a Update FSF's address.
Erik Naggum <erik@naggum.no>
parents: 12951
diff changeset
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
64085
18a818a2ee7c Update FSF's address.
Lute Kamstra <lute@gnu.org>
parents: 52401
diff changeset
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18a818a2ee7c Update FSF's address.
Lute Kamstra <lute@gnu.org>
parents: 52401
diff changeset
24 ;; Boston, MA 02110-1301, USA.
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
25
2232
4f9d60f7de9d Add standard library headers.
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 2066
diff changeset
26 ;;; Commentary:
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
27
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
28 ;; Things we cannot emulate in Lisp:
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
29 ;; It is not possible to emulate current-mouse-event as a variable,
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
30 ;; though it is not hard to obtain the data from (this-command-keys).
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
31
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
32 ;; We do not have a variable unread-command-event;
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
33 ;; instead, we have the more general unread-command-events.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
34
2039
e062b4567dc6 *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2034
diff changeset
35 ;; Our read-key-sequence and read-char are not precisely
e062b4567dc6 *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2034
diff changeset
36 ;; compatible with those in Lucid Emacs, but they should work ok.
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
37
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
38 ;;; Code:
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
39
2057
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
40 (defun next-command-event (event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
41 (error "You must rewrite to use `read-command-event' instead of `next-command-event'"))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
42
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
43 (defun next-event (event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
44 (error "You must rewrite to use `read-event' instead of `next-event'"))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
45
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
46 (defun dispatch-event (event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
47 (error "`dispatch-event' not supported"))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
48
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
49 ;; Make events of type eval, menu and timeout
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
50 ;; execute properly.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
51
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
52 (define-key global-map [menu] 'execute-eval-event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
53 (define-key global-map [timeout] 'execute-eval-event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
54 (define-key global-map [eval] 'execute-eval-event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
55
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
56 (defun execute-eval-event (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
57 (interactive "e")
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
58 (funcall (nth 1 event) (nth 2 event)))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
59
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
60 (put 'eval 'event-symbol-elements '(eval))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
61 (put 'menu 'event-symbol-elements '(eval))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
62 (put 'timeout 'event-symbol-elements '(eval))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
63
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
64 (defun allocate-event ()
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
65 "Returns an empty event structure.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
66 In this emulation, it returns nil."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
67 nil)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
68
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
69 (defun button-press-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
70 "True if the argument is a mouse-button-press event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
71 (and (consp obj) (symbolp (car obj))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
72 (memq 'down (get (car obj) 'event-symbol-elements))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
73
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
74 (defun button-release-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
75 "True if the argument is a mouse-button-release event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
76 (and (consp obj) (symbolp (car obj))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
77 (or (memq 'click (get (car obj) 'event-symbol-elements))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
78 (memq 'drag (get (car obj) 'event-symbol-elements)))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
79
17858
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
80 (defun button-event-p (obj)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
81 "True if the argument is a mouse-button press or release event object."
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
82 (and (consp obj) (symbolp (car obj))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
83 (or (memq 'click (get (car obj) 'event-symbol-elements))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
84 (memq 'down (get (car obj) 'event-symbol-elements))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
85 (memq 'drag (get (car obj) 'event-symbol-elements)))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
86
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
87 (defun mouse-event-p (obj)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
88 "True if the argument is a mouse-button press or release event object."
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
89 (and (consp obj) (symbolp (car obj))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
90 (or (eq (car obj) 'mouse-movement)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
91 (memq 'click (get (car obj) 'event-symbol-elements))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
92 (memq 'down (get (car obj) 'event-symbol-elements))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
93 (memq 'drag (get (car obj) 'event-symbol-elements)))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
94
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
95 (defun character-to-event (ch &optional event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
96 "Converts a numeric ASCII value to an event structure, replete with
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
97 bucky bits. The character is the first argument, and the event to fill
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
98 in is the second. This function contains knowledge about what the codes
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
99 mean -- for example, the number 9 is converted to the character Tab,
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
100 not the distinct character Control-I.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
101
49598
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
102 Beware that character-to-event and event-to-character are not strictly
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
103 inverse functions, since events contain much more information than the
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
104 ASCII character set can encode."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
105 ch)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
106
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
107 (defun copy-event (event1 &optional event2)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
108 "Make a copy of the given event object.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
109 In this emulation, `copy-event' just returns its argument."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
110 event1)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
111
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
112 (defun deallocate-event (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
113 "Allow the given event structure to be reused.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
114 In actual Lucid Emacs, you MUST NOT use this event object after
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
115 calling this function with it. You will lose. It is not necessary to
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
116 call this function, as event objects are garbage- collected like all
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
117 other objects; however, it may be more efficient to explicitly
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
118 deallocate events when you are sure that that is safe.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
119
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
120 This emulation does not actually deallocate or reuse events
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
121 except via garbage collection and `cons'."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
122 nil)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
123
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
124 (defun enqueue-eval-event: (function object)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
125 "Add an eval event to the back of the queue.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
126 It will be the next event read after all pending events."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
127 (setq unread-command-events
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
128 (nconc unread-command-events
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
129 (list (list 'eval function object)))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
130
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
131 (defun eval-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
132 "True if the argument is an eval or menu event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
133 (eq (car-safe obj) 'eval))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
134
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
135 (defun event-button (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
136 "Return the button-number of the given mouse-button-press event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
137 (let ((sym (car (get (car event) 'event-symbol-elements))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
138 (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
139 (mouse-4 . 4) (mouse-5 . 5))))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
140
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
141 (defun event-function (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
142 "Return the callback function of the given timeout, menu, or eval event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
143 (nth 1 event))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
144
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
145 (defun event-key (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
146 "Returns the KeySym of the given key-press event.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
147 The value is an ASCII printing character (not upper case) or a symbol."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
148 (if (symbolp event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
149 (car (get event 'event-symbol-elements))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
150 (let ((base (logand event (1- (lsh 1 18)))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
151 (downcase (if (< base 32) (logior base 64) base)))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
152
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
153 (defun event-object (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
154 "Returns the function argument of the given timeout, menu, or eval event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
155 (nth 2 event))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
156
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
157 (defun event-point (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
158 "Returns the character position of the given mouse-related event.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
159 If the event did not occur over a window, or did
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
160 not occur over text, then this returns nil. Otherwise, it returns an index
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
161 into the buffer visible in the event's window."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
162 (posn-point (event-end event)))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
163
17858
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
164 ;; Return position of start of line LINE in WINDOW.
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
165 ;; If LINE is nil, return the last position
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
166 ;; visible in WINDOW.
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
167 (defun event-closest-point-1 (window &optional line)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
168 (let* ((total (- (window-height window)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
169 (if (window-minibuffer-p window)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
170 0 1)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
171 (distance (or line total)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
172 (save-excursion
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
173 (goto-char (window-start window))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
174 (if (= (vertical-motion distance) distance)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
175 (if (not line)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
176 (forward-char -1)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
177 (point))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
178
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
179 (defun event-closest-point (event &optional start-window)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
180 "Return the nearest position to where EVENT ended its motion.
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
181 This is computed for the window where EVENT's motion started,
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
182 or for window WINDOW if that is specified."
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
183 (or start-window (setq start-window (posn-window (event-start event))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
184 (if (eq start-window (posn-window (event-end event)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
185 (if (eq (event-point event) 'vertical-line)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
186 (event-closest-point-1 start-window
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
187 (cdr (posn-col-row (event-end event))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
188 (if (eq (event-point event) 'mode-line)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
189 (event-closest-point-1 start-window)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
190 (event-point event)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
191 ;; EVENT ended in some other window.
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
192 (let* ((end-w (posn-window (event-end event)))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
193 (end-w-top)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
194 (w-top (nth 1 (window-edges start-window))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
195 (setq end-w-top
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
196 (if (windowp end-w)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
197 (nth 1 (window-edges end-w))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
198 (/ (cdr (posn-x-y (event-end event)))
17897
02b656fa8243 (event-closest-point): Fix paren error.
Richard M. Stallman <rms@gnu.org>
parents: 17858
diff changeset
199 (frame-char-height end-w))))
17858
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
200 (if (>= end-w-top w-top)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
201 (event-closest-point-1 start-window)
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
202 (window-start start-window)))))
72e538330a11 (event-closest-point): New function.
Richard M. Stallman <rms@gnu.org>
parents: 14704
diff changeset
203
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
204 (defun event-process (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
205 "Returns the process of the given process-output event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
206 (nth 1 event))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
207
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
208 (defun event-timestamp (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
209 "Returns the timestamp of the given event object.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
210 In Lucid Emacs, this works for any kind of event.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
211 In this emulation, it returns nil for non-mouse-related events."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
212 (and (listp event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
213 (posn-timestamp (event-end event))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
214
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
215 (defun event-to-character (event &optional lenient)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
216 "Returns the closest ASCII approximation to the given event object.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
217 If the event isn't a keypress, this returns nil.
49598
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
218 If the second argument is non-nil, then this is lenient in its
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
219 translation; it will ignore modifier keys other than control and meta,
49598
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
220 and will ignore the shift modifier on those characters which have no
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
221 shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
0d8b17d428b5 Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents: 39117
diff changeset
222 the same ASCII code as Control-A.) If the second arg is nil, then nil
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
223 will be returned for events which have no direct ASCII equivalent."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
224 (if (symbolp event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
225 (and lenient
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
226 (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
227 (return . 10) (enter . 10)))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
228 ;; Our interpretation is, ASCII means anything a number can represent.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
229 (if (integerp event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
230 event nil)))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
231
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
232 (defun event-window (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
233 "Returns the window of the given mouse-related event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
234 (posn-window (event-end event)))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
235
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
236 (defun event-x (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
237 "Returns the X position in characters of the given mouse-related event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
238 (/ (car (posn-col-row (event-end event)))
2066
9b4cb6b6d474 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents: 2057
diff changeset
239 (frame-char-width (window-frame (event-window event)))))
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
240
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
241 (defun event-x-pixel (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
242 "Returns the X position in pixels of the given mouse-related event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
243 (car (posn-col-row (event-end event))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
244
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
245 (defun event-y (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
246 "Returns the Y position in characters of the given mouse-related event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
247 (/ (cdr (posn-col-row (event-end event)))
2066
9b4cb6b6d474 entered into RCS
Richard M. Stallman <rms@gnu.org>
parents: 2057
diff changeset
248 (frame-char-height (window-frame (event-window event)))))
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
249
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
250 (defun event-y-pixel (event)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
251 "Returns the Y position in pixels of the given mouse-related event."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
252 (cdr (posn-col-row (event-end event))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
253
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
254 (defun key-press-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
255 "True if the argument is a keyboard event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
256 (or (integerp obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
257 (and (symbolp obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
258 (get obj 'event-symbol-elements))))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
259
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
260 (defun menu-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
261 "True if the argument is a menu event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
262 (eq (car-safe obj) 'menu))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
263
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
264 (defun motion-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
265 "True if the argument is a mouse-motion event object."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
266 (eq (car-safe obj) 'mouse-movement))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
267
2057
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
268 (defun read-command-event ()
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
269 "Return the next keyboard or mouse event; execute other events.
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
270 This is similar to the function `next-command-event' of Lucid Emacs,
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
271 but different in that it returns the event rather than filling in
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
272 an existing event object."
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
273 (let (event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
274 (while (progn
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
275 (setq event (read-event))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
276 (not (or (key-press-event-p event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
277 (button-press-event-p event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
278 (button-release-event-p event)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
279 (menu-event-p event))))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
280 (let ((type (car-safe event)))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
281 (cond ((eq type 'eval)
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
282 (funcall (nth 1 event) (nth 2 event)))
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
283 ((eq type 'switch-frame)
2957
ec432bd5d5b9 (event-modifiers): Function deleted.
Richard M. Stallman <rms@gnu.org>
parents: 2232
diff changeset
284 (select-frame (nth 1 event))))))
2057
265b81ff7eee *** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents: 2039
diff changeset
285 event))
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
286
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
287 (defun process-event-p (obj)
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
288 "True if the argument is a process-output event object.
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
289 GNU Emacs 19 does not currently generate process-output events."
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
290 (eq (car-safe obj) 'process))
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
291
18383
11218164bc54 Add provide call.
Richard M. Stallman <rms@gnu.org>
parents: 17897
diff changeset
292 (provide 'levents)
11218164bc54 Add provide call.
Richard M. Stallman <rms@gnu.org>
parents: 17897
diff changeset
293
52401
695cf19ef79e Add arch taglines
Miles Bader <miles@gnu.org>
parents: 49598
diff changeset
294 ;;; arch-tag: a80c21da-69d7-46de-9cdb-5f68577b5525
2034
8f940ad51dd0 Initial revision
Richard M. Stallman <rms@gnu.org>
parents:
diff changeset
295 ;;; levents.el ends here