lisp/hscroll.el

   1 ;;; hscroll.el: Minor mode to automatically scroll truncated lines horizontally
   2 ;;; Copyright (C) 1992, 1993, 1995, 1996 Free Software Foundation, Inc.
   3
   4 ;; Author: Wayne Mesard <wmesard@esd.sgi.com>
   5 ;; Keywords: display
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:a
  25 ;;
  26 ;;    Automatically scroll horizontally when the point moves off the
  27 ;;    left or right edge of the window.
  28 ;;
  29 ;;    - Type "M-x hscroll-mode" to enable it in the current buffer.
  30 ;;    - Type "M-x hscroll-global-mode" to enable it in every buffer.
  31 ;;    - "turn-on-hscroll" is useful in mode hooks as in:
  32 ;;          (add-hook 'text-mode-hook 'turn-on-hscroll)
  33 ;;
  34 ;;    - hscroll-margin controls how close the cursor can get to the edge
  35 ;;      of the window.
  36 ;;    - hscroll-step-percent controls how far to jump once we decide to do so.
  37 ;;
  38 ;;    Most users won't want to mess with the other variables defined
  39 ;;    here.  But they're all documented, and they all start with
  40 ;;    "hscroll-" if you're curious.
  41 ;;
  42 ;;    Oh, you should also know that if you set the hscroll-margin and
  43 ;;    hscroll-step-percent large enough, you can get an interesting, but
  44 ;;    undesired ping-pong effect as the point bounces from one edge to
  45 ;;    the other.
  46 ;;
  47 ;;    wmesard@sgi.com
  48
  49 ;;; Code:
  50
  51 ;;;
  52 ;;; PUBLIC VARIABLES
  53 ;;;
  54
  55 (defvar hscroll-version "2.2")
  56
  57 (defvar hscroll-margin 5
  58   "*How many columns away from the edge of the window point is allowed to get
  59 before HScroll will horizontally scroll the window.")
  60
  61 (defvar hscroll-snap-threshold 30
  62   "*When point is this many columns (or less) from the left edge of the document,
  63 don't do any horizontal scrolling.  In other words, be biased towards the left
  64 edge of the document.
  65   Set this variable to zero to disable this bias.")
  66
  67 (defvar hscroll-step-percent 25
  68   "*How far away to place the point from the window's edge when scrolling.
  69 Expressed as a percentage of the window's width.")
  70
  71 (defvar hscroll-mode-name " Hscr"
  72   "*Horizontal scrolling mode line indicator.
  73 Set this to nil to conserve valuable mode line space.")
  74
  75 (or (assq 'hscroll-mode minor-mode-alist)
  76     (setq minor-mode-alist
  77           (cons '(hscroll-mode hscroll-mode-name) minor-mode-alist)))
  78
  79
  80 ;;;
  81 ;;; PRIVATE VARIABLES
  82 ;;;
  83
  84 (defvar hscroll-mode nil
  85   "Non-nil if HScroll mode is enabled.")
  86 (make-variable-buffer-local 'hscroll-mode)
  87
  88
  89 (defvar hscroll-old-truncate-local nil)
  90 (defvar hscroll-old-truncate-was-global nil)
  91 (make-variable-buffer-local 'hscroll-old-truncate)
  92 (make-variable-buffer-local 'hscroll-old-truncate-was-global)
  93
  94 (defvar hscroll-old-truncate-default nil)
  95
  96 ;;;
  97 ;;; PUBLIC COMMANDS
  98 ;;;
  99
 100 ;;;###autoload
 101 (defun turn-on-hscroll ()
 102   "Unconditionally turn on Hscroll mode in the current buffer."
 103   (hscroll-mode 1))
 104
 105 ;;;###autoload
 106 (defun hscroll-mode (&optional arg)
 107   "Toggle HScroll mode in the current buffer.
 108 With ARG, turn HScroll mode on if ARG is positive, off otherwise.
 109 In HScroll mode, truncated lines will automatically scroll left or
 110 right when point gets near either edge of the window.
 111   See also \\[hscroll-global-mode]."
 112   (interactive "P")
 113   (make-local-hook 'post-command-hook)
 114   (let ((newmode (if (null arg)
 115                       (not hscroll-mode)
 116                     (> (prefix-numeric-value arg) 0))))
 117
 118     (if newmode
 119         ;; turn it on
 120         (if (not hscroll-mode)
 121             ;; it was off
 122             (let ((localp (local-variable-p 'truncate-lines)))
 123               (if localp
 124                   (setq hscroll-old-truncate-local truncate-lines))
 125               (setq hscroll-old-truncate-was-global (not localp))
 126               (setq truncate-lines t)
 127               (add-hook 'post-command-hook
 128                         (function hscroll-window-maybe) nil t)
 129               ))
 130       ;; turn it off
 131       (if hscroll-mode
 132           ;; it was on
 133           (progn
 134             (if hscroll-old-truncate-was-global
 135                 (kill-local-variable 'truncate-lines)
 136               (setq truncate-lines hscroll-old-truncate-local))
 137             (if (not truncate-lines)
 138                 (set-window-hscroll (selected-window) 0))
 139             (remove-hook 'post-command-hook
 140                          (function hscroll-window-maybe) t)
 141             ))
 142       )
 143
 144     (setq hscroll-mode newmode)
 145     (force-mode-line-update nil)
 146     ))
 147
 148
 149 ;;;###autoload
 150 (defun hscroll-global-mode  (&optional arg)
 151   "Toggle HScroll mode in all buffers.
 152 With ARG, turn HScroll mode on if ARG is positive, off otherwise.
 153 If a buffer ever has HScroll mode set locally (via \\[hscroll-mode]),
 154 it will forever use the local value (i.e., \\[hscroll-global-mode]
 155 will have no effect on it).
 156   See also \\[hscroll-mode]."
 157   (interactive "P")
 158   (let* ((oldmode (default-value 'hscroll-mode))
 159          (newmode (if (null arg)
 160                       (not oldmode)
 161                     (> (prefix-numeric-value arg) 0))))
 162
 163     (if newmode
 164         ;; turn it on
 165         (if (not hscroll-mode)
 166             ;; it was off
 167             (progn
 168               (setq hscroll-old-truncate-default (default-value truncate-lines))
 169               (setq hscroll-old-truncate-was-global t)
 170               (setq-default truncate-lines t)
 171               (add-hook 'post-command-hook (function hscroll-window-maybe))
 172               ))
 173       ;; turn it off
 174       (if hscroll-mode
 175           ;; it was on
 176           (progn
 177             (setq-default truncate-lines hscroll-old-truncate-default)
 178             (remove-hook 'post-command-hook (function hscroll-window-maybe))
 179             ))
 180       )
 181
 182     (setq-default hscroll-mode newmode)
 183     (force-mode-line-update t)
 184     ))
 185
 186 (defun hscroll-window-maybe ()
 187   "Scroll horizontally if point is off or nearly off the edge of the window.
 188 This is called automatically when in HScroll mode, but it can be explicitly
 189 invoked as well (i.e., it can be bound to a key)."
 190   (interactive)
 191   ;; Only consider scrolling if truncate-lines is true,
 192   ;; the window is already scrolled or partial-widths is true and this is
 193   ;; a partial width window.  See display_text_line() in xdisp.c.
 194   (if (and hscroll-mode
 195            (or truncate-lines
 196                (not (zerop (window-hscroll)))
 197                (and truncate-partial-width-windows
 198                     (< (window-width) (frame-width)))))
 199       (let ((linelen (save-excursion (end-of-line) (current-column)))
 200             (rightmost-char (+ (window-width) (window-hscroll)))
 201             )
 202         (if (< (current-column) hscroll-snap-threshold)
 203             (set-window-hscroll
 204              (selected-window)
 205              (- (window-hscroll)))
 206           (if (>= (current-column)
 207                 (- rightmost-char hscroll-margin
 208                    ;; Off-by-one if the left edge is scrolled
 209                    (if (not (zerop (window-hscroll))) 1 0)
 210                    ;; Off by one if the right edge is scrolled
 211                    (if (> linelen rightmost-char) 1 0)
 212                    ))
 213             ;; Scroll to the left a proportion of the window's width.
 214             (set-window-hscroll
 215              (selected-window)
 216              (- (+ (current-column)
 217                    (/ (* (window-width) hscroll-step-percent) 100))
 218                 (window-width)))
 219           (if (< (current-column) (+ (window-hscroll) hscroll-margin))
 220               ;; Scroll to the right a proportion of the window's width.
 221               (set-window-hscroll
 222                (selected-window)
 223                (- (current-column) (/ (* (window-width) hscroll-step-percent) 100)))
 224             )))
 225         )))
 226
 227 ;;;
 228 ;;; It's not a bug, it's a *feature*
 229 ;;;
 230
 231 (provide 'hscroll)
 232
 233 ;;; hscroll.el ends here