Mercurial > emacs
comparison lisp/mwheel.el @ 45994:65253ed28734
Undo last patch for now.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Mon, 24 Jun 2002 15:50:38 +0000 |
parents | d8512fb0b229 |
children | 5133c42d55cc |
comparison
equal
deleted
inserted
replaced
45993:b974df2c611f | 45994:65253ed28734 |
---|---|
1 ;;; mwheel.el --- Mouse support for MS intelli-mouse type mice | 1 ;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
2 | 2 |
3 ;; Copyright (C) 1998, 2000, 2001, Free Software Foundation, Inc. | 3 ;; Copyright (C) 1998, 2000, 2001 Free Software Foundation, Inc. |
4 ;; Maintainer: William M. Perry <wmperry@gnu.org> | 4 ;; Maintainer: William M. Perry <wmperry@gnu.org> |
5 ;; Keywords: mouse | 5 ;; Keywords: mouse |
6 | 6 |
7 ;; This file is part of GNU Emacs. | 7 ;; This file is part of GNU Emacs. |
8 | 8 |
61 "Mouse button number for scrolling up." | 61 "Mouse button number for scrolling up." |
62 :group 'mouse | 62 :group 'mouse |
63 :type 'integer | 63 :type 'integer |
64 :set 'mouse-wheel-change-button) | 64 :set 'mouse-wheel-change-button) |
65 | 65 |
66 (defcustom mouse-wheel-scroll-amount '(1 5 nil) | 66 (defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) |
67 "Amount to scroll windows by when spinning the mouse wheel. | 67 "Amount to scroll windows by when spinning the mouse wheel. |
68 This is actually a list, where the first element is the amount to | 68 This is actually a cons cell, where the first item is the amount to scroll |
69 scroll slowly (normally invoked with the Shift key depressed) the | 69 on a normal wheel event, and the rest is an alist mapping the modifier key |
70 second is the amount to scroll on a normal wheel event, and the third | 70 to the amount to scroll when the wheel is moved with the modifier key depressed. |
71 is the amount to scroll fast (normally with the Control key depressed). | |
72 | 71 |
73 Each item should be the number of lines to scroll, or `nil' for near | 72 Each item should be the number of lines to scroll, or `nil' for near |
74 full screen. | 73 full screen. It can also be a floating point number, specifying |
74 the fraction of the window to scroll. | |
75 A near full screen is `next-screen-context-lines' less than a full screen." | 75 A near full screen is `next-screen-context-lines' less than a full screen." |
76 :group 'mouse | 76 :group 'mouse |
77 :type '(list | 77 :type '(cons |
78 (choice :tag "Slow (Shift key)" | 78 (choice :tag "Normal" |
79 (const :tag "Full screen" :value nil) | 79 (const :tag "Full screen" :value nil) |
80 (integer :tag "Specific # of lines")) | 80 (integer :tag "Specific # of lines") |
81 (choice :tag "Normal (no keys)" | 81 (float :tag "Fraction of window")) |
82 (const :tag "Full screen" :value nil) | 82 (repeat |
83 (integer :tag "Specific # of lines")) | 83 (cons |
84 (choice :tag "Fast (Ctrl key)" | 84 (repeat (choice :tag "modifier" (const alt) (const control) (const hyper) |
85 (const :tag "Full screen" :value nil) | 85 (const meta) (const shift) (const super))) |
86 (integer :tag "Specific # of lines")))) | 86 (choice :tag "scroll amount" |
87 (const :tag "Full screen" :value nil) | |
88 (integer :tag "Specific # of lines") | |
89 (float :tag "Fraction of window")))))) | |
90 | |
91 (defcustom mouse-wheel-progessive-speed t | |
92 "If non-nil, the faster the user moves the wheel, the faster the scrolling. | |
93 Note that this has no effect when `mouse-wheel-scroll-amount' specifies | |
94 a \"near full screen\" scroll." | |
95 :group 'mouse | |
96 :type 'boolean) | |
87 | 97 |
88 (defcustom mouse-wheel-follow-mouse nil | 98 (defcustom mouse-wheel-follow-mouse nil |
89 "Whether the mouse wheel should scroll the window that the mouse is over. | 99 "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." | 100 This can be slightly disconcerting, but some people may prefer it." |
91 :group 'mouse | 101 :group 'mouse |
92 :type 'boolean) | 102 :type 'boolean) |
93 | 103 |
94 (defun mouse-wheel-event-window () | 104 (if (not (fboundp 'event-button)) |
95 "Return the window associated with this mouse command." | 105 (defun mwheel-event-button (event) |
96 ;; If the command was a mouse event, the window is stored in the event. | 106 (let ((x (symbol-name (event-basic-type event)))) |
97 (if (listp last-command-event) | 107 ;; Map mouse-wheel events to appropriate buttons |
98 (if (fboundp 'event-window) | 108 (if (string-equal "mouse-wheel" x) |
99 (event-window last-command-event) | 109 (let ((amount (car (cdr (cdr (cdr event)))))) |
100 (posn-window (event-start last-command-event))) | 110 (if (< amount 0) |
101 ;; If not a mouse event, use the window the mouse is over now. | 111 mouse-wheel-up-button |
102 (let* ((coordinates (mouse-position)) | 112 mouse-wheel-down-button)) |
103 (x (car (cdr coordinates))) | 113 (if (not (string-match "^mouse-\\([0-9]+\\)" x)) |
104 (y (cdr (cdr coordinates)))) | 114 (error "Not a button event: %S" event) |
105 (and (numberp x) | 115 (string-to-int (substring x (match-beginning 1) (match-end 1))))))) |
106 (numberp y) | 116 (fset 'mwheel-event-button 'event-button)) |
107 (window-at x y (car coordinates)))))) | |
108 | 117 |
109 ;; Interpret mouse-wheel-scroll-amount | 118 (if (not (fboundp 'event-window)) |
110 ;; If the scroll-amount is a cons cell instead of a list, | 119 (defun mwheel-event-window (event) |
111 ;; then the car is the normal speed, the cdr is the slow | 120 (posn-window (event-start event))) |
112 ;; speed, and the fast speed is nil. This is for pre-21.1 | 121 (fset 'mwheel-event-window 'event-window)) |
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 | 122 |
134 (defun mouse-wheel-scroll-internal (direction speed) | 123 (defun mwheel-scroll (event) |
135 "Scroll DIRECTION (up or down) SPEED (slow, normal, or fast). | 124 "Scroll up or down according to the EVENT. |
136 `mouse-wheel-scroll-amount' defines the speeds." | 125 This should only be bound to mouse buttons 4 and 5." |
137 (let* ((scrollwin (if mouse-wheel-follow-mouse | 126 (interactive "e") |
138 (mouse-wheel-event-window))) | 127 (let* ((curwin (if mouse-wheel-follow-mouse |
139 (curwin (if scrollwin | 128 (prog1 |
140 (selected-window))) | 129 (selected-window) |
141 (amt (mouse-wheel-amount speed))) | 130 (select-window (mwheel-event-window event))))) |
131 (mods | |
132 (delq 'click (delq 'double (delq 'triple (event-modifiers event))))) | |
133 (amt | |
134 (if mods | |
135 (cdr (assoc mods (cdr mouse-wheel-scroll-amount))) | |
136 (car mouse-wheel-scroll-amount)))) | |
137 (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) | |
138 (when (and mouse-wheel-progessive-speed (numberp amt)) | |
139 ;; When the double-mouse-N comes in, a mouse-N has been executed already, | |
140 ;; So by adding things up we get a squaring up (1, 3, 6, 10, 16, ...). | |
141 (setq amt (* amt (event-click-count event)))) | |
142 (unwind-protect | 142 (unwind-protect |
143 (progn | 143 (let ((button (mwheel-event-button event))) |
144 (if scrollwin (select-window scrollwin)) | 144 (cond ((= button mouse-wheel-down-button) (scroll-down amt)) |
145 (if (eq direction 'down) | 145 ((= button mouse-wheel-up-button) (scroll-up amt)) |
146 (scroll-down amt) | 146 (t (error "Bad binding in mwheel-scroll")))) |
147 (scroll-up amt))) | |
148 (if curwin (select-window curwin))))) | 147 (if curwin (select-window curwin))))) |
149 | 148 |
150 | 149 |
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. | |
233 ;;;###autoload | 150 ;;;###autoload |
234 (define-minor-mode mouse-wheel-mode | 151 (define-minor-mode mouse-wheel-mode |
235 "Toggle mouse wheel support. | 152 "Toggle mouse wheel support. |
236 With prefix argument ARG, turn on if positive, otherwise off. | 153 With prefix argument ARG, turn on if positive, otherwise off. |
237 Returns non-nil if the new state is enabled." | 154 Returns non-nil if the new state is enabled." |
238 :global t | 155 :global t |
239 :group 'mouse | 156 :group 'mouse |
240 ;; This condition-case is here because Emacs 19 will throw an error | 157 ;; In the latest versions of XEmacs, we could just use |
241 ;; if you try to define a key that it does not know about. I for one | 158 ;; (S-)*mouse-[45], since those are aliases for the button |
242 ;; prefer to just unconditionally do a mwheel-install in my .emacs, so | 159 ;; equivalents in XEmacs, but I want this to work in as many |
243 ;; that if the wheeled-mouse is there, it just works, and this way it | 160 ;; versions of XEmacs as it can. |
244 ;; doesn't yell at me if I'm on my laptop or another machine, etc. | 161 (let* ((prefix (if (featurep 'xemacs) "button%d" "mouse-%d")) |
245 (condition-case () | 162 (dn (intern (format prefix mouse-wheel-down-button))) |
246 (progn | 163 (up (intern (format prefix mouse-wheel-up-button))) |
247 ;; In the latest versions of XEmacs, we could just use | 164 (keys |
248 ;; (S-)*mouse-[45], since those are aliases for the button | 165 (nconc (list (vector dn) (vector up)) |
249 ;; equivalents in XEmacs, but I want this to work in as many | 166 (mapcar (lambda (amt) `[(,@(car amt) ,up)]) |
250 ;; versions of XEmacs as it can. | 167 (cdr mouse-wheel-scroll-amount)) |
251 (mouse-wheel-button-definer '("button%d" . "mouse-%d") | 168 (mapcar (lambda (amt) `[(,@(car amt) ,dn)]) |
252 'mouse-wheel-scroll-down-normal 'mouse-wheel-scroll-up-normal) | 169 (cdr mouse-wheel-scroll-amount))))) |
253 (mouse-wheel-button-definer '((shift "button%d") . "S-mouse-%d") | 170 ;; This condition-case is here because Emacs 19 will throw an error |
254 'mouse-wheel-scroll-down-slow 'mouse-wheel-scroll-up-slow) | 171 ;; if you try to define a key that it does not know about. I for one |
255 (mouse-wheel-button-definer '((control "button%d") . "C-mouse-%d") | 172 ;; prefer to just unconditionally do a mwheel-install in my .emacs, so |
256 'mouse-wheel-scroll-down-fast 'mouse-wheel-scroll-up-fast)) | 173 ;; that if the wheeled-mouse is there, it just works, and this way it |
257 (error nil))) | 174 ;; doesn't yell at me if I'm on my laptop or another machine, etc. |
175 (condition-case () | |
176 (dolist (key keys) | |
177 (cond (mouse-wheel-mode | |
178 (global-set-key key 'mwheel-scroll)) | |
179 ((eq (lookup-key (current-global-map) key) 'mwheel-scroll) | |
180 (global-unset-key key)))) | |
181 (error nil)))) | |
258 | 182 |
259 ;;; Compatibility entry point | 183 ;;; Compatibility entry point |
260 ;;;###autoload | 184 ;;;###autoload |
261 (defun mwheel-install (&optional uninstall) | 185 (defun mwheel-install (&optional uninstall) |
262 "Enable mouse wheel support." | 186 "Enable mouse wheel support." |
263 (mouse-wheel-mode t)) | 187 (mouse-wheel-mode t)) |
264 | 188 |
265 | |
266 (provide 'mwheel) | 189 (provide 'mwheel) |
267 | 190 |
268 ;;; mwheel.el ends here | 191 ;;; mwheel.el ends here |