X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/44d5226a2cedb7e585fd6ab5290902c69154238a..b336bfcdf39f1e4d35bff4a7bd01d3b4bca8f516:/lisp/mwheel.el diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 7996554a9e..c505833502 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -1,16 +1,16 @@ ;;; mwheel.el --- Wheel mouse support -;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Maintainer: William M. Perry ;; Keywords: mouse ;; 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 @@ -18,9 +18,7 @@ ;; 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 . ;;; Commentary: @@ -43,26 +41,25 @@ (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 @@ -70,13 +67,12 @@ (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))) + (intern (format "mouse-%s" mouse-wheel-up-button))) "Event used for scrolling up." :group 'mouse :type 'symbol @@ -84,11 +80,10 @@ (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 accidentally yanked into the buffer when @@ -136,7 +131,8 @@ less than a full screen." (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. @@ -152,7 +148,9 @@ This can be slightly disconcerting, but some people prefer it." :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 @@ -161,13 +159,12 @@ This can be slightly disconcerting, but some people prefer it." (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.") @@ -182,6 +179,12 @@ This can be slightly disconcerting, but some people prefer it." (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." @@ -190,6 +193,10 @@ 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))) @@ -205,26 +212,32 @@ This should only be bound to mouse buttons 4 and 5." (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 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) @@ -233,35 +246,36 @@ This should only be bound to mouse buttons 4 and 5." (run-with-timer mouse-wheel-inhibit-click-time nil 'mwheel-inhibit-click-timeout)))) -;;;###autoload +(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. 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)))