Line data Source code
1 : ;;; mwheel.el --- Wheel mouse support
2 :
3 : ;; Copyright (C) 1998, 2000-2017 Free Software Foundation, Inc.
4 : ;; Maintainer: William M. Perry <wmperry@gnu.org>
5 : ;; Keywords: mouse
6 : ;; Package: emacs
7 :
8 : ;; This file is part of GNU Emacs.
9 :
10 : ;; GNU Emacs is free software: you can redistribute it and/or modify
11 : ;; it under the terms of the GNU General Public License as published by
12 : ;; the Free Software Foundation, either version 3 of the License, or
13 : ;; (at your option) any later version.
14 :
15 : ;; GNU Emacs is distributed in the hope that it will be useful,
16 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 : ;; GNU General Public License for more details.
19 :
20 : ;; You should have received a copy of the GNU General Public License
21 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 :
23 : ;;; Commentary:
24 :
25 : ;; This code will enable the use of the infamous 'wheel' on the new
26 : ;; crop of mice. Under XFree86 and the XSuSE X Servers, the wheel
27 : ;; events are sent as button4/button5 events.
28 :
29 : ;; I for one would prefer some way of converting the button4/button5
30 : ;; events into different event types, like 'mwheel-up' or
31 : ;; 'mwheel-down', but I cannot find a way to do this very easily (or
32 : ;; portably), so for now I just live with it.
33 :
34 : ;; To enable this code, simply put this at the top of your .emacs
35 : ;; file:
36 : ;;
37 : ;; (mouse-wheel-mode 1)
38 :
39 : ;;; Code:
40 :
41 : (require 'custom)
42 : (require 'timer)
43 :
44 : (defvar mouse-wheel-mode)
45 :
46 : ;; Setter function for mouse-button user-options. Switch Mouse Wheel
47 : ;; mode off and on again so that the old button is unbound and
48 : ;; new button is bound to mwheel-scroll.
49 :
50 : (defun mouse-wheel-change-button (var button)
51 4 : (set-default var button)
52 : ;; Sync the bindings.
53 4 : (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
54 :
55 : (defvar mouse-wheel-down-button 4)
56 : (make-obsolete-variable 'mouse-wheel-down-button
57 : 'mouse-wheel-down-event
58 : "22.1")
59 : (defcustom mouse-wheel-down-event
60 : (if (or (featurep 'w32-win) (featurep 'ns-win))
61 : 'wheel-up
62 : (intern (format "mouse-%s" mouse-wheel-down-button)))
63 : "Event used for scrolling down."
64 : :group 'mouse
65 : :type 'symbol
66 : :set 'mouse-wheel-change-button)
67 :
68 : (defvar mouse-wheel-up-button 5)
69 : (make-obsolete-variable 'mouse-wheel-up-button
70 : 'mouse-wheel-up-event
71 : "22.1")
72 : (defcustom mouse-wheel-up-event
73 : (if (or (featurep 'w32-win) (featurep 'ns-win))
74 : 'wheel-down
75 : (intern (format "mouse-%s" mouse-wheel-up-button)))
76 : "Event used for scrolling up."
77 : :group 'mouse
78 : :type 'symbol
79 : :set 'mouse-wheel-change-button)
80 :
81 : (defvar mouse-wheel-click-button 2)
82 : (make-obsolete-variable 'mouse-wheel-click-button
83 : 'mouse-wheel-click-event
84 : "22.1")
85 : (defcustom mouse-wheel-click-event
86 : (intern (format "mouse-%s" mouse-wheel-click-button))
87 : "Event that should be temporarily inhibited after mouse scrolling.
88 : The mouse wheel is typically on the mouse-2 button, so it may easily
89 : happen that text is accidentally yanked into the buffer when
90 : scrolling with the mouse wheel. To prevent that, this variable can be
91 : set to the event sent when clicking on the mouse wheel button."
92 : :group 'mouse
93 : :type 'symbol
94 : :set 'mouse-wheel-change-button)
95 :
96 : (defcustom mouse-wheel-inhibit-click-time 0.35
97 : "Time in seconds to inhibit clicking on mouse wheel button after scroll."
98 : :group 'mouse
99 : :type 'number)
100 :
101 : (defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil))
102 : "Amount to scroll windows by when spinning the mouse wheel.
103 : This is an alist mapping the modifier key to the amount to scroll when
104 : the wheel is moved with the modifier key depressed.
105 : Elements of the list have the form (MODIFIERS . AMOUNT) or just AMOUNT if
106 : MODIFIERS is nil.
107 :
108 : AMOUNT should be the number of lines to scroll, or nil for near full
109 : screen. It can also be a floating point number, specifying the fraction of
110 : a full screen to scroll. A near full screen is `next-screen-context-lines'
111 : less than a full screen."
112 : :group 'mouse
113 : :type '(cons
114 : (choice :tag "Normal"
115 : (const :tag "Full screen" :value nil)
116 : (integer :tag "Specific # of lines")
117 : (float :tag "Fraction of window")
118 : (cons
119 : (repeat (choice :tag "modifier"
120 : (const alt) (const control) (const hyper)
121 : (const meta) (const shift) (const super)))
122 : (choice :tag "scroll amount"
123 : (const :tag "Full screen" :value nil)
124 : (integer :tag "Specific # of lines")
125 : (float :tag "Fraction of window"))))
126 : (repeat
127 : (cons
128 : (repeat (choice :tag "modifier"
129 : (const alt) (const control) (const hyper)
130 : (const meta) (const shift) (const super)))
131 : (choice :tag "scroll amount"
132 : (const :tag "Full screen" :value nil)
133 : (integer :tag "Specific # of lines")
134 : (float :tag "Fraction of window")))))
135 : :set 'mouse-wheel-change-button)
136 :
137 : (defcustom mouse-wheel-progressive-speed t
138 : "If non-nil, the faster the user moves the wheel, the faster the scrolling.
139 : Note that this has no effect when `mouse-wheel-scroll-amount' specifies
140 : a \"near full screen\" scroll or when the mouse wheel sends key instead
141 : of button events."
142 : :group 'mouse
143 : :type 'boolean)
144 :
145 : (defcustom mouse-wheel-follow-mouse t
146 : "Whether the mouse wheel should scroll the window that the mouse is over.
147 : This can be slightly disconcerting, but some people prefer it."
148 : :group 'mouse
149 : :type 'boolean)
150 :
151 : (eval-and-compile
152 : (if (fboundp 'event-button)
153 : (fset 'mwheel-event-button 'event-button)
154 : (defun mwheel-event-button (event)
155 : (let ((x (event-basic-type event)))
156 : ;; Map mouse-wheel events to appropriate buttons
157 : (if (eq 'mouse-wheel x)
158 : (let ((amount (car (cdr (cdr (cdr event))))))
159 : (if (< amount 0)
160 : mouse-wheel-up-event
161 : mouse-wheel-down-event))
162 : x))))
163 :
164 : (if (fboundp 'event-window)
165 : (fset 'mwheel-event-window 'event-window)
166 : (defun mwheel-event-window (event)
167 : (posn-window (event-start event)))))
168 :
169 : (defvar mwheel-inhibit-click-event-timer nil
170 : "Timer running while mouse wheel click event is inhibited.")
171 :
172 : (defun mwheel-inhibit-click-timeout ()
173 : "Handler for `mwheel-inhibit-click-event-timer'."
174 0 : (setq mwheel-inhibit-click-event-timer nil)
175 0 : (remove-hook 'pre-command-hook 'mwheel-filter-click-events))
176 :
177 : (defun mwheel-filter-click-events ()
178 : "Discard `mouse-wheel-click-event' while scrolling the mouse."
179 0 : (if (eq (event-basic-type last-input-event) mouse-wheel-click-event)
180 0 : (setq this-command 'ignore)))
181 :
182 : (defvar mwheel-scroll-up-function 'scroll-up
183 : "Function that does the job of scrolling upward.")
184 :
185 : (defvar mwheel-scroll-down-function 'scroll-down
186 : "Function that does the job of scrolling downward.")
187 :
188 : (defun mwheel-scroll (event)
189 : "Scroll up or down according to the EVENT.
190 : This should be bound only to mouse buttons 4, 5, 6, and 7 on
191 : non-Windows systems."
192 0 : (interactive (list last-input-event))
193 0 : (let* ((selected-window (selected-window))
194 : (scroll-window
195 0 : (or (catch 'found
196 0 : (let* ((window (if mouse-wheel-follow-mouse
197 0 : (mwheel-event-window event)
198 0 : (selected-window)))
199 0 : (frame (when (window-live-p window)
200 0 : (frame-parameter
201 0 : (window-frame window) 'mouse-wheel-frame))))
202 0 : (when (frame-live-p frame)
203 0 : (let* ((pos (mouse-absolute-pixel-position))
204 0 : (pos-x (car pos))
205 0 : (pos-y (cdr pos)))
206 0 : (walk-window-tree
207 : (lambda (window-1)
208 0 : (let ((edges (window-edges window-1 nil t t)))
209 0 : (when (and (<= (nth 0 edges) pos-x)
210 0 : (<= pos-x (nth 2 edges))
211 0 : (<= (nth 1 edges) pos-y)
212 0 : (<= pos-y (nth 3 edges)))
213 0 : (throw 'found window-1))))
214 0 : frame nil t)))))
215 0 : (mwheel-event-window event)))
216 : (old-point
217 0 : (and (eq scroll-window selected-window)
218 0 : (eq (car-safe transient-mark-mode) 'only)
219 0 : (window-point)))
220 : (mods
221 0 : (delq 'click (delq 'double (delq 'triple (event-modifiers event)))))
222 0 : (amt (assoc mods mouse-wheel-scroll-amount)))
223 0 : (unless (eq scroll-window selected-window)
224 : ;; Mark window to be scrolled for redisplay.
225 0 : (select-window scroll-window 'mark-for-redisplay))
226 : ;; Extract the actual amount or find the element that has no modifiers.
227 0 : (if amt (setq amt (cdr amt))
228 0 : (let ((list-elt mouse-wheel-scroll-amount))
229 0 : (while (consp (setq amt (pop list-elt))))))
230 0 : (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height))))))
231 0 : (when (and mouse-wheel-progressive-speed (numberp amt))
232 : ;; When the double-mouse-N comes in, a mouse-N has been executed already,
233 : ;; So by adding things up we get a squaring up (1, 3, 6, 10, 15, ...).
234 0 : (setq amt (* amt (event-click-count event))))
235 0 : (unwind-protect
236 0 : (let ((button (mwheel-event-button event)))
237 0 : (cond ((eq button mouse-wheel-down-event)
238 0 : (condition-case nil (funcall mwheel-scroll-down-function amt)
239 : ;; Make sure we do indeed scroll to the beginning of
240 : ;; the buffer.
241 : (beginning-of-buffer
242 0 : (unwind-protect
243 0 : (funcall mwheel-scroll-down-function)
244 : ;; If the first scroll succeeded, then some scrolling
245 : ;; is possible: keep scrolling til the beginning but
246 : ;; do not signal an error. For some reason, we have
247 : ;; to do it even if the first scroll signaled an
248 : ;; error, because otherwise the window is recentered
249 : ;; for a reason that escapes me. This problem seems
250 : ;; to only affect scroll-down. --Stef
251 0 : (set-window-start (selected-window) (point-min))))))
252 0 : ((eq button mouse-wheel-up-event)
253 0 : (condition-case nil (funcall mwheel-scroll-up-function amt)
254 : ;; Make sure we do indeed scroll to the end of the buffer.
255 0 : (end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
256 0 : ((eq button mouse-wheel-left-event) ; for tilt scroll
257 0 : (when mwheel-tilt-scroll-p
258 0 : (funcall (if mwheel-flip-direction
259 0 : mwheel-scroll-right-function
260 0 : mwheel-scroll-left-function) amt)))
261 0 : ((eq button mouse-wheel-right-event) ; for tilt scroll
262 0 : (when mwheel-tilt-scroll-p
263 0 : (funcall (if mwheel-flip-direction
264 0 : mwheel-scroll-left-function
265 0 : mwheel-scroll-right-function) amt)))
266 0 : (t (error "Bad binding in mwheel-scroll"))))
267 0 : (if (eq scroll-window selected-window)
268 : ;; If there is a temporarily active region, deactivate it if
269 : ;; scrolling moved point.
270 0 : (when (and old-point (/= old-point (window-point)))
271 : ;; Call `deactivate-mark' at the original position, so that
272 : ;; the original region is saved to the X selection.
273 0 : (let ((new-point (window-point)))
274 0 : (goto-char old-point)
275 0 : (deactivate-mark)
276 0 : (goto-char new-point)))
277 0 : (select-window selected-window t))))
278 :
279 0 : (when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time)
280 0 : (if mwheel-inhibit-click-event-timer
281 0 : (cancel-timer mwheel-inhibit-click-event-timer)
282 0 : (add-hook 'pre-command-hook 'mwheel-filter-click-events))
283 0 : (setq mwheel-inhibit-click-event-timer
284 0 : (run-with-timer mouse-wheel-inhibit-click-time nil
285 0 : 'mwheel-inhibit-click-timeout))))
286 :
287 : (put 'mwheel-scroll 'scroll-command t)
288 :
289 : (defvar mwheel-installed-bindings nil)
290 :
291 : (define-minor-mode mouse-wheel-mode
292 : "Toggle mouse wheel support (Mouse Wheel mode).
293 : With a prefix argument ARG, enable Mouse Wheel mode if ARG is
294 : positive, and disable it otherwise. If called from Lisp, enable
295 : the mode if ARG is omitted or nil."
296 : :init-value t
297 : ;; We'd like to use custom-initialize-set here so the setup is done
298 : ;; before dumping, but at the point where the defcustom is evaluated,
299 : ;; the corresponding function isn't defined yet, so
300 : ;; custom-initialize-set signals an error.
301 : :initialize 'custom-initialize-delay
302 : :global t
303 : :group 'mouse
304 : ;; Remove previous bindings, if any.
305 0 : (while mwheel-installed-bindings
306 0 : (let ((key (pop mwheel-installed-bindings)))
307 0 : (when (eq (lookup-key (current-global-map) key) 'mwheel-scroll)
308 0 : (global-unset-key key))))
309 : ;; Setup bindings as needed.
310 0 : (when mouse-wheel-mode
311 0 : (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event mouse-wheel-right-event mouse-wheel-left-event))
312 0 : (dolist (key (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,event)])
313 0 : mouse-wheel-scroll-amount))
314 0 : (global-set-key key 'mwheel-scroll)
315 0 : (push key mwheel-installed-bindings)))))
316 :
317 : ;;; Compatibility entry point
318 : ;; preloaded ;;;###autoload
319 : (defun mwheel-install (&optional uninstall)
320 : "Enable mouse wheel support."
321 0 : (mouse-wheel-mode (if uninstall -1 1)))
322 :
323 :
324 : ;;; For tilt-scroll
325 : ;;;
326 : (defcustom mwheel-tilt-scroll-p nil
327 : "Enable scroll using tilting mouse wheel."
328 : :group 'mouse
329 : :type 'boolean
330 : :version "26.1")
331 :
332 : (defcustom mwheel-flip-direction nil
333 : "Swap direction of 'wheel-right and 'wheel-left."
334 : :group 'mouse
335 : :type 'boolean
336 : :version "26.1")
337 :
338 : (defcustom mwheel-scroll-left-function 'scroll-left
339 : "Function that does the job of scrolling left."
340 : :group 'mouse
341 : :type 'function
342 : :version "26.1")
343 :
344 : (defcustom mwheel-scroll-right-function 'scroll-right
345 : "Function that does the job of scrolling right."
346 : :group 'mouse
347 : :type 'function
348 : :version "26.1")
349 :
350 : (defvar mouse-wheel-left-event
351 : (if (or (featurep 'w32-win) (featurep 'ns-win))
352 : 'wheel-left
353 : (intern "mouse-6"))
354 : "Event used for scrolling left.")
355 :
356 : (defvar mouse-wheel-right-event
357 : (if (or (featurep 'w32-win) (featurep 'ns-win))
358 : 'wheel-right
359 : (intern "mouse-7"))
360 : "Event used for scrolling right.")
361 :
362 : (provide 'mwheel)
363 :
364 : ;;; mwheel.el ends here
|