/[emacs]/emacs/lisp/mwheel.el
ViewVC logotype

Diff of /emacs/lisp/mwheel.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by jasonr, Sat May 4 22:16:04 2002 UTC revision 1.13.2.1 by miles, Fri Apr 4 06:20:10 2003 UTC
# Line 1  Line 1 
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    
# Line 40  Line 40 
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)
# Line 91  A near full screen is `next-screen-conte Line 136  A near full screen is `next-screen-conte
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
# Line 154  With prefix argument ARG, turn on if pos Line 218  With prefix argument ARG, turn on if pos
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
# Line 184  Returns non-nil if the new state is enab Line 242  Returns non-nil if the new state is enab
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    

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.13.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26