code.delx.au - gnu-emacs/blob - lisp/ruler-mode.el

   1 ;;; ruler-mode.el --- Display a ruler in the header line
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 24 Mar 2001
   8 ;; Version: 1.4
   9 ;; Keywords: environment
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This library provides a minor mode to display a ruler in the header
  31 ;; line.  It works only on Emacs 21.
  32 ;;
  33 ;; You can use the mouse to change the `fill-column', `window-margins'
  34 ;; and `tab-stop-list' settings:
  35 ;;
  36 ;; [header-line (shift down-mouse-1)] set left margin to the ruler
  37 ;; graduation where the mouse pointer is on.
  38 ;;
  39 ;; [header-line (shift down-mouse-3)] set right margin to the ruler
  40 ;; graduation where the mouse pointer is on.
  41 ;;
  42 ;; [header-line down-mouse-2] set `fill-column' to the ruler
  43 ;; graduation where the mouse pointer is on.
  44 ;;
  45 ;; [header-line (control down-mouse-1)] add a tab stop to the ruler
  46 ;; graduation where the mouse pointer is on.
  47 ;;
  48 ;; [header-line (control down-mouse-3)] remove the tab stop at the
  49 ;; ruler graduation where the mouse pointer is on.
  50 ;;
  51 ;; [header-line (control down-mouse-2)] or M-x
  52 ;; `ruler-mode-toggle-show-tab-stops' toggle showing and visually
  53 ;; editing `tab-stop-list' setting.  The `ruler-mode-show-tab-stops'
  54 ;; option controls if the ruler shows tab stops by default.
  55 ;;
  56 ;; In the ruler the character `ruler-mode-current-column-char' shows
  57 ;; the `current-column' location, `ruler-mode-fill-column-char' shows
  58 ;; the `fill-column' location and `ruler-mode-tab-stop-char' shows tab
  59 ;; stop locations.  `window-margins' areas are shown with a different
  60 ;; background color.
  61 ;;
  62 ;; It is also possible to customize the following characters:
  63 ;;
  64 ;; - `ruler-mode-margins-char' character used to pad margin areas
  65 ;;   (space by default).
  66 ;; - `ruler-mode-basic-graduation-char' character used for basic
  67 ;;   graduations ('.' by default).
  68 ;; - `ruler-mode-inter-graduation-char' character used for
  69 ;;   intermediate graduations ('!' by default).
  70 ;;
  71 ;; The following faces are customizable:
  72 ;;
  73 ;; - `ruler-mode-default-face' the ruler default face.
  74 ;; - `ruler-mode-fill-column-face' the face used to highlight the
  75 ;;   `fill-column' character.
  76 ;; - `ruler-mode-current-column-face' the face used to highlight the
  77 ;;   `current-column' character.
  78 ;; - `ruler-mode-tab-stop-face' the face used to highlight tab stop
  79 ;;   characters.
  80 ;; - `ruler-mode-margins-face' the face used to highlight the
  81 ;;   `window-margins' areas.
  82 ;; - `ruler-mode-column-number-face' the face used to highlight the
  83 ;;   number graduations.
  84 ;;
  85 ;; `ruler-mode-default-face' inherits from the built-in `default' face.
  86 ;; All `ruler-mode' faces inerit from `ruler-mode-default-face'.
  87 ;;
  88 ;; WARNING: To keep ruler graduations aligned on text columns it is
  89 ;; important to use the same font family and size for ruler and text
  90 ;; areas.
  91
  92 ;; Installation
  93 ;;
  94 ;; To automatically display the ruler in specific major modes use:
  95 ;;
  96 ;;    (add-hook '<major-mode>-hook 'ruler-mode)
  97 ;;
  98
  99 ;;; History:
 100 ;;
 101 \f
 102 ;;; Code:
 103 (eval-when-compile
 104   (require 'wid-edit))
 105
 106 (defgroup ruler-mode nil
 107   "Display a ruler in the header line."
 108   :version "21.2"
 109   :group 'environment)
 110
 111 (defcustom ruler-mode-show-tab-stops nil
 112   "*If non-nil the ruler shows tab stop positions.
 113 Also allowing to visually change `tab-stop-list' setting using
 114 <C-down-mouse-1> and <C-down-mouse-3> on the ruler to respectively add
 115 or remove a tab stop.  \\[ruler-mode-toggle-show-tab-stops] or
 116 <C-down-mouse-2> on the ruler toggles showing/editing of tab stops."
 117   :group 'ruler-mode
 118   :type 'boolean)
 119
 120 ;; IMPORTANT: This function must be defined before the following
 121 ;; defcustoms because it is used in their :validate clause.
 122 (defun ruler-mode-character-validate (widget)
 123   "Ensure WIDGET value is a valid character value."
 124   (save-excursion
 125     (let ((value (widget-value widget)))
 126       (if (char-valid-p value)
 127           nil
 128         (widget-put widget :error
 129                     (format "Invalid character value: %S" value))
 130         widget))))
 131
 132 (defcustom ruler-mode-fill-column-char (if window-system
 133                                            ?\¶
 134                                          ?\|)
 135   "*Character used at the `fill-column' location."
 136   :group 'ruler-mode
 137   :type '(choice
 138           (character :tag "Character")
 139           (integer :tag "Integer char value"
 140                    :validate ruler-mode-character-validate)))
 141
 142 (defcustom ruler-mode-current-column-char (if window-system
 143                                               ?\¦
 144                                             ?\@)
 145   "*Character used at the `current-column' location."
 146   :group 'ruler-mode
 147   :type '(choice
 148           (character :tag "Character")
 149           (integer :tag "Integer char value"
 150                    :validate ruler-mode-character-validate)))
 151
 152 (defcustom ruler-mode-tab-stop-char ?\T
 153   "*Character used at `tab-stop-list' locations."
 154   :group 'ruler-mode
 155   :type '(choice
 156           (character :tag "Character")
 157           (integer :tag "Integer char value"
 158                    :validate ruler-mode-character-validate)))
 159
 160 (defcustom ruler-mode-margins-char ?\
 161   "*Character used in margin areas."
 162   :group 'ruler-mode
 163   :type '(choice
 164           (character :tag "Character")
 165           (integer :tag "Integer char value"
 166                    :validate ruler-mode-character-validate)))
 167
 168 (defcustom ruler-mode-basic-graduation-char ?\.
 169   "*Character used for basic graduations."
 170   :group 'ruler-mode
 171   :type '(choice
 172           (character :tag "Character")
 173           (integer :tag "Integer char value"
 174                    :validate ruler-mode-character-validate)))
 175
 176 (defcustom ruler-mode-inter-graduation-char ?\!
 177   "*Character used for intermediate graduations."
 178   :group 'ruler-mode
 179   :type '(choice
 180           (character :tag "Character")
 181           (integer :tag "Integer char value"
 182                    :validate ruler-mode-character-validate)))
 183 \f
 184 (defface ruler-mode-default-face
 185   '((((type tty))
 186      (:inherit default
 187                :background "grey64"
 188                :foreground "grey50"
 189                ))
 190     (t
 191      (:inherit default
 192                :background "grey76"
 193                :foreground "grey64"
 194                :box (:color "grey76"
 195                             :line-width 1
 196                             :style released-button)
 197                )))
 198   "Default face used by the ruler."
 199   :group 'ruler-mode)
 200
 201 (defface ruler-mode-column-number-face
 202   '((t
 203      (:inherit ruler-mode-default-face
 204                :foreground "black"
 205                )))
 206   "Face used to highlight number graduations."
 207   :group 'ruler-mode)
 208
 209 (defface ruler-mode-fill-column-face
 210   '((t
 211      (:inherit ruler-mode-default-face
 212                :foreground "red"
 213                )))
 214   "Face used to highlight the fill column character."
 215   :group 'ruler-mode)
 216
 217 (defface ruler-mode-tab-stop-face
 218   '((t
 219      (:inherit ruler-mode-default-face
 220                :foreground "steelblue"
 221                )))
 222   "Face used to highlight tab stop characters."
 223   :group 'ruler-mode)
 224
 225 (defface ruler-mode-margins-face
 226   '((((type tty))
 227      (:inherit ruler-mode-default-face
 228                :background "grey50"
 229                ))
 230     (t
 231      (:inherit ruler-mode-default-face
 232                :background "grey64"
 233                )))
 234   "Face used to highlight the `window-margins' areas."
 235   :group 'ruler-mode)
 236
 237 (defface ruler-mode-current-column-face
 238   '((t
 239      (:inherit ruler-mode-default-face
 240                :weight bold
 241                :foreground "yellow"
 242                )))
 243   "Face used to highlight the `current-column' character."
 244   :group 'ruler-mode)
 245 \f
 246 (defun ruler-mode-mouse-set-left-margin (start-event)
 247   "Set left margin to the graduation where the mouse pointer is on.
 248 START-EVENT is the mouse click event."
 249   (interactive "e")
 250   (let* ((start (event-start start-event))
 251          (end   (event-end   start-event))
 252          w col m lm0 lm rm)
 253     (if (eq start end) ;; mouse click
 254         (save-selected-window
 255           (select-window (posn-window start))
 256           (setq m   (window-margins)
 257                 lm0 (or (car m) 0)
 258                 rm  (or (cdr m) 0)
 259                 w   (window-width)
 260                 col (car (posn-col-row start))
 261                 lm  (min (- w rm) col))
 262           (message "Left margin set to %d (was %d)" lm lm0)
 263           (set-window-margins nil lm rm)))))
 264
 265 (defun ruler-mode-mouse-set-right-margin (start-event)
 266   "Set right margin to the graduation where the mouse pointer is on.
 267 START-EVENT is the mouse click event."
 268   (interactive "e")
 269   (let* ((start (event-start start-event))
 270          (end   (event-end   start-event))
 271          m col w lm rm0 rm)
 272     (if (eq start end) ;; mouse click
 273         (save-selected-window
 274           (select-window (posn-window start))
 275           (setq m   (window-margins)
 276                 rm0 (or (cdr m) 0)
 277                 lm  (or (car m) 0)
 278                 col (car (posn-col-row start))
 279                 w   (window-width)
 280                 rm  (max 0 (- w col)))
 281           (message "Right margin set to %d (was %d)" rm rm0)
 282           (set-window-margins nil lm rm)))))
 283
 284 (defun ruler-mode-mouse-set-fill-column (start-event)
 285   "Set `fill-column' to the graduation where the mouse pointer is on.
 286 START-EVENT is the mouse click event."
 287   (interactive "e")
 288   (let* ((start (event-start start-event))
 289          (end   (event-end   start-event))
 290          m col w lm rm hs fc)
 291     (if (eq start end) ;; mouse click
 292         (save-selected-window
 293           (select-window (posn-window start))
 294           (setq m   (window-margins)
 295                 lm  (or (car m) 0)
 296                 rm  (or (cdr m) 0)
 297                 col (- (car (posn-col-row start)) lm)
 298                 w   (window-width)
 299                 hs  (window-hscroll)
 300                 fc  (+ col hs))
 301           (and (>= col 0) (< (+ col lm rm) w)
 302                (progn
 303                  (message "Fill column set to %d (was %d)" fc fill-column)
 304                  (setq fill-column fc)))))))
 305 \f
 306 (defun ruler-mode-mouse-add-tab-stop (start-event)
 307   "Add a tab stop to the graduation where the mouse pointer is on.
 308 START-EVENT is the mouse click event."
 309   (interactive "e")
 310   (if ruler-mode-show-tab-stops
 311       (let* ((start (event-start start-event))
 312              (end   (event-end   start-event))
 313              m col w lm rm hs ts)
 314         (if (eq start end) ;; mouse click
 315             (save-selected-window
 316               (select-window (posn-window start))
 317               (setq m   (window-margins)
 318                     lm  (or (car m) 0)
 319                     rm  (or (cdr m) 0)
 320                     col (- (car (posn-col-row start)) lm)
 321                     w   (window-width)
 322                     hs  (window-hscroll)
 323                     ts  (+ col hs))
 324               (and (>= col 0) (< (+ col lm rm) w)
 325                    (not (member ts tab-stop-list))
 326                    (progn
 327                      (message "Tab stop set to %d" ts)
 328                      (setq tab-stop-list
 329                            (sort (cons ts tab-stop-list)
 330                                  #'<)))))))))
 331
 332 (defun ruler-mode-mouse-del-tab-stop (start-event)
 333   "Delete tab stop at the graduation where the mouse pointer is on.
 334 START-EVENT is the mouse click event."
 335   (interactive "e")
 336   (if ruler-mode-show-tab-stops
 337       (let* ((start (event-start start-event))
 338              (end   (event-end   start-event))
 339              m col w lm rm hs ts)
 340         (if (eq start end) ;; mouse click
 341             (save-selected-window
 342               (select-window (posn-window start))
 343               (setq m   (window-margins)
 344                     lm  (or (car m) 0)
 345                     rm  (or (cdr m) 0)
 346                     col (- (car (posn-col-row start)) lm)
 347                     w   (window-width)
 348                     hs  (window-hscroll)
 349                     ts  (+ col hs))
 350               (and (>= col 0) (< (+ col lm rm) w)
 351                    (member ts tab-stop-list)
 352                    (progn
 353                      (message "Tab stop at %d deleted" ts)
 354                      (setq tab-stop-list
 355                            (delete ts tab-stop-list)))))))))
 356
 357 (defun ruler-mode-toggle-show-tab-stops ()
 358   "Toggle showing of tab stops on the ruler."
 359   (interactive)
 360   (setq ruler-mode-show-tab-stops (not ruler-mode-show-tab-stops))
 361   (force-mode-line-update))
 362 \f
 363 (defvar ruler-mode-map
 364   (let ((km (make-sparse-keymap)))
 365     (define-key km [header-line down-mouse-1]
 366       #'ignore)
 367     (define-key km [header-line down-mouse-3]
 368       #'ignore)
 369     (define-key km [header-line down-mouse-2]
 370       #'ruler-mode-mouse-set-fill-column)
 371     (define-key km [header-line (shift down-mouse-1)]
 372       #'ruler-mode-mouse-set-left-margin)
 373     (define-key km [header-line (shift down-mouse-3)]
 374       #'ruler-mode-mouse-set-right-margin)
 375     (define-key km [header-line (control down-mouse-1)]
 376       #'ruler-mode-mouse-add-tab-stop)
 377     (define-key km [header-line (control down-mouse-3)]
 378       #'ruler-mode-mouse-del-tab-stop)
 379     (define-key km [header-line (control down-mouse-2)]
 380       #'ruler-mode-toggle-show-tab-stops)
 381     km)
 382   "Keymap for ruler minor mode.")
 383
 384 (defvar ruler-mode-header-line-format-old nil
 385   "Hold previous value of `header-line-format'.")
 386 (make-variable-buffer-local 'ruler-mode-header-line-format-old)
 387
 388 (defconst ruler-mode-header-line-format
 389   '(:eval (ruler-mode-ruler))
 390   "`header-line-format' used in ruler mode.")
 391
 392 ;;;###autoload
 393 (define-minor-mode ruler-mode
 394   "Display a ruler in the header line if ARG > 0."
 395   nil nil
 396   ruler-mode-map
 397   :group 'ruler-mode
 398   (if ruler-mode
 399       (progn
 400         ;; When `ruler-mode' is on save previous header line format
 401         ;; and install the ruler header line format.
 402         (setq ruler-mode-header-line-format-old header-line-format
 403               header-line-format ruler-mode-header-line-format)
 404         (add-hook 'post-command-hook    ; add local hook
 405                   #'force-mode-line-update nil t))
 406     ;; When `ruler-mode' is off restore previous header line format if
 407     ;; the current one is the ruler header line format.
 408     (if (eq header-line-format ruler-mode-header-line-format)
 409         (setq header-line-format ruler-mode-header-line-format-old))
 410     (remove-hook 'post-command-hook     ; remove local hook
 411                  #'force-mode-line-update t)))
 412 \f
 413 ;; Add ruler-mode to the the minor mode menu in the mode line
 414 (define-key mode-line-mode-menu [ruler-mode]
 415   `(menu-item "Ruler" ruler-mode
 416               :button (:toggle . ruler-mode)))
 417
 418 (defconst ruler-mode-ruler-help-echo
 419   "\
 420 S-mouse-1/3: set L/R margin, \
 421 mouse-2: set fill col, \
 422 C-mouse-2: show tabs"
 423   "Help string shown when mouse pointer is over the ruler.
 424 `ruler-mode-show-tab-stops' is nil.")
 425
 426 (defconst ruler-mode-ruler-help-echo-tab
 427   "\
 428 C-mouse1/3: set/unset tab, \
 429 C-mouse-2: hide tabs"
 430   "Help string shown when mouse pointer is over the ruler.
 431 `ruler-mode-show-tab-stops' is non-nil.")
 432
 433 (defconst ruler-mode-left-margin-help-echo
 434   "Left margin %S"
 435   "Help string shown when mouse is over the left margin area.")
 436
 437 (defconst ruler-mode-right-margin-help-echo
 438   "Right margin %S"
 439   "Help string shown when mouse is over the right margin area.")
 440
 441 (defun ruler-mode-extra-left-cols ()
 442   "Return number of extra columns on the left side of selected frame.
 443 That is the number of columns occupied by the left fringe area and
 444 vertical scrollbar on the left side of the selected frame."
 445   (let ((w  (frame-first-window))
 446         (xy (cons 0 0)))
 447     (with-current-buffer (window-buffer w)
 448       (let (header-line-format)
 449         (while (not (listp (coordinates-in-window-p xy w)))
 450           (setcar xy (1+ (car xy))))
 451         (car xy)))))
 452 \f
 453 (defun ruler-mode-ruler ()
 454   "Return a string ruler."
 455   (if ruler-mode
 456       (let* ((j     (ruler-mode-extra-left-cols))
 457              (k     (/ (or (frame-parameter nil 'right-fringe) 0)
 458                        (frame-char-width)))
 459              (w     (+ (window-width) j))
 460              (m     (window-margins))
 461              (l     (or (car m) 0))
 462              (r     (or (cdr m) 0))
 463              (o     (- (window-hscroll) l j))
 464              (i     0)
 465              (ruler (concat
 466                      ;; unit graduations
 467                      (make-string w ruler-mode-basic-graduation-char)
 468                      ;; extra space to fill the header line
 469                      (make-string k ?\ )))
 470              c)
 471
 472         ;; Setup default face and help echo.
 473         (put-text-property 0 (length ruler)
 474                            'face 'ruler-mode-default-face
 475                            ruler)
 476         (put-text-property 0 (length ruler)
 477                            'help-echo
 478                            (if ruler-mode-show-tab-stops
 479                                ruler-mode-ruler-help-echo-tab
 480                              ruler-mode-ruler-help-echo)
 481                            ruler)
 482         ;; Setup the local map.
 483         (put-text-property 0 (length ruler)
 484                            'local-map ruler-mode-map
 485                            ruler)
 486
 487         (setq j (+ l j))
 488         ;; Setup the left margin area.
 489         (put-text-property
 490          i j 'face 'ruler-mode-margins-face
 491          ruler)
 492         (put-text-property
 493          i j 'help-echo (format ruler-mode-left-margin-help-echo l)
 494          ruler)
 495         (while (< i j)
 496           (aset ruler i ruler-mode-margins-char)
 497           (setq i (1+ i)))
 498
 499         ;; Setup the ruler area.
 500         (setq r (- w r))
 501         (while (< i r)
 502           (setq j (+ i o))
 503           (cond
 504            ((= (mod j 10) 0)
 505             (setq c (number-to-string (/ j 10))
 506                   m (length c)
 507                   k i)
 508             (put-text-property
 509              i (1+ i) 'face 'ruler-mode-column-number-face
 510              ruler)
 511             (while (and (> m 0) (>= k 0))
 512               (aset ruler k (aref c (setq m (1- m))))
 513               (setq k (1- k)))
 514             )
 515            ((= (mod j 5) 0)
 516             (aset ruler i ruler-mode-inter-graduation-char)
 517             )
 518            )
 519           (setq i (1+ i)))
 520
 521         ;; Setup the right margin area.
 522         (put-text-property
 523          i (length ruler) 'face 'ruler-mode-margins-face
 524          ruler)
 525         (put-text-property
 526          i (length ruler) 'help-echo
 527          (format ruler-mode-right-margin-help-echo (- w r))
 528          ruler)
 529         (while (< i (length ruler))
 530           (aset ruler i ruler-mode-margins-char)
 531           (setq i (1+ i)))
 532
 533         ;; Show the `fill-column' marker.
 534         (setq i (- fill-column o))
 535         (and (>= i 0) (< i r)
 536              (aset ruler i ruler-mode-fill-column-char)
 537              (put-text-property
 538               i (1+ i) 'face 'ruler-mode-fill-column-face
 539               ruler))
 540
 541         ;; Show the `tab-stop-list' markers.
 542         (if ruler-mode-show-tab-stops
 543             (let ((tsl tab-stop-list) ts)
 544               (while tsl
 545                 (setq ts  (car tsl)
 546                       tsl (cdr tsl)
 547                       i   (- ts o))
 548                 (and (>= i 0) (< i r)
 549                      (aset ruler i ruler-mode-tab-stop-char)
 550                      (put-text-property
 551                       i (1+ i)
 552                       'face (cond
 553                              ;; Don't override the fill-column face
 554                              ((eq ts fill-column)
 555                               'ruler-mode-fill-column-face)
 556                              (t
 557                               'ruler-mode-tab-stop-face))
 558                       ruler)))))
 559
 560         ;; Show the `current-column' marker.
 561         (setq i (- (current-column) o))
 562         (and (>= i 0) (< i r)
 563              (aset ruler i ruler-mode-current-column-char)
 564              (put-text-property
 565               i (1+ i) 'face 'ruler-mode-current-column-face
 566               ruler))
 567
 568         ruler)))
 569
 570 (provide 'ruler-mode)
 571
 572 ;; Local Variables:
 573 ;; coding: iso-latin-1
 574 ;; End:
 575
 576 ;;; ruler-mode.el ends here