Commit | Line | Data |
---|---|---|
a32b7419 WP |
1 | ;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
2 | ||
f7c9a765 | 3 | ;; Copyright (C) 1998, 2000, 2001, Free Software Foundation, Inc. |
a32b7419 WP |
4 | ;; Maintainer: William M. Perry <wmperry@gnu.org> |
5 | ;; Keywords: mouse | |
6 | ||
8ed8f294 | 7 | ;; This file is part of GNU Emacs. |
a32b7419 | 8 | |
8ed8f294 GM |
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
10 | ;; it under the terms of the GNU General Public License as published by | |
a32b7419 WP |
11 | ;; the Free Software Foundation; either version 2, or (at your option) |
12 | ;; any later version. | |
13 | ||
8ed8f294 GM |
14 | ;; GNU Emacs is distributed in the hope that it will be useful, |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
a32b7419 WP |
18 | |
19 | ;; You should have received a copy of the GNU General Public License | |
8ed8f294 | 20 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
a32b7419 WP |
21 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
22 | ;; Boston, MA 02111-1307, USA. | |
23 | ||
a32b7419 WP |
24 | ;;; Commentary: |
25 | ||
26 | ;; This code will enable the use of the infamous 'wheel' on the new | |
27 | ;; crop of mice. Under XFree86 and the XSuSE X Servers, the wheel | |
28 | ;; events are sent as button4/button5 events. | |
29 | ||
30 | ;; I for one would prefer some way of converting the button4/button5 | |
31 | ;; events into different event types, like 'mwheel-up' or | |
32 | ;; 'mwheel-down', but I cannot find a way to do this very easily (or | |
33 | ;; portably), so for now I just live with it. | |
34 | ||
35 | ;; To enable this code, simply put this at the top of your .emacs | |
36 | ;; file: | |
37 | ;; | |
a32b7419 WP |
38 | ;; (mwheel-install) |
39 | ||
40 | ;;; Code: | |
41 | ||
42 | (require 'custom) | |
a32b7419 | 43 | |
bf85004b GM |
44 | ;; Setter function for mouse-button user-options. Switch Mouse Wheel |
45 | ;; mode off and on again so that the old button is unbound and | |
46 | ;; new button is bound to mwheel-scroll. | |
47 | ||
48 | (defun mouse-wheel-change-button (var button) | |
49 | (set-default var button) | |
50 | (when mouse-wheel-mode | |
51 | (mouse-wheel-mode 0) | |
52 | (mouse-wheel-mode 1))) | |
53 | ||
54 | (defcustom mouse-wheel-down-button 4 | |
55 | "Mouse button number for scrolling down." | |
56 | :group 'mouse | |
57 | :type 'integer | |
58 | :set 'mouse-wheel-change-button) | |
59 | ||
60 | (defcustom mouse-wheel-up-button 5 | |
61 | "Mouse button number for scrolling up." | |
62 | :group 'mouse | |
63 | :type 'integer | |
64 | :set 'mouse-wheel-change-button) | |
65 | ||
f7c9a765 | 66 | (defcustom mouse-wheel-scroll-amount '(1 5 nil) |
a32b7419 | 67 | "Amount to scroll windows by when spinning the mouse wheel. |
f7c9a765 RS |
68 | This is actually a list, where the first element is the amount to |
69 | scroll slowly (normally invoked with the Shift key depressed) the | |
70 | second is the amount to scroll on a normal wheel event, and the third | |
71 | is the amount to scroll fast (normally with the Control key depressed). | |
a32b7419 WP |
72 | |
73 | Each item should be the number of lines to scroll, or `nil' for near | |
f7c9a765 | 74 | full screen. |
a32b7419 WP |
75 | A near full screen is `next-screen-context-lines' less than a full screen." |
76 | :group 'mouse | |
f7c9a765 RS |
77 | :type '(list |
78 | (choice :tag "Slow (Shift key)" | |
a32b7419 | 79 | (const :tag "Full screen" :value nil) |
f7c9a765 RS |
80 | (integer :tag "Specific # of lines")) |
81 | (choice :tag "Normal (no keys)" | |
82 | (const :tag "Full screen" :value nil) | |
83 | (integer :tag "Specific # of lines")) | |
84 | (choice :tag "Fast (Ctrl key)" | |
85 | (const :tag "Full screen" :value nil) | |
86 | (integer :tag "Specific # of lines")))) | |
a32b7419 | 87 | |
937b2877 | 88 | (defcustom mouse-wheel-follow-mouse nil |
a32b7419 WP |
89 | "Whether the mouse wheel should scroll the window that the mouse is over. |
90 | This can be slightly disconcerting, but some people may prefer it." | |
91 | :group 'mouse | |
92 | :type 'boolean) | |
93 | ||
f7c9a765 RS |
94 | (defun mouse-wheel-event-window () |
95 | "Return the window associated with this mouse command." | |
96 | ;; If the command was a mouse event, the window is stored in the event. | |
97 | (if (listp last-command-event) | |
98 | (if (fboundp 'event-window) | |
99 | (event-window last-command-event) | |
100 | (posn-window (event-start last-command-event))) | |
101 | ;; If not a mouse event, use the window the mouse is over now. | |
102 | (let* ((coordinates (mouse-position)) | |
103 | (x (car (cdr coordinates))) | |
104 | (y (cdr (cdr coordinates)))) | |
105 | (and (numberp x) | |
106 | (numberp y) | |
107 | (window-at x y (car coordinates)))))) | |
108 | ||
109 | ;; Interpret mouse-wheel-scroll-amount | |
110 | ;; If the scroll-amount is a cons cell instead of a list, | |
111 | ;; then the car is the normal speed, the cdr is the slow | |
112 | ;; speed, and the fast speed is nil. This is for pre-21.1 | |
113 | ;; backward compatibility. | |
114 | (defun mouse-wheel-amount (speed) | |
115 | (cond ((not (consp mouse-wheel-scroll-amount)) | |
116 | ;; illegal value | |
117 | mouse-wheel-scroll-amount) | |
118 | ((not (consp (cdr mouse-wheel-scroll-amount))) | |
119 | ;; old-style value: a cons | |
120 | (cond ((eq speed 'normal) | |
121 | (car mouse-wheel-scroll-amount)) | |
122 | ((eq speed 'slow) | |
123 | (cdr mouse-wheel-scroll-amount)) | |
124 | (t | |
125 | nil))) | |
126 | (t | |
127 | (cond ((eq speed 'slow) | |
128 | (nth 0 mouse-wheel-scroll-amount)) | |
129 | ((eq speed 'normal) | |
130 | (nth 1 mouse-wheel-scroll-amount)) | |
131 | (t ;fast | |
132 | (nth 2 mouse-wheel-scroll-amount)))))) | |
133 | ||
134 | (defun mouse-wheel-scroll-internal (direction speed) | |
135 | "Scroll DIRECTION (up or down) SPEED (slow, normal, or fast). | |
136 | `mouse-wheel-scroll-amount' defines the speeds." | |
137 | (let* ((scrollwin (if mouse-wheel-follow-mouse | |
138 | (mouse-wheel-event-window))) | |
139 | (curwin (if scrollwin | |
140 | (selected-window))) | |
141 | (amt (mouse-wheel-amount speed))) | |
a32b7419 | 142 | (unwind-protect |
f7c9a765 RS |
143 | (progn |
144 | (if scrollwin (select-window scrollwin)) | |
145 | (if (eq direction 'down) | |
146 | (scroll-down amt) | |
147 | (scroll-up amt))) | |
a32b7419 WP |
148 | (if curwin (select-window curwin))))) |
149 | ||
f4cbc7a0 | 150 | |
f7c9a765 RS |
151 | (defun mouse-wheel-scroll-up-fast () |
152 | "Scroll text of current window upward a full screen. | |
153 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
154 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
155 | (interactive) | |
156 | (mouse-wheel-scroll-internal 'up 'fast)) | |
157 | ||
158 | (defun mouse-wheel-scroll-down-fast () | |
159 | "Scroll text of current window down a full screen. | |
160 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
161 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
162 | (interactive) | |
163 | (mouse-wheel-scroll-internal 'down 'fast)) | |
164 | ||
165 | (defun mouse-wheel-scroll-up-normal () | |
166 | "Scroll text of current window upward a few lines. | |
167 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
168 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
169 | (interactive) | |
170 | (mouse-wheel-scroll-internal 'up 'normal)) | |
171 | ||
172 | (defun mouse-wheel-scroll-down-normal () | |
173 | "Scroll text of current window down a few lines. | |
174 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
175 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
176 | (interactive) | |
177 | (mouse-wheel-scroll-internal 'down 'normal)) | |
178 | ||
179 | (defun mouse-wheel-scroll-up-slow () | |
180 | "Scroll text of current window upward a line. | |
181 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
182 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
183 | (interactive) | |
184 | (mouse-wheel-scroll-internal 'up 'slow)) | |
185 | ||
186 | (defun mouse-wheel-scroll-down-slow () | |
187 | "Scroll text of current window down a line. | |
188 | `mouse-wheel-follow-mouse' controls how the current window is determined. | |
189 | `mouse-wheel-scroll-amount' controls the amount of scroll." | |
190 | (interactive) | |
191 | (mouse-wheel-scroll-internal 'down 'slow)) | |
192 | ||
193 | ||
194 | ;;; helper functions for minor mode mouse-wheel-mode. | |
195 | ||
196 | (defun mouse-wheel-button-definer (button-pair down-function up-function) | |
197 | (mouse-wheel-key-definer button-pair 'dn down-function) | |
198 | (mouse-wheel-key-definer button-pair 'up up-function)) | |
199 | ||
200 | (defun mouse-wheel-key-definer (button-pair up-or-dn function) | |
201 | (let ((key (if (featurep 'xemacs) | |
202 | (mouse-wheel-xemacs-key-formatter (car button-pair) up-or-dn) | |
203 | (mouse-wheel-intern-vector (cdr button-pair) up-or-dn)))) | |
204 | (cond (mouse-wheel-mode | |
205 | (define-key global-map key function)) | |
206 | ((eq (lookup-key global-map key) 'function) | |
207 | (define-key global-map key nil))))) | |
208 | ||
209 | (defun mouse-wheel-xemacs-key-formatter (key-format-list up-or-dn) | |
210 | (cond ((listp key-format-list) ;e.g., (shift "button%d") | |
211 | (list (car key-format-list) | |
212 | (mouse-wheel-xemacs-intern (car (cdr key-format-list)) up-or-dn))) | |
213 | (t | |
214 | (mouse-wheel-xemacs-intern key-format-list up-or-dn)))) | |
215 | ||
216 | (defun mouse-wheel-xemacs-intern (key-format-string up-or-dn) | |
217 | (intern (format key-format-string | |
218 | (if (eq up-or-dn 'up) | |
219 | mouse-wheel-up-button | |
220 | mouse-wheel-down-button)))) | |
221 | ||
222 | (defun mouse-wheel-intern-vector (key-format-string up-or-dn) | |
223 | "Turns \"mouse-%d\" into [mouse-4]." | |
224 | (vector (intern (format key-format-string | |
225 | (if (eq up-or-dn 'up) | |
226 | mouse-wheel-up-button | |
227 | mouse-wheel-down-button))))) | |
228 | ||
229 | ;;; Note this definition must be at the end of the file, because | |
230 | ;;; `define-minor-mode' actually calls the mode-function if the | |
231 | ;;; associated variable is non-nil, which requires that all needed | |
232 | ;;; functions be already defined. | |
a32b7419 | 233 | ;;;###autoload |
f4cbc7a0 MB |
234 | (define-minor-mode mouse-wheel-mode |
235 | "Toggle mouse wheel support. | |
236 | With prefix argument ARG, turn on if positive, otherwise off. | |
237 | Returns non-nil if the new state is enabled." | |
f4cbc7a0 MB |
238 | :global t |
239 | :group 'mouse | |
f7c9a765 RS |
240 | ;; This condition-case is here because Emacs 19 will throw an error |
241 | ;; if you try to define a key that it does not know about. I for one | |
242 | ;; prefer to just unconditionally do a mwheel-install in my .emacs, so | |
243 | ;; that if the wheeled-mouse is there, it just works, and this way it | |
244 | ;; doesn't yell at me if I'm on my laptop or another machine, etc. | |
245 | (condition-case () | |
246 | (progn | |
247 | ;; In the latest versions of XEmacs, we could just use | |
248 | ;; (S-)*mouse-[45], since those are aliases for the button | |
249 | ;; equivalents in XEmacs, but I want this to work in as many | |
250 | ;; versions of XEmacs as it can. | |
251 | (mouse-wheel-button-definer '("button%d" . "mouse-%d") | |
252 | 'mouse-wheel-scroll-down-normal 'mouse-wheel-scroll-up-normal) | |
253 | (mouse-wheel-button-definer '((shift "button%d") . "S-mouse-%d") | |
254 | 'mouse-wheel-scroll-down-slow 'mouse-wheel-scroll-up-slow) | |
255 | (mouse-wheel-button-definer '((control "button%d") . "C-mouse-%d") | |
256 | 'mouse-wheel-scroll-down-fast 'mouse-wheel-scroll-up-fast)) | |
257 | (error nil))) | |
f4cbc7a0 MB |
258 | |
259 | ;;; Compatibility entry point | |
260 | ;;;###autoload | |
261 | (defun mwheel-install (&optional uninstall) | |
262 | "Enable mouse wheel support." | |
263 | (mouse-wheel-mode t)) | |
264 | ||
f7c9a765 | 265 | |
a32b7419 WP |
266 | (provide 'mwheel) |
267 | ||
268 | ;;; mwheel.el ends here |