1 |
;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
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 |
|
|
46 |
;; new button is bound to mwheel-scroll. |
;; new button is bound to mwheel-scroll. |
47 |
|
|
48 |
(defun mouse-wheel-change-button (var button) |
(defun mouse-wheel-change-button (var button) |
49 |
(set-default var button) |
(let ((active mouse-wheel-mode)) |
50 |
(when mouse-wheel-mode |
;; Deactivate before changing the setting. |
51 |
(mouse-wheel-mode 0) |
(when active (mouse-wheel-mode -1)) |
52 |
(mouse-wheel-mode 1))) |
(set-default var button) |
53 |
|
(when active (mouse-wheel-mode 1)))) |
54 |
|
|
55 |
(defcustom mouse-wheel-down-button 4 |
(defcustom mouse-wheel-down-button 4 |
56 |
"Mouse button number for scrolling down." |
"Obsolete. Use `mouse-wheel-down-event'.") |
57 |
|
(defcustom mouse-wheel-down-event |
58 |
|
;; In the latest versions of XEmacs, we could just use mouse-%s as well. |
59 |
|
(intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") |
60 |
|
mouse-wheel-down-button)) |
61 |
|
"Event used for scrolling down." |
62 |
:group 'mouse |
:group 'mouse |
63 |
:type 'integer |
:type 'symbol |
64 |
:set 'mouse-wheel-change-button) |
:set 'mouse-wheel-change-button) |
65 |
|
|
66 |
(defcustom mouse-wheel-up-button 5 |
(defcustom mouse-wheel-up-button 5 |
67 |
"Mouse button number for scrolling up." |
"Obsolete. Use `mouse-whell-up-event'.") |
68 |
|
(defcustom mouse-wheel-up-event |
69 |
|
;; In the latest versions of XEmacs, we could just use mouse-%s as well. |
70 |
|
(intern (format (if (featurep 'xemacs) "button%s" "mouse-%s") |
71 |
|
mouse-wheel-up-button)) |
72 |
|
"Event used for scrolling down." |
73 |
:group 'mouse |
:group 'mouse |
74 |
:type 'integer |
:type 'symbol |
75 |
:set 'mouse-wheel-change-button) |
:set 'mouse-wheel-change-button) |
76 |
|
|
77 |
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) |
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) |
117 |
:group 'mouse |
:group 'mouse |
118 |
:type 'boolean) |
:type 'boolean) |
119 |
|
|
120 |
(defcustom mouse-wheel-follow-mouse nil |
(defcustom mouse-wheel-follow-mouse t |
121 |
"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. |
122 |
This can be slightly disconcerting, but some people prefer it." |
This can be slightly disconcerting, but some people prefer it." |
123 |
:group 'mouse |
:group 'mouse |
125 |
|
|
126 |
(if (not (fboundp 'event-button)) |
(if (not (fboundp 'event-button)) |
127 |
(defun mwheel-event-button (event) |
(defun mwheel-event-button (event) |
128 |
(let ((x (symbol-name (event-basic-type event)))) |
(let ((x (event-basic-type event))) |
129 |
;; Map mouse-wheel events to appropriate buttons |
;; Map mouse-wheel events to appropriate buttons |
130 |
(if (string-equal "mouse-wheel" x) |
(if (eq 'mouse-wheel x) |
131 |
(let ((amount (car (cdr (cdr (cdr event)))))) |
(let ((amount (car (cdr (cdr (cdr event)))))) |
132 |
(if (< amount 0) |
(if (< amount 0) |
133 |
mouse-wheel-up-button |
mouse-wheel-up-event |
134 |
mouse-wheel-down-button)) |
mouse-wheel-down-event)) |
135 |
(if (not (string-match "^mouse-\\([0-9]+\\)" x)) |
x))) |
|
(error "Not a button event: %S" event) |
|
|
(string-to-int (substring x (match-beginning 1) (match-end 1))))))) |
|
136 |
(fset 'mwheel-event-button 'event-button)) |
(fset 'mwheel-event-button 'event-button)) |
137 |
|
|
138 |
(if (not (fboundp 'event-window)) |
(if (not (fboundp 'event-window)) |
143 |
(defun mwheel-scroll (event) |
(defun mwheel-scroll (event) |
144 |
"Scroll up or down according to the EVENT. |
"Scroll up or down according to the EVENT. |
145 |
This should only be bound to mouse buttons 4 and 5." |
This should only be bound to mouse buttons 4 and 5." |
146 |
(interactive "e") |
(interactive (list last-input-event)) |
147 |
(let* ((curwin (if mouse-wheel-follow-mouse |
(let* ((curwin (if mouse-wheel-follow-mouse |
148 |
(prog1 |
(prog1 |
149 |
(selected-window) |
(selected-window) |
158 |
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) |
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) |
159 |
(when (and mouse-wheel-progessive-speed (numberp amt)) |
(when (and mouse-wheel-progessive-speed (numberp amt)) |
160 |
;; 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, |
161 |
;; 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, ...). |
162 |
(setq amt (* amt (event-click-count event)))) |
(setq amt (* amt (event-click-count event)))) |
163 |
(unwind-protect |
(unwind-protect |
164 |
(let ((button (mwheel-event-button event))) |
(let ((button (mwheel-event-button event))) |
165 |
(cond ((= button mouse-wheel-down-button) (scroll-down amt)) |
(cond ((eq button mouse-wheel-down-event) (scroll-down amt)) |
166 |
((= button mouse-wheel-up-button) (scroll-up amt)) |
((eq button mouse-wheel-up-event) (scroll-up amt)) |
167 |
(t (error "Bad binding in mwheel-scroll")))) |
(t (error "Bad binding in mwheel-scroll")))) |
168 |
(if curwin (select-window curwin))))) |
(if curwin (select-window curwin))))) |
169 |
|
|
175 |
Returns non-nil if the new state is enabled." |
Returns non-nil if the new state is enabled." |
176 |
:global t |
:global t |
177 |
:group 'mouse |
:group 'mouse |
178 |
;; In the latest versions of XEmacs, we could just use |
(let* ((dn mouse-wheel-down-event) |
179 |
;; (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))) |
|
180 |
(keys |
(keys |
181 |
(nconc (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,up)]) |
(nconc (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,up)]) |
182 |
mouse-wheel-scroll-amount) |
mouse-wheel-scroll-amount) |
199 |
;;;###autoload |
;;;###autoload |
200 |
(defun mwheel-install (&optional uninstall) |
(defun mwheel-install (&optional uninstall) |
201 |
"Enable mouse wheel support." |
"Enable mouse wheel support." |
202 |
(mouse-wheel-mode t)) |
(mouse-wheel-mode (if uninstall -1 1))) |
203 |
|
|
204 |
(provide 'mwheel) |
(provide 'mwheel) |
205 |
|
|