1 |
;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
;;; mwheel.el --- Wheel mouse support |
2 |
|
|
3 |
;; Copyright (C) 1998, 2000, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1998,2000,2001,2002 Free Software Foundation, Inc. |
4 |
;; Maintainer: William M. Perry <wmperry@gnu.org> |
;; Maintainer: William M. Perry <wmperry@gnu.org> |
5 |
;; Keywords: mouse |
;; Keywords: mouse |
6 |
|
|
40 |
;;; Code: |
;;; Code: |
41 |
|
|
42 |
(require 'custom) |
(require 'custom) |
43 |
|
(require 'timer) |
44 |
|
|
45 |
;; Setter function for mouse-button user-options. Switch Mouse Wheel |
;; Setter function for mouse-button user-options. Switch Mouse Wheel |
46 |
;; mode off and on again so that the old button is unbound and |
;; mode off and on again so that the old button is unbound and |
47 |
;; new button is bound to mwheel-scroll. |
;; new button is bound to mwheel-scroll. |
48 |
|
|
49 |
(defun mouse-wheel-change-button (var button) |
(defun mouse-wheel-change-button (var button) |
50 |
(set-default var button) |
(let ((active mouse-wheel-mode)) |
51 |
(when mouse-wheel-mode |
;; Deactivate before changing the setting. |
52 |
(mouse-wheel-mode 0) |
(when active (mouse-wheel-mode -1)) |
53 |
(mouse-wheel-mode 1))) |
(set-default var button) |
54 |
|
(when active (mouse-wheel-mode 1)))) |
55 |
|
|
56 |
|
(defvar mouse-wheel-down-button 4) |
57 |
|
(make-obsolete-variable 'mouse-wheel-down-button |
58 |
|
'mouse-wheel-down-event) |
59 |
|
(defcustom mouse-wheel-down-event |
60 |
|
;; In the latest versions of XEmacs, we could just use mouse-%s as well. |
61 |
|
(intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") |
62 |
|
mouse-wheel-down-button)) |
63 |
|
"Event used for scrolling down." |
64 |
|
:group 'mouse |
65 |
|
:type 'symbol |
66 |
|
:set 'mouse-wheel-change-button) |
67 |
|
|
68 |
(defcustom mouse-wheel-down-button 4 |
(defvar mouse-wheel-up-button 5) |
69 |
"Mouse button number for scrolling down." |
(make-obsolete-variable 'mouse-wheel-up-button |
70 |
|
'mouse-wheel-up-event) |
71 |
|
(defcustom mouse-wheel-up-event |
72 |
|
;; In the latest versions of XEmacs, we could just use mouse-%s as well. |
73 |
|
(intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") |
74 |
|
mouse-wheel-up-button)) |
75 |
|
"Event used for scrolling down." |
76 |
:group 'mouse |
:group 'mouse |
77 |
:type 'integer |
:type 'symbol |
78 |
:set 'mouse-wheel-change-button) |
:set 'mouse-wheel-change-button) |
79 |
|
|
80 |
(defcustom mouse-wheel-up-button 5 |
(defvar mouse-wheel-click-button 2) |
81 |
"Mouse button number for scrolling up." |
(make-obsolete-variable 'mouse-wheel-click-button |
82 |
|
'mouse-wheel-click-event) |
83 |
|
(defcustom mouse-wheel-click-event |
84 |
|
;; In the latest versions of XEmacs, we could just use mouse-%s as well. |
85 |
|
(intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") |
86 |
|
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 accidentially 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 |
:group 'mouse |
93 |
:type 'integer |
:type 'symbol |
94 |
:set 'mouse-wheel-change-button) |
: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)) |
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) |
102 |
"Amount to scroll windows by when spinning the mouse wheel. |
"Amount to scroll windows by when spinning the mouse wheel. |
103 |
This is actually a cons cell, where the first item is the amount to scroll |
This is an alist mapping the modifier key to the amount to scroll when |
104 |
on a normal wheel event, and the rest is an alist mapping the modifier key |
the wheel is moved with the modifier key depressed. |
105 |
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 |
106 |
|
MODIFIERS is nil. |
107 |
Each item should be the number of lines to scroll, or `nil' for near |
|
108 |
full screen. It can also be a floating point number, specifying |
AMOUNT should be the number of lines to scroll, or `nil' for near full |
109 |
the fraction of the window to scroll. |
screen. It can also be a floating point number, specifying the fraction of |
110 |
A near full screen is `next-screen-context-lines' less than a full screen." |
a full screen to scroll. A near full screen is `next-screen-context-lines' |
111 |
|
less than a full screen." |
112 |
:group 'mouse |
:group 'mouse |
113 |
:type '(cons |
:type '(cons |
114 |
(choice :tag "Normal" |
(choice :tag "Normal" |
115 |
(const :tag "Full screen" :value nil) |
(const :tag "Full screen" :value nil) |
116 |
(integer :tag "Specific # of lines") |
(integer :tag "Specific # of lines") |
117 |
(float :tag "Fraction of window")) |
(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 |
(repeat |
127 |
(cons |
(cons |
128 |
(repeat (choice :tag "modifier" (const alt) (const control) (const hyper) |
(repeat (choice :tag "modifier" |
129 |
|
(const alt) (const control) (const hyper) |
130 |
(const meta) (const shift) (const super))) |
(const meta) (const shift) (const super))) |
131 |
(choice :tag "scroll amount" |
(choice :tag "scroll amount" |
132 |
(const :tag "Full screen" :value nil) |
(const :tag "Full screen" :value nil) |
136 |
(defcustom mouse-wheel-progessive-speed t |
(defcustom mouse-wheel-progessive-speed t |
137 |
"If non-nil, the faster the user moves the wheel, the faster the scrolling. |
"If non-nil, the faster the user moves the wheel, the faster the scrolling. |
138 |
Note that this has no effect when `mouse-wheel-scroll-amount' specifies |
Note that this has no effect when `mouse-wheel-scroll-amount' specifies |
139 |
a \"near full screen\" scroll." |
a \"near full screen\" scroll or when the mouse wheel sends key instead |
140 |
|
of button events." |
141 |
:group 'mouse |
:group 'mouse |
142 |
:type 'boolean) |
:type 'boolean) |
143 |
|
|
144 |
(defcustom mouse-wheel-follow-mouse nil |
(defcustom mouse-wheel-follow-mouse t |
145 |
"Whether the mouse wheel should scroll the window that the mouse is over. |
"Whether the mouse wheel should scroll the window that the mouse is over. |
146 |
This can be slightly disconcerting, but some people may prefer it." |
This can be slightly disconcerting, but some people prefer it." |
147 |
:group 'mouse |
:group 'mouse |
148 |
:type 'boolean) |
:type 'boolean) |
149 |
|
|
150 |
(if (not (fboundp 'event-button)) |
(if (not (fboundp 'event-button)) |
151 |
(defun mwheel-event-button (event) |
(defun mwheel-event-button (event) |
152 |
(let ((x (symbol-name (event-basic-type event)))) |
(let ((x (event-basic-type event))) |
153 |
;; Map mouse-wheel events to appropriate buttons |
;; Map mouse-wheel events to appropriate buttons |
154 |
(if (string-equal "mouse-wheel" x) |
(if (eq 'mouse-wheel x) |
155 |
(let ((amount (car (cdr (cdr (cdr event)))))) |
(let ((amount (car (cdr (cdr (cdr event)))))) |
156 |
(if (< amount 0) |
(if (< amount 0) |
157 |
mouse-wheel-up-button |
mouse-wheel-up-event |
158 |
mouse-wheel-down-button)) |
mouse-wheel-down-event)) |
159 |
(if (not (string-match "^mouse-\\([0-9]+\\)" x)) |
x))) |
160 |
(error "Not a button event: %S" event) |
(fset 'mwheel-event-button 'event-button)) |
|
(string-to-int (substring x (match-beginning 1) (match-end 1))))))) |
|
|
(fset 'mwheel-event-button 'event-button)) |
|
161 |
|
|
162 |
(if (not (fboundp 'event-window)) |
(if (not (fboundp 'event-window)) |
163 |
(defun mwheel-event-window (event) |
(defun mwheel-event-window (event) |
164 |
(posn-window (event-start event))) |
(posn-window (event-start event))) |
165 |
(fset 'mwheel-event-window 'event-window)) |
(fset 'mwheel-event-window 'event-window)) |
166 |
|
|
167 |
|
(defvar mwheel-inhibit-click-event-timer nil |
168 |
|
"Timer running while mouse wheel click event is inhibited.") |
169 |
|
|
170 |
|
(defun mwheel-inhibit-click-timeout () |
171 |
|
"Handler for `mwheel-inhibit-click-event-timer'." |
172 |
|
(setq mwheel-inhibit-click-event-timer nil) |
173 |
|
(remove-hook 'pre-command-hook 'mwheel-filter-click-events)) |
174 |
|
|
175 |
|
(defun mwheel-filter-click-events () |
176 |
|
"Discard `mouse-wheel-click-event' while scrolling the mouse." |
177 |
|
(if (eq (event-basic-type last-input-event) mouse-wheel-click-event) |
178 |
|
(setq this-command 'ignore))) |
179 |
|
|
180 |
(defun mwheel-scroll (event) |
(defun mwheel-scroll (event) |
181 |
"Scroll up or down according to the EVENT. |
"Scroll up or down according to the EVENT. |
182 |
This should only be bound to mouse buttons 4 and 5." |
This should only be bound to mouse buttons 4 and 5." |
183 |
(interactive "e") |
(interactive (list last-input-event)) |
184 |
(let* ((curwin (if mouse-wheel-follow-mouse |
(let* ((curwin (if mouse-wheel-follow-mouse |
185 |
(prog1 |
(prog1 |
186 |
(selected-window) |
(selected-window) |
187 |
(select-window (mwheel-event-window event))))) |
(select-window (mwheel-event-window event))))) |
188 |
(mods |
(mods |
189 |
(delq 'click (delq 'double (delq 'triple (event-modifiers event))))) |
(delq 'click (delq 'double (delq 'triple (event-modifiers event))))) |
190 |
(amt |
(amt (assoc mods mouse-wheel-scroll-amount))) |
191 |
(if mods |
;; Extract the actual amount or find the element that has no modifiers. |
192 |
(cdr (assoc mods (cdr mouse-wheel-scroll-amount))) |
(if amt (setq amt (cdr amt)) |
193 |
(car mouse-wheel-scroll-amount)))) |
(let ((list-elt mouse-wheel-scroll-amount)) |
194 |
|
(while (consp (setq amt (pop list-elt)))))) |
195 |
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) |
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) |
196 |
(when (and mouse-wheel-progessive-speed (numberp amt)) |
(when (and mouse-wheel-progessive-speed (numberp amt)) |
197 |
;; When the double-mouse-N comes in, a mouse-N has been executed already, |
;; When the double-mouse-N comes in, a mouse-N has been executed already, |
198 |
;; So by adding things up we get a squaring up (1, 3, 6, 10, 16, ...). |
;; So by adding things up we get a squaring up (1, 3, 6, 10, 15, ...). |
199 |
(setq amt (* amt (event-click-count event)))) |
(setq amt (* amt (event-click-count event)))) |
200 |
(unwind-protect |
(unwind-protect |
201 |
(let ((button (mwheel-event-button event))) |
(let ((button (mwheel-event-button event))) |
202 |
(cond ((= button mouse-wheel-down-button) (scroll-down amt)) |
(cond ((eq button mouse-wheel-down-event) (scroll-down amt)) |
203 |
((= button mouse-wheel-up-button) (scroll-up amt)) |
((eq button mouse-wheel-up-event) (scroll-up amt)) |
204 |
(t (error "Bad binding in mwheel-scroll")))) |
(t (error "Bad binding in mwheel-scroll")))) |
205 |
(if curwin (select-window curwin))))) |
(if curwin (select-window curwin)))) |
206 |
|
(when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time) |
207 |
|
(if mwheel-inhibit-click-event-timer |
208 |
|
(cancel-timer mwheel-inhibit-click-event-timer) |
209 |
|
(add-hook 'pre-command-hook 'mwheel-filter-click-events)) |
210 |
|
(setq mwheel-inhibit-click-event-timer |
211 |
|
(run-with-timer mouse-wheel-inhibit-click-time nil |
212 |
|
'mwheel-inhibit-click-timeout)))) |
213 |
|
|
214 |
;;;###autoload |
;;;###autoload |
215 |
(define-minor-mode mouse-wheel-mode |
(define-minor-mode mouse-wheel-mode |
218 |
Returns non-nil if the new state is enabled." |
Returns non-nil if the new state is enabled." |
219 |
:global t |
:global t |
220 |
:group 'mouse |
:group 'mouse |
221 |
;; In the latest versions of XEmacs, we could just use |
(let* ((dn mouse-wheel-down-event) |
222 |
;; (S-)*mouse-[45], since those are aliases for the button |
(up mouse-wheel-up-event) |
|
;; equivalents in XEmacs, but I want this to work in as many |
|
|
;; versions of XEmacs as it can. |
|
|
(let* ((prefix (if (featurep 'xemacs) "button%d" "mouse-%d")) |
|
|
(dn (intern (format prefix mouse-wheel-down-button))) |
|
|
(up (intern (format prefix mouse-wheel-up-button))) |
|
223 |
(keys |
(keys |
224 |
(nconc (list (vector dn) (vector up)) |
(nconc (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,up)]) |
225 |
(mapcar (lambda (amt) `[(,@(car amt) ,up)]) |
mouse-wheel-scroll-amount) |
226 |
(cdr mouse-wheel-scroll-amount)) |
(mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,dn)]) |
227 |
(mapcar (lambda (amt) `[(,@(car amt) ,dn)]) |
mouse-wheel-scroll-amount)))) |
|
(cdr mouse-wheel-scroll-amount))))) |
|
228 |
;; This condition-case is here because Emacs 19 will throw an error |
;; This condition-case is here because Emacs 19 will throw an error |
229 |
;; if you try to define a key that it does not know about. I for one |
;; if you try to define a key that it does not know about. I for one |
230 |
;; prefer to just unconditionally do a mwheel-install in my .emacs, so |
;; prefer to just unconditionally do a mwheel-install in my .emacs, so |
242 |
;;;###autoload |
;;;###autoload |
243 |
(defun mwheel-install (&optional uninstall) |
(defun mwheel-install (&optional uninstall) |
244 |
"Enable mouse wheel support." |
"Enable mouse wheel support." |
245 |
(mouse-wheel-mode t)) |
(mouse-wheel-mode (if uninstall -1 1))) |
246 |
|
|
247 |
(provide 'mwheel) |
(provide 'mwheel) |
248 |
|
|