mwheel.el 13.2 KB
Newer Older
1
;;; mwheel.el --- Wheel mouse support
William M. Perry's avatar
William M. Perry committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1998, 2000-2019 Free Software Foundation, Inc.
William M. Perry's avatar
William M. Perry committed
4
;; Keywords: mouse
5
;; Package: emacs
William M. Perry's avatar
William M. Perry committed
6

7
;; This file is part of GNU Emacs.
William M. Perry's avatar
William M. Perry committed
8

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
11 12
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
William M. Perry's avatar
William M. Perry committed
13

14 15 16 17
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
William M. Perry's avatar
William M. Perry committed
18 19

;; You should have received a copy of the GNU General Public License
20
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
William M. Perry's avatar
William M. Perry committed
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35

;;; Commentary:

;; This code will enable the use of the infamous 'wheel' on the new
;; crop of mice.  Under XFree86 and the XSuSE X Servers, the wheel
;; events are sent as button4/button5 events.

;; I for one would prefer some way of converting the button4/button5
;; events into different event types, like 'mwheel-up' or
;; 'mwheel-down', but I cannot find a way to do this very easily (or
;; portably), so for now I just live with it.

;; To enable this code, simply put this at the top of your .emacs
;; file:
;;
Glenn Morris's avatar
Glenn Morris committed
36
;; (mouse-wheel-mode 1)
William M. Perry's avatar
William M. Perry committed
37 38 39 40

;;; Code:

(require 'custom)
41
(require 'timer)
William M. Perry's avatar
William M. Perry committed
42

43
(defvar mouse-wheel-mode)
Eli Zaretskii's avatar
Eli Zaretskii committed
44

45 46 47 48 49
;; Setter function for mouse-button user-options.  Switch Mouse Wheel
;; mode off and on again so that the old button is unbound and
;; new button is bound to mwheel-scroll.

(defun mouse-wheel-change-button (var button)
50 51
  (set-default var button)
  ;; Sync the bindings.
52
  (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
53

54
(defcustom mouse-wheel-down-event
55
  (if (or (featurep 'w32-win) (featurep 'ns-win))
56
      'wheel-up
57
    'mouse-4)
58
  "Event used for scrolling down."
59
  :group 'mouse
60
  :type 'symbol
61 62
  :set 'mouse-wheel-change-button)

63
(defcustom mouse-wheel-up-event
64
  (if (or (featurep 'w32-win) (featurep 'ns-win))
65
      'wheel-down
66
    'mouse-5)
67
  "Event used for scrolling up."
68
  :group 'mouse
69
  :type 'symbol
70 71
  :set 'mouse-wheel-change-button)

72
(defcustom mouse-wheel-click-event 'mouse-2
73 74
  "Event that should be temporarily inhibited after mouse scrolling.
The mouse wheel is typically on the mouse-2 button, so it may easily
75
happen that text is accidentally yanked into the buffer when
76 77 78 79 80 81 82 83 84
scrolling with the mouse wheel.  To prevent that, this variable can be
set to the event sent when clicking on the mouse wheel button."
  :group 'mouse
  :type 'symbol
  :set 'mouse-wheel-change-button)

(defcustom mouse-wheel-inhibit-click-time 0.35
  "Time in seconds to inhibit clicking on mouse wheel button after scroll."
  :group 'mouse
85
  :type 'number)
86

Stefan Monnier's avatar
Stefan Monnier committed
87
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil))
William M. Perry's avatar
William M. Perry committed
88
  "Amount to scroll windows by when spinning the mouse wheel.
89 90 91 92 93
This is an alist mapping the modifier key to the amount to scroll when
the wheel is moved with the modifier key depressed.
Elements of the list have the form (MODIFIERS . AMOUNT) or just AMOUNT if
MODIFIERS is nil.

94
AMOUNT should be the number of lines to scroll, or nil for near full
95 96 97
screen.  It can also be a floating point number, specifying the fraction of
a full screen to scroll.  A near full screen is `next-screen-context-lines'
less than a full screen."
William M. Perry's avatar
William M. Perry committed
98
  :group 'mouse
Stefan Monnier's avatar
Stefan Monnier committed
99 100
  :type '(cons
	  (choice :tag "Normal"
William M. Perry's avatar
William M. Perry committed
101
		  (const :tag "Full screen" :value nil)
Stefan Monnier's avatar
Stefan Monnier committed
102
		  (integer :tag "Specific # of lines")
103
		  (float :tag "Fraction of window")
104 105 106 107 108 109 110
		  (cons
		   (repeat (choice :tag "modifier"
				   (const alt) (const control) (const hyper)
				   (const meta) (const shift) (const super)))
		   (choice :tag "scroll amount"
			   (const :tag "Full screen" :value nil)
			   (integer :tag "Specific # of lines")
111
			   (float :tag "Fraction of window"))))
Stefan Monnier's avatar
Stefan Monnier committed
112 113
          (repeat
           (cons
114 115
            (repeat (choice :tag "modifier"
			    (const alt) (const control) (const hyper)
Stefan Monnier's avatar
Stefan Monnier committed
116 117 118 119
                            (const meta) (const shift) (const super)))
            (choice :tag "scroll amount"
                    (const :tag "Full screen" :value nil)
                    (integer :tag "Specific # of lines")
120 121
                    (float :tag "Fraction of window")))))
  :set 'mouse-wheel-change-button)
Stefan Monnier's avatar
Stefan Monnier committed
122

123
(defcustom mouse-wheel-progressive-speed t
Stefan Monnier's avatar
Stefan Monnier committed
124 125
  "If non-nil, the faster the user moves the wheel, the faster the scrolling.
Note that this has no effect when `mouse-wheel-scroll-amount' specifies
126 127
a \"near full screen\" scroll or when the mouse wheel sends key instead
of button events."
Stefan Monnier's avatar
Stefan Monnier committed
128 129
  :group 'mouse
  :type 'boolean)
William M. Perry's avatar
William M. Perry committed
130

131
(defcustom mouse-wheel-follow-mouse t
William M. Perry's avatar
William M. Perry committed
132
  "Whether the mouse wheel should scroll the window that the mouse is over.
133
This can be slightly disconcerting, but some people prefer it."
William M. Perry's avatar
William M. Perry committed
134 135 136
  :group 'mouse
  :type 'boolean)

137 138
;;; For tilt-scroll
;;;
Glenn Morris's avatar
Glenn Morris committed
139
(defcustom mouse-wheel-tilt-scroll nil
140 141 142 143 144
  "Enable scroll using tilting mouse wheel."
  :group 'mouse
  :type 'boolean
  :version "26.1")

Glenn Morris's avatar
Glenn Morris committed
145
(defcustom mouse-wheel-flip-direction nil
146 147 148 149 150
  "Swap direction of 'wheel-right and 'wheel-left."
  :group 'mouse
  :type 'boolean
  :version "26.1")

151 152 153
(eval-and-compile
  (if (fboundp 'event-button)
      (fset 'mwheel-event-button 'event-button)
Stefan Monnier's avatar
Stefan Monnier committed
154
    (defun mwheel-event-button (event)
155
      (let ((x (event-basic-type event)))
Stefan Monnier's avatar
Stefan Monnier committed
156
	;; Map mouse-wheel events to appropriate buttons
157
	(if (eq 'mouse-wheel x)
Stefan Monnier's avatar
Stefan Monnier committed
158 159
	    (let ((amount (car (cdr (cdr (cdr event))))))
	      (if (< amount 0)
160 161
		  mouse-wheel-up-event
		mouse-wheel-down-event))
162
	  x))))
Stefan Monnier's avatar
Stefan Monnier committed
163

164 165
  (if (fboundp 'event-window)
      (fset 'mwheel-event-window 'event-window)
Stefan Monnier's avatar
Stefan Monnier committed
166
    (defun mwheel-event-window (event)
167
      (posn-window (event-start event)))))
Stefan Monnier's avatar
Stefan Monnier committed
168

169 170 171 172 173 174 175 176 177 178 179 180 181
(defvar mwheel-inhibit-click-event-timer nil
  "Timer running while mouse wheel click event is inhibited.")

(defun mwheel-inhibit-click-timeout ()
  "Handler for `mwheel-inhibit-click-event-timer'."
  (setq mwheel-inhibit-click-event-timer nil)
  (remove-hook 'pre-command-hook 'mwheel-filter-click-events))

(defun mwheel-filter-click-events ()
  "Discard `mouse-wheel-click-event' while scrolling the mouse."
  (if (eq (event-basic-type last-input-event) mouse-wheel-click-event)
      (setq this-command 'ignore)))

182 183 184 185 186 187
(defvar mwheel-scroll-up-function 'scroll-up
  "Function that does the job of scrolling upward.")

(defvar mwheel-scroll-down-function 'scroll-down
  "Function that does the job of scrolling downward.")

Glenn Morris's avatar
Glenn Morris committed
188 189 190 191 192 193
(defvar mwheel-scroll-left-function 'scroll-left
  "Function that does the job of scrolling left.")

(defvar mwheel-scroll-right-function 'scroll-right
  "Function that does the job of scrolling right.")

194 195 196 197 198 199 200 201 202 203 204 205
(defvar mouse-wheel-left-event
  (if (or (featurep 'w32-win) (featurep 'ns-win))
      'wheel-left
    (intern "mouse-6"))
  "Event used for scrolling left.")

(defvar mouse-wheel-right-event
  (if (or (featurep 'w32-win) (featurep 'ns-win))
      'wheel-right
    (intern "mouse-7"))
  "Event used for scrolling right.")

Stefan Monnier's avatar
Stefan Monnier committed
206 207
(defun mwheel-scroll (event)
  "Scroll up or down according to the EVENT.
208 209
This should be bound only to mouse buttons 4, 5, 6, and 7 on
non-Windows systems."
210
  (interactive (list last-input-event))
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
  (let* ((selected-window (selected-window))
         (scroll-window
          (or (catch 'found
                (let* ((window (if mouse-wheel-follow-mouse
                                   (mwheel-event-window event)
                                 (selected-window)))
                       (frame (when (window-live-p window)
                                (frame-parameter
                                 (window-frame window) 'mouse-wheel-frame))))
                  (when (frame-live-p frame)
                    (let* ((pos (mouse-absolute-pixel-position))
                           (pos-x (car pos))
                           (pos-y (cdr pos)))
                      (walk-window-tree
                       (lambda (window-1)
                         (let ((edges (window-edges window-1 nil t t)))
                           (when (and (<= (nth 0 edges) pos-x)
                                      (<= pos-x (nth 2 edges))
                                      (<= (nth 1 edges) pos-y)
                                      (<= pos-y (nth 3 edges)))
                             (throw 'found window-1))))
                       frame nil t)))))
              (mwheel-event-window event)))
	 (old-point
          (and (eq scroll-window selected-window)
	       (eq (car-safe transient-mark-mode) 'only)
	       (window-point)))
Stefan Monnier's avatar
Stefan Monnier committed
238 239
         (mods
	  (delq 'click (delq 'double (delq 'triple (event-modifiers event)))))
240
         (amt (assoc mods mouse-wheel-scroll-amount)))
241 242 243
    (unless (eq scroll-window selected-window)
      ;; Mark window to be scrolled for redisplay.
      (select-window scroll-window 'mark-for-redisplay))
244 245 246 247
    ;; Extract the actual amount or find the element that has no modifiers.
    (if amt (setq amt (cdr amt))
      (let ((list-elt mouse-wheel-scroll-amount))
	(while (consp (setq amt (pop list-elt))))))
Stefan Monnier's avatar
Stefan Monnier committed
248
    (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height))))))
249
    (when (and mouse-wheel-progressive-speed (numberp amt))
Stefan Monnier's avatar
Stefan Monnier committed
250
      ;; When the double-mouse-N comes in, a mouse-N has been executed already,
251
      ;; So by adding things up we get a squaring up (1, 3, 6, 10, 15, ...).
Stefan Monnier's avatar
Stefan Monnier committed
252
      (setq amt (* amt (event-click-count event))))
253
    (when (numberp amt) (setq amt (* amt (event-line-count event))))
William M. Perry's avatar
William M. Perry committed
254
    (unwind-protect
Stefan Monnier's avatar
Stefan Monnier committed
255
	(let ((button (mwheel-event-button event)))
256
	  (cond ((eq button mouse-wheel-down-event)
257
                 (condition-case nil (funcall mwheel-scroll-down-function amt)
258 259 260 261
                   ;; Make sure we do indeed scroll to the beginning of
                   ;; the buffer.
                   (beginning-of-buffer
                    (unwind-protect
262
                        (funcall mwheel-scroll-down-function)
263 264 265
                      ;; If the first scroll succeeded, then some scrolling
                      ;; is possible: keep scrolling til the beginning but
                      ;; do not signal an error.  For some reason, we have
Glenn Morris's avatar
Glenn Morris committed
266
                      ;; to do it even if the first scroll signaled an
267 268 269 270 271
                      ;; error, because otherwise the window is recentered
                      ;; for a reason that escapes me.  This problem seems
                      ;; to only affect scroll-down.  --Stef
                      (set-window-start (selected-window) (point-min))))))
		((eq button mouse-wheel-up-event)
272
                 (condition-case nil (funcall mwheel-scroll-up-function amt)
273
                   ;; Make sure we do indeed scroll to the end of the buffer.
274
                   (end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
275
                ((eq button mouse-wheel-left-event) ; for tilt scroll
276 277
                 (when mouse-wheel-tilt-scroll
                   (funcall (if mouse-wheel-flip-direction
278 279 280
                                mwheel-scroll-right-function
                              mwheel-scroll-left-function) amt)))
                ((eq button mouse-wheel-right-event) ; for tilt scroll
281 282
                 (when mouse-wheel-tilt-scroll
                   (funcall (if mouse-wheel-flip-direction
283 284
                                mwheel-scroll-left-function
                              mwheel-scroll-right-function) amt)))
Stefan Monnier's avatar
Stefan Monnier committed
285
		(t (error "Bad binding in mwheel-scroll"))))
286 287 288 289 290 291 292 293 294 295 296 297
      (if (eq scroll-window selected-window)
	  ;; If there is a temporarily active region, deactivate it if
	  ;; scrolling moved point.
	  (when (and old-point (/= old-point (window-point)))
	    ;; Call `deactivate-mark' at the original position, so that
	    ;; the original region is saved to the X selection.
	    (let ((new-point (window-point)))
	      (goto-char old-point)
	      (deactivate-mark)
	      (goto-char new-point)))
	(select-window selected-window t))))

298 299 300 301
  (when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time)
    (if mwheel-inhibit-click-event-timer
	(cancel-timer mwheel-inhibit-click-event-timer)
      (add-hook 'pre-command-hook 'mwheel-filter-click-events))
302
    (setq mwheel-inhibit-click-event-timer
303 304
	  (run-with-timer mouse-wheel-inhibit-click-time nil
			  'mwheel-inhibit-click-timeout))))
305

306
(put 'mwheel-scroll 'scroll-command t)
307

308 309
(defvar mwheel-installed-bindings nil)

310
(define-minor-mode mouse-wheel-mode
311
  "Toggle mouse wheel support (Mouse Wheel mode)."
312 313 314 315 316 317
  :init-value t
  ;; We'd like to use custom-initialize-set here so the setup is done
  ;; before dumping, but at the point where the defcustom is evaluated,
  ;; the corresponding function isn't defined yet, so
  ;; custom-initialize-set signals an error.
  :initialize 'custom-initialize-delay
318 319
  :global t
  :group 'mouse
320 321 322 323 324 325 326
  ;; Remove previous bindings, if any.
  (while mwheel-installed-bindings
    (let ((key (pop mwheel-installed-bindings)))
      (when (eq (lookup-key (current-global-map) key) 'mwheel-scroll)
        (global-unset-key key))))
  ;; Setup bindings as needed.
  (when mouse-wheel-mode
327
    (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event mouse-wheel-right-event mouse-wheel-left-event))
328 329 330 331
      (dolist (key (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,event)])
                           mouse-wheel-scroll-amount))
        (global-set-key key 'mwheel-scroll)
        (push key mwheel-installed-bindings)))))
332 333

;;; Compatibility entry point
334
;; preloaded ;;;###autoload
335 336
(defun mwheel-install (&optional uninstall)
  "Enable mouse wheel support."
337
  (mouse-wheel-mode (if uninstall -1 1)))
338

William M. Perry's avatar
William M. Perry committed
339 340 341
(provide 'mwheel)

;;; mwheel.el ends here