/[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.14 by rms, Fri Jun 21 12:30:47 2002 UTC revision 1.15 by monnier, Mon Jun 24 15:50:38 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 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 63  Line 63 
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.
# Line 91  This can be slightly disconcerting, but Line 101  This can be slightly disconcerting, but
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.
# Line 237  With prefix argument ARG, turn on if pos Line 154  With prefix argument ARG, turn on if pos
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
# Line 262  Returns non-nil if the new state is enab Line 186  Returns non-nil if the new state is enab
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

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

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