lisp/scroll-bar.el

   1 ;;; scroll-bar.el --- window system-independent scroll bar support
   2
   3 ;; Copyright (C) 1993-1995, 1999-2014 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: emacs-devel@gnu.org
   6 ;; Keywords: hardware
   7 ;; Package: emacs
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Window-system-independent bindings of mouse clicks on the scroll bar.
  27 ;; Presently emulates the scroll-bar behavior of xterm.
  28
  29 ;;; Code:
  30
  31 (require 'mouse)
  32 (eval-when-compile (require 'cl-lib))
  33
  34 \f
  35 ;;;; Utilities.
  36
  37 (defun scroll-bar-event-ratio (event)
  38   "Given a scroll bar event EVENT, return the scroll bar position as a ratio.
  39 The value is a cons cell (PORTION . WHOLE) containing two integers
  40 whose ratio gives the event's vertical position in the scroll bar, with 0
  41 referring to the top and 1 to the bottom."
  42   (nth 2 event))
  43
  44 (defun scroll-bar-scale (num-denom whole)
  45   "Given a pair (NUM . DENOM) and WHOLE, return (/ (* NUM WHOLE) DENOM).
  46 This is handy for scaling a position on a scroll bar into real units,
  47 like buffer positions.  If SCROLL-BAR-POS is the (PORTION . WHOLE) pair
  48 from a scroll bar event, then (scroll-bar-scale SCROLL-BAR-POS
  49 \(buffer-size)) is the position in the current buffer corresponding to
  50 that scroll bar position."
  51   ;; We multiply before we divide to maintain precision.
  52   ;; We use floating point because the product of a large buffer size
  53   ;; with a large scroll bar portion can easily overflow a lisp int.
  54   (truncate (/ (* (float (car num-denom)) whole) (cdr num-denom))))
  55
  56 (defun scroll-bar-columns (side)
  57   "Return the width, measured in columns, of the vertical scrollbar on SIDE.
  58 SIDE must be the symbol `left' or `right'."
  59   (let* ((wsb   (window-scroll-bars))
  60          (vtype (nth 2 wsb))
  61          (cols  (nth 1 wsb)))
  62     (cond
  63      ((not (memq side '(left right)))
  64       (error "`left' or `right' expected instead of %S" side))
  65      ((and (eq vtype side) cols))
  66      ((eq (frame-parameter nil 'vertical-scroll-bars) side)
  67       ;; nil means it's a non-toolkit scroll bar, and its width in
  68       ;; columns is 14 pixels rounded up.
  69       (ceiling (or (frame-parameter nil 'scroll-bar-width) 14)
  70                (frame-char-width)))
  71      (0))))
  72
  73 \f
  74 ;;;; Helpful functions for enabling and disabling scroll bars.
  75
  76 (defvar scroll-bar-mode)
  77 (defvar previous-scroll-bar-mode nil)
  78
  79 (defvar scroll-bar-mode-explicit nil
  80   "Non-nil means `set-scroll-bar-mode' should really do something.
  81 This is nil while loading `scroll-bar.el', and t afterward.")
  82
  83 (defun set-scroll-bar-mode (value)
  84   "Set the scroll bar mode to VALUE and put the new value into effect.
  85 See the `scroll-bar-mode' variable for possible values to use."
  86   (if scroll-bar-mode
  87       (setq previous-scroll-bar-mode scroll-bar-mode))
  88
  89   (setq scroll-bar-mode value)
  90
  91   (when scroll-bar-mode-explicit
  92     (modify-all-frames-parameters (list (cons 'vertical-scroll-bars
  93                                               scroll-bar-mode)))))
  94
  95 (defcustom scroll-bar-mode default-frame-scroll-bars
  96   "Specify whether to have vertical scroll bars, and on which side.
  97 Possible values are nil (no scroll bars), `left' (scroll bars on left)
  98 and `right' (scroll bars on right).
  99 To set this variable in a Lisp program, use `set-scroll-bar-mode'
 100 to make it take real effect.
 101 Setting the variable with a customization buffer also takes effect."
 102   :type '(choice (const :tag "none (nil)" nil)
 103                  (const left)
 104                  (const right))
 105   :group 'frames
 106   ;; The default value for :initialize would try to use :set
 107   ;; when processing the file in cus-dep.el.
 108   :initialize 'custom-initialize-default
 109   :set (lambda (_sym val) (set-scroll-bar-mode val)))
 110
 111 ;; We just set scroll-bar-mode, but that was the default.
 112 ;; If it is set again, that is for real.
 113 (setq scroll-bar-mode-explicit t)
 114
 115 (defun get-scroll-bar-mode ()
 116   (declare (gv-setter set-scroll-bar-mode))
 117   scroll-bar-mode)
 118
 119 (define-minor-mode scroll-bar-mode
 120   "Toggle vertical scroll bars on all frames (Scroll Bar mode).
 121 With a prefix argument ARG, enable Scroll Bar mode if ARG is
 122 positive, and disable it otherwise.  If called from Lisp, enable
 123 the mode if ARG is omitted or nil.
 124
 125 This command applies to all frames that exist and frames to be
 126 created in the future."
 127   :variable ((get-scroll-bar-mode)
 128              . (lambda (v) (set-scroll-bar-mode
 129                        (if v (or previous-scroll-bar-mode
 130                                  default-frame-scroll-bars))))))
 131
 132 (defun toggle-scroll-bar (arg)
 133   "Toggle whether or not the selected frame has vertical scroll bars.
 134 With arg, turn vertical scroll bars on if and only if arg is positive.
 135 The variable `scroll-bar-mode' controls which side the scroll bars are on
 136 when they are turned on; if it is nil, they go on the left."
 137   (interactive "P")
 138   (if (null arg)
 139       (setq arg
 140             (if (cdr (assq 'vertical-scroll-bars
 141                            (frame-parameters (selected-frame))))
 142                 -1 1))
 143     (setq arg (prefix-numeric-value arg)))
 144   (modify-frame-parameters
 145    (selected-frame)
 146    (list (cons 'vertical-scroll-bars
 147                (if (> arg 0)
 148                    (or scroll-bar-mode default-frame-scroll-bars))))))
 149
 150 (defun toggle-horizontal-scroll-bar (_arg)
 151   "Toggle whether or not the selected frame has horizontal scroll bars.
 152 With arg, turn horizontal scroll bars on if and only if arg is positive.
 153 Horizontal scroll bars aren't implemented yet."
 154   (interactive "P")
 155   (error "Horizontal scroll bars aren't implemented yet"))
 156 \f
 157 ;;;; Buffer navigation using the scroll bar.
 158
 159 ;; This was used for up-events on button 2, but no longer.
 160 (defun scroll-bar-set-window-start (event)
 161   "Set the window start according to where the scroll bar is dragged.
 162 EVENT should be a scroll bar click or drag event."
 163   (interactive "e")
 164   (let* ((end-position (event-end event))
 165          (window (nth 0 end-position))
 166          (portion-whole (nth 2 end-position)))
 167     (with-current-buffer (window-buffer window)
 168       (save-excursion
 169         (goto-char (+ (point-min)
 170                       (scroll-bar-scale portion-whole
 171                                         (- (point-max) (point-min)))))
 172         (beginning-of-line)
 173         (set-window-start window (point))))))
 174
 175 (defun scroll-bar-drag-position (portion-whole)
 176   "Calculate new window start for drag event."
 177   (save-excursion
 178     (goto-char (+ (point-min)
 179                   (scroll-bar-scale portion-whole
 180                                     (- (point-max) (point-min)))))
 181     (beginning-of-line)
 182     (point)))
 183
 184 (defun scroll-bar-maybe-set-window-start (event)
 185   "Set the window start according to where the scroll bar is dragged.
 186 Only change window start if the new start is substantially different.
 187 EVENT should be a scroll bar click or drag event."
 188   (interactive "e")
 189   (let* ((end-position (event-end event))
 190          (window (nth 0 end-position))
 191          (portion-whole (nth 2 end-position))
 192          (next-portion-whole (cons (1+ (car portion-whole))
 193                                    (cdr portion-whole)))
 194          portion-start
 195          next-portion-start
 196          (current-start (window-start window)))
 197     (with-current-buffer (window-buffer window)
 198       (setq portion-start (scroll-bar-drag-position portion-whole))
 199       (setq next-portion-start (max
 200                                 (scroll-bar-drag-position next-portion-whole)
 201                                 (1+ portion-start)))
 202       (if (or (>= current-start next-portion-start)
 203               (< current-start portion-start))
 204           (set-window-start window portion-start)
 205         ;; Always set window start, to ensure scroll bar position is updated.
 206         (set-window-start window current-start)))))
 207
 208 ;; Scroll the window to the proper position for EVENT.
 209 (defun scroll-bar-drag-1 (event)
 210   (let* ((start-position (event-start event))
 211          (window (nth 0 start-position))
 212          (portion-whole (nth 2 start-position)))
 213     (save-excursion
 214       (with-current-buffer (window-buffer window)
 215         ;; Calculate position relative to the accessible part of the buffer.
 216         (goto-char (+ (point-min)
 217                       (scroll-bar-scale portion-whole
 218                                         (- (point-max) (point-min)))))
 219         (vertical-motion 0 window)
 220         (set-window-start window (point))))))
 221
 222 (defun scroll-bar-drag (event)
 223   "Scroll the window by dragging the scroll bar slider.
 224 If you click outside the slider, the window scrolls to bring the slider there."
 225   (interactive "e")
 226   (let* (done
 227          (echo-keystrokes 0)
 228          (end-position (event-end event))
 229          (window (nth 0 end-position))
 230          (before-scroll))
 231     (with-current-buffer (window-buffer window)
 232       (setq before-scroll point-before-scroll))
 233     (save-selected-window
 234       (select-window window)
 235       (setq before-scroll
 236             (or before-scroll (point))))
 237     (scroll-bar-drag-1 event)
 238     (track-mouse
 239       (while (not done)
 240         (setq event (read-event))
 241         (if (eq (car-safe event) 'mouse-movement)
 242             (setq event (read-event)))
 243         (cond ((eq (car-safe event) 'scroll-bar-movement)
 244                (scroll-bar-drag-1 event))
 245               (t
 246                ;; Exit when we get the drag event; ignore that event.
 247                (setq done t)))))
 248     (sit-for 0)
 249     (with-current-buffer (window-buffer window)
 250       (setq point-before-scroll before-scroll))))
 251
 252 (defun scroll-bar-scroll-down (event)
 253   "Scroll the window's top line down to the location of the scroll bar click.
 254 EVENT should be a scroll bar click."
 255   (interactive "e")
 256   (let* ((end-position (event-end event))
 257          (window (nth 0 end-position))
 258          (before-scroll))
 259     (with-current-buffer (window-buffer window)
 260       (setq before-scroll point-before-scroll))
 261     (unwind-protect
 262         (save-selected-window
 263           (let ((portion-whole (nth 2 end-position)))
 264             (select-window window)
 265             (setq before-scroll
 266                   (or before-scroll (point)))
 267             (scroll-down
 268              (scroll-bar-scale portion-whole (1- (window-height)))))
 269           (sit-for 0))
 270       (with-current-buffer (window-buffer window)
 271         (setq point-before-scroll before-scroll)))))
 272
 273 (defun scroll-bar-scroll-up (event)
 274   "Scroll the line next to the scroll bar click to the top of the window.
 275 EVENT should be a scroll bar click."
 276   (interactive "e")
 277   (let* ((end-position (event-end event))
 278          (window (nth 0 end-position))
 279          (before-scroll))
 280     (with-current-buffer (window-buffer window)
 281       (setq before-scroll point-before-scroll))
 282     (unwind-protect
 283         (save-selected-window
 284           (let ((portion-whole (nth 2 end-position)))
 285             (select-window window)
 286             (setq before-scroll
 287                   (or before-scroll (point)))
 288             (scroll-up
 289              (scroll-bar-scale portion-whole (1- (window-height)))))
 290           (sit-for 0))
 291       (with-current-buffer (window-buffer window)
 292         (setq point-before-scroll before-scroll)))))
 293
 294 \f
 295 ;;; Tookit scroll bars.
 296
 297 (defun scroll-bar-toolkit-scroll (event)
 298   (interactive "e")
 299   (let* ((end-position (event-end event))
 300          (window (nth 0 end-position))
 301          (part (nth 4 end-position))
 302          before-scroll)
 303     (cond ((eq part 'end-scroll))
 304           (t
 305            (with-current-buffer (window-buffer window)
 306              (setq before-scroll point-before-scroll))
 307            (save-selected-window
 308              (select-window window)
 309              (setq before-scroll (or before-scroll (point)))
 310              (cond ((eq part 'above-handle)
 311                     (scroll-up '-))
 312                    ((eq part 'below-handle)
 313                     (scroll-up nil))
 314                    ((eq part 'ratio)
 315                     (let* ((portion-whole (nth 2 end-position))
 316                            (lines (scroll-bar-scale portion-whole
 317                                                     (1- (window-height)))))
 318                       (scroll-up (cond ((not (zerop lines)) lines)
 319                                        ((< (car portion-whole) 0) -1)
 320                                        (t 1)))))
 321                    ((eq part 'up)
 322                     (scroll-up -1))
 323                    ((eq part 'down)
 324                     (scroll-up 1))
 325                    ((eq part 'top)
 326                     (set-window-start window (point-min)))
 327                    ((eq part 'bottom)
 328                     (goto-char (point-max))
 329                     (recenter))
 330                    ((eq part 'handle)
 331                     (scroll-bar-drag-1 event))))
 332            (sit-for 0)
 333            (with-current-buffer (window-buffer window)
 334              (setq point-before-scroll before-scroll))))))
 335
 336
 337 \f
 338 ;;;; Bindings.
 339
 340 ;; For now, we'll set things up to work like xterm.
 341 (cond ((and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
 342        (global-set-key [vertical-scroll-bar mouse-1]
 343                        'scroll-bar-toolkit-scroll))
 344       (t
 345        (global-set-key [vertical-scroll-bar mouse-1]
 346                        'scroll-bar-scroll-up)
 347        (global-set-key [vertical-scroll-bar drag-mouse-1]
 348                        'scroll-bar-scroll-up)
 349        (global-set-key [vertical-scroll-bar down-mouse-2]
 350                        'scroll-bar-drag)
 351        (global-set-key [vertical-scroll-bar mouse-3]
 352                        'scroll-bar-scroll-down)
 353        (global-set-key [vertical-scroll-bar drag-mouse-3]
 354                        'scroll-bar-scroll-down)))
 355
 356 \f
 357 (provide 'scroll-bar)
 358
 359 ;;; scroll-bar.el ends here