(require 'custom)
(defun mouse-wheel-change-button (var button)
(set-default var button)
(when mouse-wheel-mode
(mouse-wheel-mode 0)
(mouse-wheel-mode 1)))
(defcustom mouse-wheel-down-button 4
"Mouse button number for scrolling down."
:group 'mouse
:type 'integer
:set 'mouse-wheel-change-button)
(defcustom mouse-wheel-up-button 5
"Mouse button number for scrolling up."
:group 'mouse
:type 'integer
:set 'mouse-wheel-change-button)
(defcustom mouse-wheel-scroll-amount '(5 . 1)
"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 second is the amount to scroll when the
wheel is moved with the shift key depressed.
Each item should be the number of lines to scroll, or `nil' for near
full screen.
A near full screen is `next-screen-context-lines' less than a full screen."
:group 'mouse
:type '(cons
(choice :tag "Normal"
(const :tag "Full screen" :value nil)
(integer :tag "Specific # of lines"))
(choice :tag "Shifted"
(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.
This can be slightly disconcerting, but some people may prefer it."
:group 'mouse
:type 'boolean)
(if (not (fboundp 'event-button))
(defun mwheel-event-button (event)
(let ((x (symbol-name (event-basic-type event))))
(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 mwheel-scroll (event)
(interactive "e")
(let ((curwin (if mouse-wheel-follow-mouse
(prog1
(selected-window)
(select-window (mwheel-event-window event)))))
(amt (if (memq 'shift (event-modifiers event))
(cdr mouse-wheel-scroll-amount)
(car mouse-wheel-scroll-amount))))
(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"))))
(if curwin (select-window curwin)))))
(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."
:global t
:group 'mouse
(let ((keys
(if (featurep 'xemacs)
(let ((down (intern (format "button%d" mouse-wheel-down-button)))
(up (intern (format "button%d" mouse-wheel-up-button))))
`(,down [(shift ,down)] ,up [(shift ,up)]))
(let ((down (intern (format "mouse-%d" mouse-wheel-down-button)))
(s-down (intern (format "S-mouse-%d" mouse-wheel-down-button)))
(up (intern (format "mouse-%d" mouse-wheel-up-button)))
(s-up (intern (format "S-mouse-%d" mouse-wheel-up-button))))
`([,down] [,s-down] [,up] [,s-up])))))
(condition-case ()
(dolist (key keys)
(cond (mouse-wheel-mode
(define-key global-map key 'mwheel-scroll))
((eq (lookup-key global-map key) 'mwheel-scroll)
(define-key global-map key nil))))
(error nil))))
(defun mwheel-install (&optional uninstall)
"Enable mouse wheel support."
(mouse-wheel-mode t))
(provide 'mwheel)