# HG changeset patch # User Richard M. Stallman # Date 1024662647 0 # Node ID d8512fb0b229e6209c69bb10bcaf70bc589d0d01 # Parent c5474d1cf831558bc53815f4436e71998042c945 Allow arbitrary keys for scrolling, add a third scrolling speed, fix an unwind-protect. (mouse-wheel-scroll-amount): Now a three-element list. (mouse-wheel-scroll-down-slow, mouse-wheel-scroll-up-slow) (mouse-wheel-scroll-down-normal, mouse-wheel-scroll-up-normal) (mouse-wheel-scroll-down-fast, mouse-wheel-scroll-up-fast): New functions. diff -r c5474d1cf831 -r d8512fb0b229 lisp/mwheel.el --- a/lisp/mwheel.el Fri Jun 21 12:05:52 2002 +0000 +++ b/lisp/mwheel.el Fri Jun 21 12:30:47 2002 +0000 @@ -1,6 +1,6 @@ ;;; mwheel.el --- Mouse support for MS intelli-mouse type mice -;; Copyright (C) 1998, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1998, 2000, 2001, Free Software Foundation, Inc. ;; Maintainer: William M. Perry ;; Keywords: mouse @@ -63,37 +63,27 @@ :type 'integer :set 'mouse-wheel-change-button) -(defcustom mouse-wheel-scroll-amount '(5 ((shift) . 1) ((control) . nil)) +(defcustom mouse-wheel-scroll-amount '(1 5 nil) "Amount to scroll windows by when spinning the mouse wheel. -This is actually a cons cell, where the first item is the amount to scroll -on a normal wheel event, and the rest is an alist mapping the modifier key -to the amount to scroll when the wheel is moved with the modifier key depressed. +This is actually a list, where the first element is the amount to +scroll slowly (normally invoked with the Shift key depressed) the +second is the amount to scroll on a normal wheel event, and the third +is the amount to scroll fast (normally with the Control key depressed). Each item should be the number of lines to scroll, or `nil' for near -full screen. It can also be a floating point number, specifying -the fraction of the window to scroll. +full screen. A near full screen is `next-screen-context-lines' less than a full screen." :group 'mouse - :type '(cons - (choice :tag "Normal" + :type '(list + (choice :tag "Slow (Shift key)" (const :tag "Full screen" :value nil) - (integer :tag "Specific # of lines") - (float :tag "Fraction of window")) - (repeat - (cons - (repeat (choice :tag "modifier" (const alt) (const control) (const hyper) - (const meta) (const shift) (const super))) - (choice :tag "scroll amount" - (const :tag "Full screen" :value nil) - (integer :tag "Specific # of lines") - (float :tag "Fraction of window")))))) - -(defcustom mouse-wheel-progessive-speed t - "If non-nil, the faster the user moves the wheel, the faster the scrolling. -Note that this has no effect when `mouse-wheel-scroll-amount' specifies -a \"near full screen\" scroll." - :group 'mouse - :type 'boolean) + (integer :tag "Specific # of lines")) + (choice :tag "Normal (no keys)" + (const :tag "Full screen" :value nil) + (integer :tag "Specific # of lines")) + (choice :tag "Fast (Ctrl key)" + (const :tag "Full screen" :value nil) + (integer :tag "Specific # of lines")))) (defcustom mouse-wheel-follow-mouse nil "Whether the mouse wheel should scroll the window that the mouse is over. @@ -101,52 +91,145 @@ :group 'mouse :type 'boolean) -(if (not (fboundp 'event-button)) - (defun mwheel-event-button (event) - (let ((x (symbol-name (event-basic-type event)))) - ;; Map mouse-wheel events to appropriate buttons - (if (string-equal "mouse-wheel" x) - (let ((amount (car (cdr (cdr (cdr event)))))) - (if (< amount 0) - mouse-wheel-up-button - mouse-wheel-down-button)) - (if (not (string-match "^mouse-\\([0-9]+\\)" x)) - (error "Not a button event: %S" event) - (string-to-int (substring x (match-beginning 1) (match-end 1))))))) - (fset 'mwheel-event-button 'event-button)) - -(if (not (fboundp 'event-window)) - (defun mwheel-event-window (event) - (posn-window (event-start event))) - (fset 'mwheel-event-window 'event-window)) +(defun mouse-wheel-event-window () + "Return the window associated with this mouse command." + ;; If the command was a mouse event, the window is stored in the event. + (if (listp last-command-event) + (if (fboundp 'event-window) + (event-window last-command-event) + (posn-window (event-start last-command-event))) + ;; If not a mouse event, use the window the mouse is over now. + (let* ((coordinates (mouse-position)) + (x (car (cdr coordinates))) + (y (cdr (cdr coordinates)))) + (and (numberp x) + (numberp y) + (window-at x y (car coordinates)))))) -(defun mwheel-scroll (event) - "Scroll up or down according to the EVENT. -This should only be bound to mouse buttons 4 and 5." - (interactive "e") - (let* ((curwin (if mouse-wheel-follow-mouse - (prog1 - (selected-window) - (select-window (mwheel-event-window event))))) - (mods - (delq 'click (delq 'double (delq 'triple (event-modifiers event))))) - (amt - (if mods - (cdr (assoc mods (cdr mouse-wheel-scroll-amount))) - (car mouse-wheel-scroll-amount)))) - (if (floatp amt) (setq amt (1+ (truncate (* amt (window-height)))))) - (when (and mouse-wheel-progessive-speed (numberp amt)) - ;; When the double-mouse-N comes in, a mouse-N has been executed already, - ;; So by adding things up we get a squaring up (1, 3, 6, 10, 16, ...). - (setq amt (* amt (event-click-count event)))) +;; Interpret mouse-wheel-scroll-amount +;; If the scroll-amount is a cons cell instead of a list, +;; then the car is the normal speed, the cdr is the slow +;; speed, and the fast speed is nil. This is for pre-21.1 +;; backward compatibility. +(defun mouse-wheel-amount (speed) + (cond ((not (consp mouse-wheel-scroll-amount)) + ;; illegal value + mouse-wheel-scroll-amount) + ((not (consp (cdr mouse-wheel-scroll-amount))) + ;; old-style value: a cons + (cond ((eq speed 'normal) + (car mouse-wheel-scroll-amount)) + ((eq speed 'slow) + (cdr mouse-wheel-scroll-amount)) + (t + nil))) + (t + (cond ((eq speed 'slow) + (nth 0 mouse-wheel-scroll-amount)) + ((eq speed 'normal) + (nth 1 mouse-wheel-scroll-amount)) + (t ;fast + (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))) (unwind-protect - (let ((button (mwheel-event-button event))) - (cond ((= button mouse-wheel-down-button) (scroll-down amt)) - ((= button mouse-wheel-up-button) (scroll-up amt)) - (t (error "Bad binding in mwheel-scroll")))) + (progn + (if scrollwin (select-window scrollwin)) + (if (eq direction 'down) + (scroll-down amt) + (scroll-up amt))) (if curwin (select-window curwin))))) +(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. ;;;###autoload (define-minor-mode mouse-wheel-mode "Toggle mouse wheel support. @@ -154,31 +237,24 @@ Returns non-nil if the new state is enabled." :global t :group 'mouse - ;; In the latest versions of XEmacs, we could just use - ;; (S-)*mouse-[45], since those are aliases for the button - ;; equivalents in XEmacs, but I want this to work in as many - ;; versions of XEmacs as it can. - (let* ((prefix (if (featurep 'xemacs) "button%d" "mouse-%d")) - (dn (intern (format prefix mouse-wheel-down-button))) - (up (intern (format prefix mouse-wheel-up-button))) - (keys - (nconc (list (vector dn) (vector up)) - (mapcar (lambda (amt) `[(,@(car amt) ,up)]) - (cdr mouse-wheel-scroll-amount)) - (mapcar (lambda (amt) `[(,@(car amt) ,dn)]) - (cdr 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)))) + ;; 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 () + (progn + ;; In the latest versions of XEmacs, we could just use + ;; (S-)*mouse-[45], since those are aliases for the button + ;; equivalents in XEmacs, but I want this to work in as many + ;; versions of XEmacs as it can. + (mouse-wheel-button-definer '("button%d" . "mouse-%d") + 'mouse-wheel-scroll-down-normal 'mouse-wheel-scroll-up-normal) + (mouse-wheel-button-definer '((shift "button%d") . "S-mouse-%d") + 'mouse-wheel-scroll-down-slow 'mouse-wheel-scroll-up-slow) + (mouse-wheel-button-definer '((control "button%d") . "C-mouse-%d") + 'mouse-wheel-scroll-down-fast 'mouse-wheel-scroll-up-fast)) + (error nil))) ;;; Compatibility entry point ;;;###autoload @@ -186,6 +262,7 @@ "Enable mouse wheel support." (mouse-wheel-mode t)) + (provide 'mwheel) ;;; mwheel.el ends here