;;; mwheel.el --- Wheel mouse support
-;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2011 Free Software Foundation, Inc.
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(require 'custom)
(require 'timer)
+(defvar mouse-wheel-mode)
+
;; Setter function for mouse-button user-options. Switch Mouse Wheel
;; mode off and on again so that the old button is unbound and
;; new button is bound to mwheel-scroll.
(defun mouse-wheel-change-button (var button)
- (let ((active mouse-wheel-mode))
- ;; Deactivate before changing the setting.
- (when active (mouse-wheel-mode -1))
- (set-default var button)
- (when active (mouse-wheel-mode 1))))
+ (set-default var button)
+ ;; Sync the bindings.
+ (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
(defvar mouse-wheel-down-button 4)
(make-obsolete-variable 'mouse-wheel-down-button
- 'mouse-wheel-down-event)
+ 'mouse-wheel-down-event
+ "22.1")
(defcustom mouse-wheel-down-event
- ;; In the latest versions of XEmacs, we could just use mouse-%s as well.
- (if (memq window-system '(w32 mac))
+ (if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-up
- (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s")
- mouse-wheel-down-button)))
+ (intern (format "mouse-%s" mouse-wheel-down-button)))
"Event used for scrolling down."
:group 'mouse
:type 'symbol
(defvar mouse-wheel-up-button 5)
(make-obsolete-variable 'mouse-wheel-up-button
- 'mouse-wheel-up-event)
+ 'mouse-wheel-up-event
+ "22.1")
(defcustom mouse-wheel-up-event
- ;; In the latest versions of XEmacs, we could just use mouse-%s as well.
- (if (memq window-system '(w32 mac))
+ (if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-down
- (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s")
- mouse-wheel-up-button)))
- "Event used for scrolling down."
+ (intern (format "mouse-%s" mouse-wheel-up-button)))
+ "Event used for scrolling up."
:group 'mouse
:type 'symbol
:set 'mouse-wheel-change-button)
(defvar mouse-wheel-click-button 2)
(make-obsolete-variable 'mouse-wheel-click-button
- 'mouse-wheel-click-event)
+ 'mouse-wheel-click-event
+ "22.1")
(defcustom mouse-wheel-click-event
- ;; In the latest versions of XEmacs, we could just use mouse-%s as well.
- (intern (format (if (featurep 'xemacs) "button%s" "mouse-%s")
- mouse-wheel-click-button))
+ (intern (format "mouse-%s" mouse-wheel-click-button))
"Event that should be temporarily inhibited after mouse scrolling.
The mouse wheel is typically on the mouse-2 button, so it may easily
-happen that text is accidentially yanked into the buffer when
+happen that text is accidentally yanked into the buffer when
scrolling with the mouse wheel. To prevent that, this variable can be
set to the event sent when clicking on the mouse wheel button."
:group 'mouse
(choice :tag "scroll amount"
(const :tag "Full screen" :value nil)
(integer :tag "Specific # of lines")
- (float :tag "Fraction of window"))))))
+ (float :tag "Fraction of window")))))
+ :set 'mouse-wheel-change-button)
(defcustom mouse-wheel-progressive-speed t
"If non-nil, the faster the user moves the wheel, the faster the scrolling.
:group 'mouse
:type 'boolean)
-(if (not (fboundp 'event-button))
+(eval-and-compile
+ (if (fboundp 'event-button)
+ (fset 'mwheel-event-button 'event-button)
(defun mwheel-event-button (event)
(let ((x (event-basic-type event)))
;; Map mouse-wheel events to appropriate buttons
(if (< amount 0)
mouse-wheel-up-event
mouse-wheel-down-event))
- x)))
- (fset 'mwheel-event-button 'event-button))
+ x))))
-(if (not (fboundp 'event-window))
+ (if (fboundp 'event-window)
+ (fset 'mwheel-event-window 'event-window)
(defun mwheel-event-window (event)
- (posn-window (event-start event)))
- (fset 'mwheel-event-window 'event-window))
+ (posn-window (event-start event)))))
(defvar mwheel-inhibit-click-event-timer nil
"Timer running while mouse wheel click event is inhibited.")
(if (eq (event-basic-type last-input-event) mouse-wheel-click-event)
(setq this-command 'ignore)))
+(defvar mwheel-scroll-up-function 'scroll-up
+ "Function that does the job of scrolling upward.")
+
+(defvar mwheel-scroll-down-function 'scroll-down
+ "Function that does the job of scrolling downward.")
+
(defun mwheel-scroll (event)
"Scroll up or down according to the EVENT.
This should only be bound to mouse buttons 4 and 5."
(prog1
(selected-window)
(select-window (mwheel-event-window event)))))
+ (buffer (window-buffer curwin))
+ (opoint (with-current-buffer buffer
+ (when (eq (car-safe transient-mark-mode) 'only)
+ (point))))
(mods
(delq 'click (delq 'double (delq 'triple (event-modifiers event)))))
(amt (assoc mods mouse-wheel-scroll-amount)))
(setq amt (* amt (event-click-count event))))
(unwind-protect
(let ((button (mwheel-event-button event)))
- (cond ((eq button mouse-wheel-down-event) (scroll-down amt))
- ((eq button mouse-wheel-up-event) (scroll-up amt))
+ (cond ((eq button mouse-wheel-down-event)
+ (condition-case nil (funcall mwheel-scroll-down-function amt)
+ ;; Make sure we do indeed scroll to the beginning of
+ ;; the buffer.
+ (beginning-of-buffer
+ (unwind-protect
+ (funcall mwheel-scroll-down-function)
+ ;; If the first scroll succeeded, then some scrolling
+ ;; is possible: keep scrolling til the beginning but
+ ;; do not signal an error. For some reason, we have
+ ;; to do it even if the first scroll signaled an
+ ;; error, because otherwise the window is recentered
+ ;; for a reason that escapes me. This problem seems
+ ;; to only affect scroll-down. --Stef
+ (set-window-start (selected-window) (point-min))))))
+ ((eq button mouse-wheel-up-event)
+ (condition-case nil (funcall mwheel-scroll-up-function amt)
+ ;; Make sure we do indeed scroll to the end of the buffer.
+ (end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
(t (error "Bad binding in mwheel-scroll"))))
- (if curwin (select-window curwin))))
+ (if curwin (select-window curwin)))
+ ;; If there is a temporarily active region, deactivate it iff
+ ;; scrolling moves point.
+ (when opoint
+ (with-current-buffer buffer
+ (when (/= opoint (point))
+ (deactivate-mark)))))
(when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time)
(if mwheel-inhibit-click-event-timer
(cancel-timer mwheel-inhibit-click-event-timer)
(run-with-timer mouse-wheel-inhibit-click-time nil
'mwheel-inhibit-click-timeout))))
-;;;###autoload
+(put 'mwheel-scroll 'scroll-command t)
+
+(defvar mwheel-installed-bindings nil)
+
+;; preloaded ;;;###autoload
(define-minor-mode mouse-wheel-mode
"Toggle mouse wheel support.
With prefix argument ARG, turn on if positive, otherwise off.
-Returns non-nil if the new state is enabled."
+Return non-nil if the new state is enabled."
+ :init-value t
+ ;; We'd like to use custom-initialize-set here so the setup is done
+ ;; before dumping, but at the point where the defcustom is evaluated,
+ ;; the corresponding function isn't defined yet, so
+ ;; custom-initialize-set signals an error.
+ :initialize 'custom-initialize-delay
:global t
:group 'mouse
- (let* ((dn mouse-wheel-down-event)
- (up mouse-wheel-up-event)
- (keys
- (nconc (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,up)])
- mouse-wheel-scroll-amount)
- (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,dn)])
- mouse-wheel-scroll-amount))))
- ;; This condition-case is here because Emacs 19 will throw an error
- ;; if you try to define a key that it does not know about. I for one
- ;; prefer to just unconditionally do a mwheel-install in my .emacs, so
- ;; that if the wheeled-mouse is there, it just works, and this way it
- ;; doesn't yell at me if I'm on my laptop or another machine, etc.
- (condition-case ()
- (dolist (key keys)
- (cond (mouse-wheel-mode
- (global-set-key key 'mwheel-scroll))
- ((eq (lookup-key (current-global-map) key) 'mwheel-scroll)
- (global-unset-key key))))
- (error nil))))
+ ;; Remove previous bindings, if any.
+ (while mwheel-installed-bindings
+ (let ((key (pop mwheel-installed-bindings)))
+ (when (eq (lookup-key (current-global-map) key) 'mwheel-scroll)
+ (global-unset-key key))))
+ ;; Setup bindings as needed.
+ (when mouse-wheel-mode
+ (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
+ (dolist (key (mapcar (lambda (amt) `[(,@(if (consp amt) (car amt)) ,event)])
+ mouse-wheel-scroll-amount))
+ (global-set-key key 'mwheel-scroll)
+ (push key mwheel-installed-bindings)))))
;;; Compatibility entry point
-;;;###autoload
+;; preloaded ;;;###autoload
(defun mwheel-install (&optional uninstall)
"Enable mouse wheel support."
(mouse-wheel-mode (if uninstall -1 1)))
(provide 'mwheel)
-;; arch-tag: 50ed00e7-3686-4b7a-8037-fb31aa5c237f
;;; mwheel.el ends here
HCoop / bpt / emacs.git / blobdiff