Commit | Line | Data |
---|---|---|
a32b7419 WP |
1 | ;;; mwheel.el --- Mouse support for MS intelli-mouse type mice |
2 | ||
3 | ;; Copyright (C) 1998, Free Software Foundation, Inc. | |
4 | ;; Maintainer: William M. Perry <wmperry@gnu.org> | |
5 | ;; Keywords: mouse | |
6 | ||
7 | ;; This file is part of Emacs. | |
8 | ||
9 | ;; XEmacs is free software; you can redistribute it and/or modify it | |
10 | ;; under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; XEmacs is distributed in the hope that it will be useful, but | |
15 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
17 | ;; General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with XEmacs; see the file COPYING. If not, write to the | |
21 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 | ;; Boston, MA 02111-1307, USA. | |
23 | ||
24 | ;;; Synched up with: Not synched. | |
25 | ||
26 | ;;; Commentary: | |
27 | ||
28 | ;; This code will enable the use of the infamous 'wheel' on the new | |
29 | ;; crop of mice. Under XFree86 and the XSuSE X Servers, the wheel | |
30 | ;; events are sent as button4/button5 events. | |
31 | ||
32 | ;; I for one would prefer some way of converting the button4/button5 | |
33 | ;; events into different event types, like 'mwheel-up' or | |
34 | ;; 'mwheel-down', but I cannot find a way to do this very easily (or | |
35 | ;; portably), so for now I just live with it. | |
36 | ||
37 | ;; To enable this code, simply put this at the top of your .emacs | |
38 | ;; file: | |
39 | ;; | |
40 | ;; (autoload 'mwheel-install "mwheel" "Enable mouse wheel support.") | |
41 | ;; (mwheel-install) | |
42 | ||
43 | ;;; Code: | |
44 | ||
45 | (require 'custom) | |
46 | (require 'cl) | |
47 | ||
48 | (defcustom mwheel-scroll-amount '(5 . 1) | |
49 | "Amount to scroll windows by when spinning the mouse wheel. | |
50 | This is actually a cons cell, where the first item is the amount to scroll | |
51 | on a normal wheel event, and the second is the amount to scroll when the | |
52 | wheel is moved with the shift key depressed. | |
53 | ||
54 | Each item should be the number of lines to scroll, or `nil' for near | |
55 | full screen. | |
56 | A near full screen is `next-screen-context-lines' less than a full screen." | |
57 | :group 'mouse | |
58 | :type '(cons | |
59 | (choice :tag "Normal" | |
60 | (const :tag "Full screen" :value nil) | |
61 | (integer :tag "Specific # of lines")) | |
62 | (choice :tag "Shifted" | |
63 | (const :tag "Full screen" :value nil) | |
64 | (integer :tag "Specific # of lines")))) | |
65 | ||
66 | (defcustom mwheel-follow-mouse nil | |
67 | "Whether the mouse wheel should scroll the window that the mouse is over. | |
68 | This can be slightly disconcerting, but some people may prefer it." | |
69 | :group 'mouse | |
70 | :type 'boolean) | |
71 | ||
72 | (if (not (fboundp 'event-button)) | |
73 | (defun mwheel-event-button (event) | |
74 | (let ((x (symbol-name (event-basic-type event)))) | |
75 | (if (not (string-match "^mouse-\\([0-9]+\\)" x)) | |
76 | (error "Not a button event: %S" event)) | |
77 | (string-to-int (substring x (match-beginning 1) (match-end 1))))) | |
78 | (fset 'mwheel-event-button 'event-button)) | |
79 | ||
80 | (if (not (fboundp 'event-window)) | |
81 | (defun mwheel-event-window (event) | |
82 | (posn-window (event-start event))) | |
83 | (fset 'mwheel-event-window 'event-window)) | |
84 | ||
85 | (defun mwheel-scroll (event) | |
86 | (interactive "e") | |
87 | (let ((curwin (if mwheel-follow-mouse | |
88 | (prog1 | |
89 | (selected-window) | |
90 | (select-window (mwheel-event-window event))))) | |
91 | (amt (if (memq 'shift (event-modifiers event)) | |
92 | (cdr mwheel-scroll-amount) | |
93 | (car mwheel-scroll-amount)))) | |
94 | (unwind-protect | |
95 | (case (mwheel-event-button event) | |
96 | (4 (scroll-down amt)) | |
97 | (5 (scroll-up amt)) | |
98 | (otherwise (error "Bad binding in mwheel-scroll"))) | |
99 | (if curwin (select-window curwin))))) | |
100 | ||
101 | ;;;###autoload | |
102 | (defun mwheel-install () | |
103 | "Enable mouse wheel support." | |
104 | ;; In the latest versions of XEmacs, we could just use | |
105 | ;; (S-)*mouse-[45], since those are aliases for the button | |
106 | ;; equivalents in XEmacs, but I want this to work in as many | |
107 | ;; versions of XEmacs as it can. | |
108 | (let* ((mwheel-running-xemacs (string-match "XEmacs" (emacs-version))) | |
109 | (keys (if mwheel-running-xemacs | |
110 | '(button4 [(shift button4)] button5 [(shift button5)]) | |
111 | '([mouse-4] [S-mouse-4] [mouse-5] [S-mouse-5])))) | |
112 | ;; This condition-case is here because Emacs 19 will throw an error | |
113 | ;; if you try to define a key that it does not know about. I for one | |
114 | ;; prefer to just unconditionally do a mwheel-install in my .emacs, so | |
115 | ;; that if the wheeled-mouse is there, it just works, and this way it | |
116 | ;; doesn't yell at me if I'm on my laptop or another machine, etc. | |
117 | (condition-case () | |
118 | (while keys | |
119 | (define-key global-map (car keys) 'mwheel-scroll) | |
120 | (setq keys (cdr keys))) | |
121 | (error nil)))) | |
122 | ||
123 | (provide 'mwheel) | |
124 | ||
125 | ;;; mwheel.el ends here |