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

3
;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004, 2005, 2006, 2007,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2008, 2009  Free Software Foundation, Inc.
William M. Perry's avatar
William M. Perry committed
5 6 7
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse

8
;; This file is part of GNU Emacs.
William M. Perry's avatar
William M. Perry committed
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 13
;; 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
14

15 16 17 18
;; 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
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/>.
William M. Perry's avatar
William M. Perry committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36

;;; 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
37
;; (mouse-wheel-mode 1)
William M. Perry's avatar
William M. Perry committed
38 39 40 41

;;; Code:

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

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

46 47 48 49 50
;; 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)
51 52
  (set-default var button)
  ;; Sync the bindings.
53
  (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
54

55 56
(defvar mouse-wheel-down-button 4)
(make-obsolete-variable 'mouse-wheel-down-button
57 58
                        'mouse-wheel-down-event
			"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 67
  :set 'mouse-wheel-change-button)

68 69
(defvar mouse-wheel-up-button 5)
(make-obsolete-variable 'mouse-wheel-up-button
70 71
                        'mouse-wheel-up-event
			"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 80
  :set 'mouse-wheel-change-button)

81 82
(defvar mouse-wheel-click-button 2)
(make-obsolete-variable 'mouse-wheel-click-button
83 84
                        'mouse-wheel-click-event
			"22.1")
85
(defcustom mouse-wheel-click-event
86
  (intern (format "mouse-%s" mouse-wheel-click-button))
87 88
  "Event that should be temporarily inhibited after mouse scrolling.
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 91 92 93 94 95 96 97 98
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
99
  :type 'number)
100

Stefan Monnier's avatar
Stefan Monnier committed
101
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil))
William M. Perry's avatar
William M. Perry committed
102
  "Amount to scroll windows by when spinning the mouse wheel.
103 104 105 106 107
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.

108
AMOUNT should be the number of lines to scroll, or nil for near full
109 110 111
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
112
  :group 'mouse
Stefan Monnier's avatar
Stefan Monnier committed
113 114
  :type '(cons
	  (choice :tag "Normal"
William M. Perry's avatar
William M. Perry committed
115
		  (const :tag "Full screen" :value nil)
Stefan Monnier's avatar
Stefan Monnier committed
116
		  (integer :tag "Specific # of lines")
117
		  (float :tag "Fraction of window")
118 119 120 121 122 123 124
		  (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")
125
			   (float :tag "Fraction of window"))))
Stefan Monnier's avatar
Stefan Monnier committed
126 127
          (repeat
           (cons
128 129
            (repeat (choice :tag "modifier"
			    (const alt) (const control) (const hyper)
Stefan Monnier's avatar
Stefan Monnier committed
130 131 132 133
                            (const meta) (const shift) (const super)))
            (choice :tag "scroll amount"
                    (const :tag "Full screen" :value nil)
                    (integer :tag "Specific # of lines")
134 135
                    (float :tag "Fraction of window")))))
  :set 'mouse-wheel-change-button)
Stefan Monnier's avatar
Stefan Monnier committed
136

137
(defcustom mouse-wheel-progressive-speed t
Stefan Monnier's avatar
Stefan Monnier committed
138 139
  "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
140 141
a \"near full screen\" scroll or when the mouse wheel sends key instead
of button events."
Stefan Monnier's avatar
Stefan Monnier committed
142 143
  :group 'mouse
  :type 'boolean)
William M. Perry's avatar
William M. Perry committed
144

145
(defcustom mouse-wheel-follow-mouse t
William M. Perry's avatar
William M. Perry committed
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."
William M. Perry's avatar
William M. Perry committed
148 149 150
  :group 'mouse
  :type 'boolean)

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)))

Stefan Monnier's avatar
Stefan Monnier committed
182 183 184
(defun mwheel-scroll (event)
  "Scroll up or down according to the EVENT.
This should only be bound to mouse buttons 4 and 5."
185
  (interactive (list last-input-event))
Stefan Monnier's avatar
Stefan Monnier committed
186 187 188 189
  (let* ((curwin (if mouse-wheel-follow-mouse
                     (prog1
                         (selected-window)
                       (select-window (mwheel-event-window event)))))
190 191 192 193
	 (buffer (window-buffer curwin))
	 (opoint (with-current-buffer buffer
		   (when (eq (car-safe transient-mark-mode) 'only)
		     (point))))
Stefan Monnier's avatar
Stefan Monnier committed
194 195
         (mods
	  (delq 'click (delq 'double (delq 'triple (event-modifiers event)))))
196 197 198 199 200
         (amt (assoc mods mouse-wheel-scroll-amount)))
    ;; 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
201
    (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height))))))
202
    (when (and mouse-wheel-progressive-speed (numberp amt))
Stefan Monnier's avatar
Stefan Monnier committed
203
      ;; When the double-mouse-N comes in, a mouse-N has been executed already,
204
      ;; So by adding things up we get a squaring up (1, 3, 6, 10, 15, ...).
Stefan Monnier's avatar
Stefan Monnier committed
205
      (setq amt (* amt (event-click-count event))))
William M. Perry's avatar
William M. Perry committed
206
    (unwind-protect
Stefan Monnier's avatar
Stefan Monnier committed
207
	(let ((button (mwheel-event-button event)))
208 209 210 211 212 213 214 215 216 217
	  (cond ((eq button mouse-wheel-down-event)
                 (condition-case nil (scroll-down amt)
                   ;; Make sure we do indeed scroll to the beginning of
                   ;; the buffer.
                   (beginning-of-buffer
                    (unwind-protect
                        (scroll-down)
                      ;; 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
218
                      ;; to do it even if the first scroll signaled an
219 220 221 222 223 224 225 226
                      ;; 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)
                 (condition-case nil (scroll-up amt)
                   ;; Make sure we do indeed scroll to the end of the buffer.
                   (end-of-buffer (while t (scroll-up)))))
Stefan Monnier's avatar
Stefan Monnier committed
227
		(t (error "Bad binding in mwheel-scroll"))))
228 229 230 231 232 233 234
      (if curwin (select-window curwin)))
    ;; If there is a temporarily active region, deactivate it iff
    ;; scrolling moves point.
    (when opoint
      (with-current-buffer buffer
	(when (/= opoint (point))
	  (deactivate-mark)))))
235 236 237 238
  (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))
239
    (setq mwheel-inhibit-click-event-timer
240 241
	  (run-with-timer mouse-wheel-inhibit-click-time nil
			  'mwheel-inhibit-click-timeout))))
242

243 244
(defvar mwheel-installed-bindings nil)

245
;; preloaded ;;;###autoload
246 247 248
(define-minor-mode mouse-wheel-mode
  "Toggle mouse wheel support.
With prefix argument ARG, turn on if positive, otherwise off.
249
Return non-nil if the new state is enabled."
250 251 252 253 254 255
  :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
256 257
  :global t
  :group 'mouse
258 259 260 261 262 263 264 265 266 267 268 269
  ;; 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
    (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
      (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)))))
270 271

;;; Compatibility entry point
272
;; preloaded ;;;###autoload
273 274
(defun mwheel-install (&optional uninstall)
  "Enable mouse wheel support."
275
  (mouse-wheel-mode (if uninstall -1 1)))
276

William M. Perry's avatar
William M. Perry committed
277 278
(provide 'mwheel)

279
;; arch-tag: 50ed00e7-3686-4b7a-8037-fb31aa5c237f
William M. Perry's avatar
William M. Perry committed
280
;;; mwheel.el ends here