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 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 |
|
|
63 |
:type 'integer |
:type 'integer |
64 |
:set 'mouse-wheel-change-button) |
:set 'mouse-wheel-change-button) |
65 |
|
|
66 |
(defcustom mouse-wheel-scroll-amount '(1 5 nil) |
(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) |
67 |
"Amount to scroll windows by when spinning the mouse wheel. |
"Amount to scroll windows by when spinning the mouse wheel. |
68 |
This is actually a list, where the first element is the amount to |
This is actually a cons cell, where the first item is the amount to scroll |
69 |
scroll slowly (normally invoked with the Shift key depressed) the |
on a normal wheel event, and the rest is an alist mapping the modifier key |
70 |
second is the amount to scroll on a normal wheel event, and the third |
to the amount to scroll when the wheel is moved with the modifier key depressed. |
|
is the amount to scroll fast (normally with the Control key depressed). |
|
71 |
|
|
72 |
Each item should be the number of lines to scroll, or `nil' for near |
Each item should be the number of lines to scroll, or `nil' for near |
73 |
full screen. |
full screen. It can also be a floating point number, specifying |
74 |
|
the fraction of the window to scroll. |
75 |
A near full screen is `next-screen-context-lines' less than a full screen." |
A near full screen is `next-screen-context-lines' less than a full screen." |
76 |
:group 'mouse |
:group 'mouse |
77 |
:type '(list |
:type '(cons |
78 |
(choice :tag "Slow (Shift key)" |
(choice :tag "Normal" |
79 |
(const :tag "Full screen" :value nil) |
(const :tag "Full screen" :value nil) |
80 |
(integer :tag "Specific # of lines")) |
(integer :tag "Specific # of lines") |
81 |
(choice :tag "Normal (no keys)" |
(float :tag "Fraction of window")) |
82 |
(const :tag "Full screen" :value nil) |
(repeat |
83 |
(integer :tag "Specific # of lines")) |
(cons |
84 |
(choice :tag "Fast (Ctrl key)" |
(repeat (choice :tag "modifier" (const alt) (const control) (const hyper) |
85 |
(const :tag "Full screen" :value nil) |
(const meta) (const shift) (const super))) |
86 |
(integer :tag "Specific # of lines")))) |
(choice :tag "scroll amount" |
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 |
|
|
98 |
(defcustom mouse-wheel-follow-mouse nil |
(defcustom mouse-wheel-follow-mouse nil |
99 |
"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. |
101 |
:group 'mouse |
:group 'mouse |
102 |
:type 'boolean) |
:type 'boolean) |
103 |
|
|
104 |
(defun mouse-wheel-event-window () |
(if (not (fboundp 'event-button)) |
105 |
"Return the window associated with this mouse command." |
(defun mwheel-event-button (event) |
106 |
;; If the command was a mouse event, the window is stored in the event. |
(let ((x (symbol-name (event-basic-type event)))) |
107 |
(if (listp last-command-event) |
;; Map mouse-wheel events to appropriate buttons |
108 |
(if (fboundp 'event-window) |
(if (string-equal "mouse-wheel" x) |
109 |
(event-window last-command-event) |
(let ((amount (car (cdr (cdr (cdr event)))))) |
110 |
(posn-window (event-start last-command-event))) |
(if (< amount 0) |
111 |
;; If not a mouse event, use the window the mouse is over now. |
mouse-wheel-up-button |
112 |
(let* ((coordinates (mouse-position)) |
mouse-wheel-down-button)) |
113 |
(x (car (cdr coordinates))) |
(if (not (string-match "^mouse-\\([0-9]+\\)" x)) |
114 |
(y (cdr (cdr coordinates)))) |
(error "Not a button event: %S" event) |
115 |
(and (numberp x) |
(string-to-int (substring x (match-beginning 1) (match-end 1))))))) |
116 |
(numberp y) |
(fset 'mwheel-event-button 'event-button)) |
117 |
(window-at x y (car coordinates)))))) |
|
118 |
|
(if (not (fboundp 'event-window)) |
119 |
;; Interpret mouse-wheel-scroll-amount |
(defun mwheel-event-window (event) |
120 |
;; If the scroll-amount is a cons cell instead of a list, |
(posn-window (event-start event))) |
121 |
;; then the car is the normal speed, the cdr is the slow |
(fset 'mwheel-event-window 'event-window)) |
122 |
;; speed, and the fast speed is nil. This is for pre-21.1 |
|
123 |
;; backward compatibility. |
(defun mwheel-scroll (event) |
124 |
(defun mouse-wheel-amount (speed) |
"Scroll up or down according to the EVENT. |
125 |
(cond ((not (consp mouse-wheel-scroll-amount)) |
This should only be bound to mouse buttons 4 and 5." |
126 |
;; illegal value |
(interactive "e") |
127 |
mouse-wheel-scroll-amount) |
(let* ((curwin (if mouse-wheel-follow-mouse |
128 |
((not (consp (cdr mouse-wheel-scroll-amount))) |
(prog1 |
129 |
;; old-style value: a cons |
(selected-window) |
130 |
(cond ((eq speed 'normal) |
(select-window (mwheel-event-window event))))) |
131 |
(car mouse-wheel-scroll-amount)) |
(mods |
132 |
((eq speed 'slow) |
(delq 'click (delq 'double (delq 'triple (event-modifiers event))))) |
133 |
(cdr mouse-wheel-scroll-amount)) |
(amt |
134 |
(t |
(if mods |
135 |
nil))) |
(cdr (assoc mods (cdr mouse-wheel-scroll-amount))) |
136 |
(t |
(car mouse-wheel-scroll-amount)))) |
137 |
(cond ((eq speed 'slow) |
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) |
138 |
(nth 0 mouse-wheel-scroll-amount)) |
(when (and mouse-wheel-progessive-speed (numberp amt)) |
139 |
((eq speed 'normal) |
;; When the double-mouse-N comes in, a mouse-N has been executed already, |
140 |
(nth 1 mouse-wheel-scroll-amount)) |
;; So by adding things up we get a squaring up (1, 3, 6, 10, 16, ...). |
141 |
(t ;fast |
(setq amt (* amt (event-click-count event)))) |
|
(nth 2 mouse-wheel-scroll-amount)))))) |
|
|
|
|
|
(defun mouse-wheel-scroll-internal (direction speed) |
|
|
"Scroll DIRECTION (up or down) SPEED (slow, normal, or fast). |
|
|
`mouse-wheel-scroll-amount' defines the speeds." |
|
|
(let* ((scrollwin (if mouse-wheel-follow-mouse |
|
|
(mouse-wheel-event-window))) |
|
|
(curwin (if scrollwin |
|
|
(selected-window))) |
|
|
(amt (mouse-wheel-amount speed))) |
|
142 |
(unwind-protect |
(unwind-protect |
143 |
(progn |
(let ((button (mwheel-event-button event))) |
144 |
(if scrollwin (select-window scrollwin)) |
(cond ((= button mouse-wheel-down-button) (scroll-down amt)) |
145 |
(if (eq direction 'down) |
((= button mouse-wheel-up-button) (scroll-up amt)) |
146 |
(scroll-down amt) |
(t (error "Bad binding in mwheel-scroll")))) |
|
(scroll-up amt))) |
|
147 |
(if curwin (select-window curwin))))) |
(if curwin (select-window curwin))))) |
148 |
|
|
149 |
|
|
|
(defun mouse-wheel-scroll-up-fast () |
|
|
"Scroll text of current window upward a full screen. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'up 'fast)) |
|
|
|
|
|
(defun mouse-wheel-scroll-down-fast () |
|
|
"Scroll text of current window down a full screen. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'down 'fast)) |
|
|
|
|
|
(defun mouse-wheel-scroll-up-normal () |
|
|
"Scroll text of current window upward a few lines. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'up 'normal)) |
|
|
|
|
|
(defun mouse-wheel-scroll-down-normal () |
|
|
"Scroll text of current window down a few lines. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'down 'normal)) |
|
|
|
|
|
(defun mouse-wheel-scroll-up-slow () |
|
|
"Scroll text of current window upward a line. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'up 'slow)) |
|
|
|
|
|
(defun mouse-wheel-scroll-down-slow () |
|
|
"Scroll text of current window down a line. |
|
|
`mouse-wheel-follow-mouse' controls how the current window is determined. |
|
|
`mouse-wheel-scroll-amount' controls the amount of scroll." |
|
|
(interactive) |
|
|
(mouse-wheel-scroll-internal 'down 'slow)) |
|
|
|
|
|
|
|
|
;;; helper functions for minor mode mouse-wheel-mode. |
|
|
|
|
|
(defun mouse-wheel-button-definer (button-pair down-function up-function) |
|
|
(mouse-wheel-key-definer button-pair 'dn down-function) |
|
|
(mouse-wheel-key-definer button-pair 'up up-function)) |
|
|
|
|
|
(defun mouse-wheel-key-definer (button-pair up-or-dn function) |
|
|
(let ((key (if (featurep 'xemacs) |
|
|
(mouse-wheel-xemacs-key-formatter (car button-pair) up-or-dn) |
|
|
(mouse-wheel-intern-vector (cdr button-pair) up-or-dn)))) |
|
|
(cond (mouse-wheel-mode |
|
|
(define-key global-map key function)) |
|
|
((eq (lookup-key global-map key) 'function) |
|
|
(define-key global-map key nil))))) |
|
|
|
|
|
(defun mouse-wheel-xemacs-key-formatter (key-format-list up-or-dn) |
|
|
(cond ((listp key-format-list) ;e.g., (shift "button%d") |
|
|
(list (car key-format-list) |
|
|
(mouse-wheel-xemacs-intern (car (cdr key-format-list)) up-or-dn))) |
|
|
(t |
|
|
(mouse-wheel-xemacs-intern key-format-list up-or-dn)))) |
|
|
|
|
|
(defun mouse-wheel-xemacs-intern (key-format-string up-or-dn) |
|
|
(intern (format key-format-string |
|
|
(if (eq up-or-dn 'up) |
|
|
mouse-wheel-up-button |
|
|
mouse-wheel-down-button)))) |
|
|
|
|
|
(defun mouse-wheel-intern-vector (key-format-string up-or-dn) |
|
|
"Turns \"mouse-%d\" into [mouse-4]." |
|
|
(vector (intern (format key-format-string |
|
|
(if (eq up-or-dn 'up) |
|
|
mouse-wheel-up-button |
|
|
mouse-wheel-down-button))))) |
|
|
|
|
|
;;; Note this definition must be at the end of the file, because |
|
|
;;; `define-minor-mode' actually calls the mode-function if the |
|
|
;;; associated variable is non-nil, which requires that all needed |
|
|
;;; functions be already defined. |
|
150 |
;;;###autoload |
;;;###autoload |
151 |
(define-minor-mode mouse-wheel-mode |
(define-minor-mode mouse-wheel-mode |
152 |
"Toggle mouse wheel support. |
"Toggle mouse wheel support. |
154 |
Returns non-nil if the new state is enabled." |
Returns non-nil if the new state is enabled." |
155 |
:global t |
:global t |
156 |
:group 'mouse |
:group 'mouse |
157 |
;; This condition-case is here because Emacs 19 will throw an error |
;; In the latest versions of XEmacs, we could just use |
158 |
;; if you try to define a key that it does not know about. I for one |
;; (S-)*mouse-[45], since those are aliases for the button |
159 |
;; prefer to just unconditionally do a mwheel-install in my .emacs, so |
;; equivalents in XEmacs, but I want this to work in as many |
160 |
;; that if the wheeled-mouse is there, it just works, and this way it |
;; versions of XEmacs as it can. |
161 |
;; doesn't yell at me if I'm on my laptop or another machine, etc. |
(let* ((prefix (if (featurep 'xemacs) "button%d" "mouse-%d")) |
162 |
(condition-case () |
(dn (intern (format prefix mouse-wheel-down-button))) |
163 |
(progn |
(up (intern (format prefix mouse-wheel-up-button))) |
164 |
;; In the latest versions of XEmacs, we could just use |
(keys |
165 |
;; (S-)*mouse-[45], since those are aliases for the button |
(nconc (list (vector dn) (vector up)) |
166 |
;; equivalents in XEmacs, but I want this to work in as many |
(mapcar (lambda (amt) `[(,@(car amt) ,up)]) |
167 |
;; versions of XEmacs as it can. |
(cdr mouse-wheel-scroll-amount)) |
168 |
(mouse-wheel-button-definer '("button%d" . "mouse-%d") |
(mapcar (lambda (amt) `[(,@(car amt) ,dn)]) |
169 |
'mouse-wheel-scroll-down-normal 'mouse-wheel-scroll-up-normal) |
(cdr mouse-wheel-scroll-amount))))) |
170 |
(mouse-wheel-button-definer '((shift "button%d") . "S-mouse-%d") |
;; This condition-case is here because Emacs 19 will throw an error |
171 |
'mouse-wheel-scroll-down-slow 'mouse-wheel-scroll-up-slow) |
;; if you try to define a key that it does not know about. I for one |
172 |
(mouse-wheel-button-definer '((control "button%d") . "C-mouse-%d") |
;; prefer to just unconditionally do a mwheel-install in my .emacs, so |
173 |
'mouse-wheel-scroll-down-fast 'mouse-wheel-scroll-up-fast)) |
;; that if the wheeled-mouse is there, it just works, and this way it |
174 |
(error nil))) |
;; doesn't yell at me if I'm on my laptop or another machine, etc. |
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 |
|
|
183 |
;;; Compatibility entry point |
;;; Compatibility entry point |
184 |
;;;###autoload |
;;;###autoload |
186 |
"Enable mouse wheel support." |
"Enable mouse wheel support." |
187 |
(mouse-wheel-mode t)) |
(mouse-wheel-mode t)) |
188 |
|
|
|
|
|
189 |
(provide 'mwheel) |
(provide 'mwheel) |
190 |
|
|
191 |
;;; mwheel.el ends here |
;;; mwheel.el ends here |