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