1;;; mwheel.el --- Wheel mouse support 2 3;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5;; Maintainer: William M. Perry <wmperry@gnu.org> 6;; Keywords: mouse 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 2, or (at your option) 13;; 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; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26 27;; This code will enable the use of the infamous 'wheel' on the new 28;; crop of mice. Under XFree86 and the XSuSE X Servers, the wheel 29;; events are sent as button4/button5 events. 30 31;; I for one would prefer some way of converting the button4/button5 32;; events into different event types, like 'mwheel-up' or 33;; 'mwheel-down', but I cannot find a way to do this very easily (or 34;; portably), so for now I just live with it. 35 36;; To enable this code, simply put this at the top of your .emacs 37;; file: 38;; 39;; (mouse-wheel-mode 1) 40 41;;; Code: 42 43(require 'custom) 44(require 'timer) 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 (let ((active mouse-wheel-mode)) 52 ;; Deactivate before changing the setting. 53 (when active (mouse-wheel-mode -1)) 54 (set-default var button) 55 (when active (mouse-wheel-mode 1)))) 56 57(defvar mouse-wheel-down-button 4) 58(make-obsolete-variable 'mouse-wheel-down-button 59 'mouse-wheel-down-event) 60(defcustom mouse-wheel-down-event 61 ;; In the latest versions of XEmacs, we could just use mouse-%s as well. 62 (if (memq window-system '(w32 mac)) 63 'wheel-up 64 (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") 65 mouse-wheel-down-button))) 66 "Event used for scrolling down." 67 :group 'mouse 68 :type 'symbol 69 :set 'mouse-wheel-change-button) 70 71(defvar mouse-wheel-up-button 5) 72(make-obsolete-variable 'mouse-wheel-up-button 73 'mouse-wheel-up-event) 74(defcustom mouse-wheel-up-event 75 ;; In the latest versions of XEmacs, we could just use mouse-%s as well. 76 (if (memq window-system '(w32 mac)) 77 'wheel-down 78 (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") 79 mouse-wheel-up-button))) 80 "Event used for scrolling up." 81 :group 'mouse 82 :type 'symbol 83 :set 'mouse-wheel-change-button) 84 85(defvar mouse-wheel-click-button 2) 86(make-obsolete-variable 'mouse-wheel-click-button 87 'mouse-wheel-click-event) 88(defcustom mouse-wheel-click-event 89 ;; In the latest versions of XEmacs, we could just use mouse-%s as well. 90 (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") 91 mouse-wheel-click-button)) 92 "Event that should be temporarily inhibited after mouse scrolling. 93The mouse wheel is typically on the mouse-2 button, so it may easily 94happen that text is accidentally yanked into the buffer when 95scrolling with the mouse wheel. To prevent that, this variable can be 96set to the event sent when clicking on the mouse wheel button." 97 :group 'mouse 98 :type 'symbol 99 :set 'mouse-wheel-change-button) 100 101(defcustom mouse-wheel-inhibit-click-time 0.35 102 "Time in seconds to inhibit clicking on mouse wheel button after scroll." 103 :group 'mouse 104 :type 'number) 105 106(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) 107 "Amount to scroll windows by when spinning the mouse wheel. 108This is an alist mapping the modifier key to the amount to scroll when 109the wheel is moved with the modifier key depressed. 110Elements of the list have the form (MODIFIERS . AMOUNT) or just AMOUNT if 111MODIFIERS is nil. 112 113AMOUNT should be the number of lines to scroll, or nil for near full 114screen. It can also be a floating point number, specifying the fraction of 115a full screen to scroll. A near full screen is `next-screen-context-lines' 116less than a full screen." 117 :group 'mouse 118 :type '(cons 119 (choice :tag "Normal" 120 (const :tag "Full screen" :value nil) 121 (integer :tag "Specific # of lines") 122 (float :tag "Fraction of window") 123 (cons 124 (repeat (choice :tag "modifier" 125 (const alt) (const control) (const hyper) 126 (const meta) (const shift) (const super))) 127 (choice :tag "scroll amount" 128 (const :tag "Full screen" :value nil) 129 (integer :tag "Specific # of lines") 130 (float :tag "Fraction of window")))) 131 (repeat 132 (cons 133 (repeat (choice :tag "modifier" 134 (const alt) (const control) (const hyper) 135 (const meta) (const shift) (const super))) 136 (choice :tag "scroll amount" 137 (const :tag "Full screen" :value nil) 138 (integer :tag "Specific # of lines") 139 (float :tag "Fraction of window")))))) 140 141(defcustom mouse-wheel-progressive-speed t 142 "If non-nil, the faster the user moves the wheel, the faster the scrolling. 143Note that this has no effect when `mouse-wheel-scroll-amount' specifies 144a \"near full screen\" scroll or when the mouse wheel sends key instead 145of button events." 146 :group 'mouse 147 :type 'boolean) 148 149(defcustom mouse-wheel-follow-mouse t 150 "Whether the mouse wheel should scroll the window that the mouse is over. 151This can be slightly disconcerting, but some people prefer it." 152 :group 'mouse 153 :type 'boolean) 154 155(if (not (fboundp 'event-button)) 156 (defun mwheel-event-button (event) 157 (let ((x (event-basic-type event))) 158 ;; Map mouse-wheel events to appropriate buttons 159 (if (eq 'mouse-wheel x) 160 (let ((amount (car (cdr (cdr (cdr event)))))) 161 (if (< amount 0) 162 mouse-wheel-up-event 163 mouse-wheel-down-event)) 164 x))) 165 (fset 'mwheel-event-button 'event-button)) 166 167(if (not (fboundp 'event-window)) 168 (defun mwheel-event-window (event) 169 (posn-window (event-start event))) 170 (fset 'mwheel-event-window 'event-window)) 171 172(defvar mwheel-inhibit-click-event-timer nil 173 "Timer running while mouse wheel click event is inhibited.") 174 175(defun mwheel-inhibit-click-timeout () 176 "Handler for `mwheel-inhibit-click-event-timer'." 177 (setq mwheel-inhibit-click-event-timer nil) 178 (remove-hook 'pre-command-hook 'mwheel-filter-click-events)) 179 180(defun mwheel-filter-click-events () 181 "Discard `mouse-wheel-click-event' while scrolling the mouse." 182 (if (eq (event-basic-type last-input-event) mouse-wheel-click-event) 183 (setq this-command 'ignore))) 184 185(defun mwheel-scroll (event) 186 "Scroll up or down according to the EVENT. 187This should only be bound to mouse buttons 4 and 5." 188 (interactive (list last-input-event)) 189 (let* ((curwin (if mouse-wheel-follow-mouse 190 (prog1 191 (selected-window) 192 (select-window (mwheel-event-window event))))) 193 (mods 194 (delq 'click (delq 'double (delq 'triple (event-modifiers event))))) 195 (amt (assoc mods mouse-wheel-scroll-amount))) 196 ;; Extract the actual amount or find the element that has no modifiers. 197 (if amt (setq amt (cdr amt)) 198 (let ((list-elt mouse-wheel-scroll-amount)) 199 (while (consp (setq amt (pop list-elt)))))) 200 (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) 201 (when (and mouse-wheel-progressive-speed (numberp amt)) 202 ;; When the double-mouse-N comes in, a mouse-N has been executed already, 203 ;; So by adding things up we get a squaring up (1, 3, 6, 10, 15, ...). 204 (setq amt (* amt (event-click-count event)))) 205 (unwind-protect 206 (let ((button (mwheel-event-button event))) 207 (cond ((eq button mouse-wheel-down-event) 208 (condition-case nil (scroll-down amt) 209 ;; Make sure we do indeed scroll to the beginning of 210 ;; the buffer. 211 (beginning-of-buffer 212 (unwind-protect 213 (scroll-down) 214 ;; If the first scroll succeeded, then some scrolling 215 ;; is possible: keep scrolling til the beginning but 216 ;; do not signal an error. For some reason, we have 217 ;; to do it even if the first scroll signalled an 218 ;; error, because otherwise the window is recentered 219 ;; for a reason that escapes me. This problem seems 220 ;; to only affect scroll-down. --Stef 221 (set-window-start (selected-window) (point-min)))))) 222 ((eq button mouse-wheel-up-event) 223 (condition-case nil (scroll-up amt) 224 ;; Make sure we do indeed scroll to the end of the buffer. 225 (end-of-buffer (while t (scroll-up))))) 226 (t (error "Bad binding in mwheel-scroll")))) 227 (if curwin (select-window curwin)))) 228 (when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time) 229 (if mwheel-inhibit-click-event-timer 230 (cancel-timer mwheel-inhibit-click-event-timer) 231 (add-hook 'pre-command-hook 'mwheel-filter-click-events)) 232 (setq mwheel-inhibit-click-event-timer 233 (run-with-timer mouse-wheel-inhibit-click-time nil 234 'mwheel-inhibit-click-timeout)))) 235 236;;;###autoload 237(define-minor-mode mouse-wheel-mode 238 "Toggle mouse wheel support. 239With prefix argument ARG, turn on if positive, otherwise off. 240Return non-nil if the new state is enabled." 241 :global t 242 :group 'mouse 243 (let* ((dn mouse-wheel-down-event) 244 (up mouse-wheel-up-event) 245 (keys 246 (nconc (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,up)]) 247 mouse-wheel-scroll-amount) 248 (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,dn)]) 249 mouse-wheel-scroll-amount)))) 250 ;; This condition-case is here because Emacs 19 will throw an error 251 ;; if you try to define a key that it does not know about. I for one 252 ;; prefer to just unconditionally do a mwheel-install in my .emacs, so 253 ;; that if the wheeled-mouse is there, it just works, and this way it 254 ;; doesn't yell at me if I'm on my laptop or another machine, etc. 255 (condition-case () 256 (dolist (key keys) 257 (cond (mouse-wheel-mode 258 (global-set-key key 'mwheel-scroll)) 259 ((eq (lookup-key (current-global-map) key) 'mwheel-scroll) 260 (global-unset-key key)))) 261 (error nil)))) 262 263;;; Compatibility entry point 264;;;###autoload 265(defun mwheel-install (&optional uninstall) 266 "Enable mouse wheel support." 267 (mouse-wheel-mode (if uninstall -1 1))) 268 269(provide 'mwheel) 270 271;; arch-tag: 50ed00e7-3686-4b7a-8037-fb31aa5c237f 272;;; mwheel.el ends here 273