;;; mwheel.el --- Wheel mouse support
-;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2000-2016 Free Software Foundation, Inc.
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
(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
"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
'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)))
+ (intern (format "mouse-%s" mouse-wheel-up-button)))
"Event used for scrolling up."
:group 'mouse
:type 'symbol
'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 accidentally yanked into the buffer when
(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."
+This should be bound only to mouse buttons 4 and 5 on non-Windows
+systems."
(interactive (list last-input-event))
(let* ((curwin (if mouse-wheel-follow-mouse
(prog1
(unwind-protect
(let ((button (mwheel-event-button event)))
(cond ((eq button mouse-wheel-down-event)
- (condition-case nil (scroll-down amt)
+ (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
- (scroll-down)
+ (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 signalled an
+ ;; 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 (scroll-up amt)
+ (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 (scroll-up)))))
+ (end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
(t (error "Bad binding in mwheel-scroll"))))
(if curwin (select-window curwin)))
- ;; If there is a temporarily active region, deactivate it iff
+ ;; If there is a temporarily active region, deactivate it if
;; scrolling moves point.
(when opoint
(with-current-buffer buffer
(when (/= opoint (point))
- (deactivate-mark)))))
+ ;; Call `deactivate-mark' at the original position, so that
+ ;; the original region is saved to the X selection.
+ (let ((newpoint (point)))
+ (goto-char opoint)
+ (deactivate-mark)
+ (goto-char newpoint))))))
(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)
+
(define-minor-mode mouse-wheel-mode
- "Toggle mouse wheel support.
-With prefix argument ARG, turn on if positive, otherwise off.
-Return non-nil if the new state is enabled."
+ "Toggle mouse wheel support (Mouse Wheel mode).
+With a prefix argument ARG, enable Mouse Wheel mode if ARG is
+positive, and disable it otherwise. If called from Lisp, enable
+the mode if ARG is omitted or nil."
+ :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