/[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.16 by monnier, Mon Jun 24 23:59:22 2002 UTC revision 1.17 by monnier, Thu Jun 27 21:45:42 2002 UTC
# Line 1  Line 1 
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    
# Line 46  Line 46 
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))
# Line 106  of button events." Line 117  of button events."
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
# Line 114  This can be slightly disconcerting, but Line 125  This can be slightly disconcerting, but
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))
# Line 134  This can be slightly disconcerting, but Line 143  This can be slightly disconcerting, but
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)
# Line 149  This should only be bound to mouse butto Line 158  This should only be bound to mouse butto
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    
# Line 166  With prefix argument ARG, turn on if pos Line 175  With prefix argument ARG, turn on if pos
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)
# Line 195  Returns non-nil if the new state is enab Line 199  Returns non-nil if the new state is enab
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    

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

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