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, 2002, 2003, 2004, 2005 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.6
   9 ;; Keywords: convenience
  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' `comment-column',
  34 ;; `goal-column', `window-margins' and `tab-stop-list' settings:
  35 ;;
  36 ;; [header-line (shift down-mouse-1)] set left margin end to the ruler
  37 ;; graduation where the mouse pointer is on.
  38 ;;
  39 ;; [header-line (shift down-mouse-3)] set right margin beginning to
  40 ;; the ruler graduation where the mouse pointer is on.
  41 ;;
  42 ;; [header-line down-mouse-2] Drag the `fill-column', `comment-column'
  43 ;; or `goal-column' to a ruler graduation.
  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, `ruler-mode-comment-column-char' shows
  59 ;; the `comment-column' location, `ruler-mode-goal-column-char' shows
  60 ;; the `goal-column' and `ruler-mode-tab-stop-char' shows tab stop
  61 ;; locations.  Graduations in `window-margins' and `window-fringes'
  62 ;; areas are shown with a different foreground color.
  63 ;;
  64 ;; It is also possible to customize the following characters:
  65 ;;
  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' the ruler default face.
  74 ;; - `ruler-mode-fill-column' the face used to highlight the
  75 ;;   `fill-column' character.
  76 ;; - `ruler-mode-comment-column' the face used to highlight the
  77 ;;   `comment-column' character.
  78 ;; - `ruler-mode-goal-column' the face used to highlight the
  79 ;;   `goal-column' character.
  80 ;; - `ruler-mode-current-column' the face used to highlight the
  81 ;;   `current-column' character.
  82 ;; - `ruler-mode-tab-stop' the face used to highlight tab stop
  83 ;;   characters.
  84 ;; - `ruler-mode-margins' the face used to highlight graduations
  85 ;;   in the `window-margins' areas.
  86 ;; - `ruler-mode-fringes' the face used to highlight graduations
  87 ;;   in the `window-fringes' areas.
  88 ;; - `ruler-mode-column-number' the face used to highlight the
  89 ;;   numbered graduations.
  90 ;;
  91 ;; `ruler-mode-default' inherits from the built-in `default' face.
  92 ;; All `ruler-mode' faces inherit from `ruler-mode-default'.
  93 ;;
  94 ;; WARNING: To keep ruler graduations aligned on text columns it is
  95 ;; important to use the same font family and size for ruler and text
  96 ;; areas.
  97 ;;
  98 ;; You can override the ruler format by defining an appropriate
  99 ;; function as the buffer-local value of `ruler-mode-ruler-function'.
 100
 101 ;; Installation
 102 ;;
 103 ;; To automatically display the ruler in specific major modes use:
 104 ;;
 105 ;;    (add-hook '<major-mode>-hook 'ruler-mode)
 106 ;;
 107
 108 ;;; History:
 109 ;;
 110 \f
 111 ;;; Code:
 112 (eval-when-compile
 113   (require 'wid-edit))
 114 (require 'scroll-bar)
 115 (require 'fringe)
 116
 117 (defgroup ruler-mode nil
 118   "Display a ruler in the header line."
 119   :version "22.1"
 120   :group 'convenience)
 121
 122 (defcustom ruler-mode-show-tab-stops nil
 123   "*If non-nil the ruler shows tab stop positions.
 124 Also allowing to visually change `tab-stop-list' setting using
 125 <C-down-mouse-1> and <C-down-mouse-3> on the ruler to respectively add
 126 or remove a tab stop.  \\[ruler-mode-toggle-show-tab-stops] or
 127 <C-down-mouse-2> on the ruler toggles showing/editing of tab stops."
 128   :group 'ruler-mode
 129   :type 'boolean)
 130
 131 ;; IMPORTANT: This function must be defined before the following
 132 ;; defcustoms because it is used in their :validate clause.
 133 (defun ruler-mode-character-validate (widget)
 134   "Ensure WIDGET value is a valid character value."
 135   (save-excursion
 136     (let ((value (widget-value widget)))
 137       (if (char-valid-p value)
 138           nil
 139         (widget-put widget :error
 140                     (format "Invalid character value: %S" value))
 141         widget))))
 142
 143 (defcustom ruler-mode-fill-column-char (if (char-displayable-p ?¶)
 144                                            ?\¶
 145                                          ?\|)
 146   "*Character used at the `fill-column' location."
 147   :group 'ruler-mode
 148   :type '(choice
 149           (character :tag "Character")
 150           (integer :tag "Integer char value"
 151                    :validate ruler-mode-character-validate)))
 152
 153 (defcustom ruler-mode-comment-column-char ?\#
 154   "*Character used at the `comment-column' location."
 155   :group 'ruler-mode
 156   :type '(choice
 157           (character :tag "Character")
 158           (integer :tag "Integer char value"
 159                    :validate ruler-mode-character-validate)))
 160
 161 (defcustom ruler-mode-goal-column-char ?G
 162   "*Character used at the `goal-column' location."
 163   :group 'ruler-mode
 164   :type '(choice
 165           (character :tag "Character")
 166           (integer :tag "Integer char value"
 167                    :validate ruler-mode-character-validate)))
 168
 169 (defcustom ruler-mode-current-column-char (if (char-displayable-p ?¦)
 170                                               ?\¦
 171                                             ?\@)
 172   "*Character used at the `current-column' location."
 173   :group 'ruler-mode
 174   :type '(choice
 175           (character :tag "Character")
 176           (integer :tag "Integer char value"
 177                    :validate ruler-mode-character-validate)))
 178
 179 (defcustom ruler-mode-tab-stop-char ?\T
 180   "*Character used at `tab-stop-list' locations."
 181   :group 'ruler-mode
 182   :type '(choice
 183           (character :tag "Character")
 184           (integer :tag "Integer char value"
 185                    :validate ruler-mode-character-validate)))
 186
 187 (defcustom ruler-mode-basic-graduation-char ?\.
 188   "*Character used for basic graduations."
 189   :group 'ruler-mode
 190   :type '(choice
 191           (character :tag "Character")
 192           (integer :tag "Integer char value"
 193                    :validate ruler-mode-character-validate)))
 194
 195 (defcustom ruler-mode-inter-graduation-char ?\!
 196   "*Character used for intermediate graduations."
 197   :group 'ruler-mode
 198   :type '(choice
 199           (character :tag "Character")
 200           (integer :tag "Integer char value"
 201                    :validate ruler-mode-character-validate)))
 202
 203 (defcustom ruler-mode-set-goal-column-ding-flag t
 204   "*Non-nil means do `ding' when `goal-column' is set."
 205   :group 'ruler-mode
 206   :type 'boolean)
 207 \f
 208 (defface ruler-mode-default
 209   '((((type tty))
 210      (:inherit default
 211                :background "grey64"
 212                :foreground "grey50"
 213                ))
 214     (t
 215      (:inherit default
 216                :background "grey76"
 217                :foreground "grey64"
 218                :box (:color "grey76"
 219                             :line-width 1
 220                             :style released-button)
 221                )))
 222   "Default face used by the ruler."
 223   :group 'ruler-mode)
 224 ;; backward-compatibility alias
 225 (put 'ruler-mode-default-face 'face-alias 'ruler-mode-default)
 226
 227 (defface ruler-mode-pad
 228   '((((type tty))
 229      (:inherit ruler-mode-default
 230                :background "grey50"
 231                ))
 232     (t
 233      (:inherit ruler-mode-default
 234                :background "grey64"
 235                )))
 236   "Face used to pad inactive ruler areas."
 237   :group 'ruler-mode)
 238 ;; backward-compatibility alias
 239 (put 'ruler-mode-pad-face 'face-alias 'ruler-mode-pad)
 240
 241 (defface ruler-mode-margins
 242   '((t
 243      (:inherit ruler-mode-default
 244                :foreground "white"
 245                )))
 246   "Face used to highlight margin areas."
 247   :group 'ruler-mode)
 248 ;; backward-compatibility alias
 249 (put 'ruler-mode-margins-face 'face-alias 'ruler-mode-margins)
 250
 251 (defface ruler-mode-fringes
 252   '((t
 253      (:inherit ruler-mode-default
 254                :foreground "green"
 255                )))
 256   "Face used to highlight fringes areas."
 257   :group 'ruler-mode)
 258 ;; backward-compatibility alias
 259 (put 'ruler-mode-fringes-face 'face-alias 'ruler-mode-fringes)
 260
 261 (defface ruler-mode-column-number
 262   '((t
 263      (:inherit ruler-mode-default
 264                :foreground "black"
 265                )))
 266   "Face used to highlight number graduations."
 267   :group 'ruler-mode)
 268 ;; backward-compatibility alias
 269 (put 'ruler-mode-column-number-face 'face-alias 'ruler-mode-column-number)
 270
 271 (defface ruler-mode-fill-column
 272   '((t
 273      (:inherit ruler-mode-default
 274                :foreground "red"
 275                )))
 276   "Face used to highlight the fill column character."
 277   :group 'ruler-mode)
 278 ;; backward-compatibility alias
 279 (put 'ruler-mode-fill-column-face 'face-alias 'ruler-mode-fill-column)
 280
 281 (defface ruler-mode-comment-column
 282   '((t
 283      (:inherit ruler-mode-default
 284                :foreground "red"
 285                )))
 286   "Face used to highlight the comment column character."
 287   :group 'ruler-mode)
 288 ;; backward-compatibility alias
 289 (put 'ruler-mode-comment-column-face 'face-alias 'ruler-mode-comment-column)
 290
 291 (defface ruler-mode-goal-column
 292   '((t
 293      (:inherit ruler-mode-default
 294                :foreground "red"
 295                )))
 296   "Face used to highlight the goal column character."
 297   :group 'ruler-mode)
 298 ;; backward-compatibility alias
 299 (put 'ruler-mode-goal-column-face 'face-alias 'ruler-mode-goal-column)
 300
 301 (defface ruler-mode-tab-stop
 302   '((t
 303      (:inherit ruler-mode-default
 304                :foreground "steelblue"
 305                )))
 306   "Face used to highlight tab stop characters."
 307   :group 'ruler-mode)
 308 ;; backward-compatibility alias
 309 (put 'ruler-mode-tab-stop-face 'face-alias 'ruler-mode-tab-stop)
 310
 311 (defface ruler-mode-current-column
 312   '((t
 313      (:inherit ruler-mode-default
 314                :weight bold
 315                :foreground "yellow"
 316                )))
 317   "Face used to highlight the `current-column' character."
 318   :group 'ruler-mode)
 319 ;; backward-compatibility alias
 320 (put 'ruler-mode-current-column-face 'face-alias 'ruler-mode-current-column)
 321 \f
 322
 323 (defsubst ruler-mode-full-window-width ()
 324   "Return the full width of the selected window."
 325   (let ((edges (window-edges)))
 326     (- (nth 2 edges) (nth 0 edges))))
 327
 328 (defsubst ruler-mode-window-col (n)
 329   "Return a column number relative to the selected window.
 330 N is a column number relative to selected frame."
 331   (- n
 332      (car (window-edges))
 333      (or (car (window-margins)) 0)
 334      (fringe-columns 'left)
 335      (scroll-bar-columns 'left)))
 336 \f
 337 (defun ruler-mode-mouse-set-left-margin (start-event)
 338   "Set left margin end to the graduation where the mouse pointer is on.
 339 START-EVENT is the mouse click event."
 340   (interactive "e")
 341   (let* ((start (event-start start-event))
 342          (end   (event-end   start-event))
 343          col w lm rm)
 344     (when (eq start end) ;; mouse click
 345       (save-selected-window
 346         (select-window (posn-window start))
 347         (setq col (- (car (posn-col-row start)) (car (window-edges))
 348                      (scroll-bar-columns 'left))
 349               w   (- (ruler-mode-full-window-width)
 350                      (scroll-bar-columns 'left)
 351                      (scroll-bar-columns 'right)))
 352         (when (and (>= col 0) (< col w))
 353           (setq lm (window-margins)
 354                 rm (or (cdr lm) 0)
 355                 lm (or (car lm) 0))
 356           (message "Left margin set to %d (was %d)" col lm)
 357           (set-window-margins nil col rm))))))
 358
 359 (defun ruler-mode-mouse-set-right-margin (start-event)
 360   "Set right margin beginning to the graduation where the mouse pointer is on.
 361 START-EVENT is the mouse click event."
 362   (interactive "e")
 363   (let* ((start (event-start start-event))
 364          (end   (event-end   start-event))
 365          col w lm rm)
 366     (when (eq start end) ;; mouse click
 367       (save-selected-window
 368         (select-window (posn-window start))
 369         (setq col (- (car (posn-col-row start)) (car (window-edges))
 370                      (scroll-bar-columns 'left))
 371               w   (- (ruler-mode-full-window-width)
 372                      (scroll-bar-columns 'left)
 373                      (scroll-bar-columns 'right)))
 374         (when (and (>= col 0) (< col w))
 375           (setq lm  (window-margins)
 376                 rm  (or (cdr lm) 0)
 377                 lm  (or (car lm) 0)
 378                 col (- w col 1))
 379           (message "Right margin set to %d (was %d)" col rm)
 380           (set-window-margins nil lm col))))))
 381
 382 (defvar ruler-mode-dragged-symbol nil
 383   "Column symbol dragged in the ruler.
 384 That is `fill-column', `comment-column', `goal-column', or nil when
 385 nothing is dragged.")
 386
 387 (defun ruler-mode-mouse-grab-any-column (start-event)
 388   "Drag a column symbol on the ruler.
 389 Start dragging on mouse down event START-EVENT, and update the column
 390 symbol value with the current value of the ruler graduation while
 391 dragging.  See also the variable `ruler-mode-dragged-symbol'."
 392   (interactive "e")
 393   (setq ruler-mode-dragged-symbol nil)
 394   (let* ((start (event-start start-event))
 395          col newc oldc)
 396     (save-selected-window
 397       (select-window (posn-window start))
 398       (setq col  (ruler-mode-window-col (car (posn-col-row start)))
 399             newc (+ col (window-hscroll)))
 400       (and
 401        (>= col 0) (< col (window-width))
 402        (cond
 403
 404         ;; Handle the fill column.
 405         ((eq newc fill-column)
 406          (setq oldc fill-column
 407                ruler-mode-dragged-symbol 'fill-column)
 408          t) ;; Start dragging
 409
 410         ;; Handle the comment column.
 411         ((eq newc comment-column)
 412          (setq oldc comment-column
 413                ruler-mode-dragged-symbol 'comment-column)
 414          t) ;; Start dragging
 415
 416         ;; Handle the goal column.
 417         ;; A. On mouse down on the goal column character on the ruler,
 418         ;;    update the `goal-column' value while dragging.
 419         ;; B. If `goal-column' is nil, set the goal column where the
 420         ;;    mouse is clicked.
 421         ;; C. On mouse click on the goal column character on the
 422         ;;    ruler, unset the goal column.
 423         ((eq newc goal-column)          ; A. Drag the goal column.
 424          (setq oldc goal-column
 425                ruler-mode-dragged-symbol 'goal-column)
 426          t) ;; Start dragging
 427
 428         ((null goal-column)             ; B. Set the goal column.
 429          (setq oldc goal-column
 430                goal-column newc)
 431          ;; mouse-2 coming AFTER drag-mouse-2 invokes `ding'.  This
 432          ;; `ding' flushes the next messages about setting goal
 433          ;; column.  So here I force fetch the event(mouse-2) and
 434          ;; throw away.
 435          (read-event)
 436          ;; Ding BEFORE `message' is OK.
 437          (when ruler-mode-set-goal-column-ding-flag
 438            (ding))
 439          (message "Goal column set to %d (click on %s again to unset it)"
 440                   newc
 441                   (propertize (char-to-string ruler-mode-goal-column-char)
 442                               'face 'ruler-mode-goal-column))
 443          nil) ;; Don't start dragging.
 444         )
 445        (if (eq 'click (ruler-mode-mouse-drag-any-column-iteration
 446                        (posn-window start)))
 447            (when (eq 'goal-column ruler-mode-dragged-symbol)
 448              ;; C. Unset the goal column.
 449              (set-goal-column t))
 450          ;; At end of dragging, report the updated column symbol.
 451          (message "%s is set to %d (was %d)"
 452                   ruler-mode-dragged-symbol
 453                   (symbol-value ruler-mode-dragged-symbol)
 454                   oldc))))))
 455
 456 (defun ruler-mode-mouse-drag-any-column-iteration (window)
 457   "Update the ruler while dragging the mouse.
 458 WINDOW is the window where occurred the last down-mouse event.
 459 Return the symbol `drag' if the mouse has been dragged, or `click' if
 460 the mouse has been clicked."
 461   (let ((drags 0)
 462         event)
 463     (track-mouse
 464       (while (mouse-movement-p (setq event (read-event)))
 465         (setq drags (1+ drags))
 466         (when (eq window (posn-window (event-end event)))
 467           (ruler-mode-mouse-drag-any-column event)
 468           (force-mode-line-update))))
 469     (if (and (zerop drags) (eq 'click (car (event-modifiers event))))
 470         'click
 471       'drag)))
 472
 473 (defun ruler-mode-mouse-drag-any-column (start-event)
 474   "Update the value of the symbol dragged on the ruler.
 475 Called on each mouse motion event START-EVENT."
 476   (let* ((start (event-start start-event))
 477          (end   (event-end   start-event))
 478          col newc)
 479     (save-selected-window
 480       (select-window (posn-window start))
 481       (setq col  (ruler-mode-window-col (car (posn-col-row end)))
 482             newc (+ col (window-hscroll)))
 483       (when (and (>= col 0) (< col (window-width)))
 484         (set ruler-mode-dragged-symbol newc)))))
 485 \f
 486 (defun ruler-mode-mouse-add-tab-stop (start-event)
 487   "Add a tab stop to the graduation where the mouse pointer is on.
 488 START-EVENT is the mouse click event."
 489   (interactive "e")
 490   (when ruler-mode-show-tab-stops
 491     (let* ((start (event-start start-event))
 492            (end   (event-end   start-event))
 493            col ts)
 494       (when (eq start end) ;; mouse click
 495         (save-selected-window
 496           (select-window (posn-window start))
 497           (setq col (ruler-mode-window-col (car (posn-col-row start)))
 498                 ts  (+ col (window-hscroll)))
 499           (and (>= col 0) (< col (window-width))
 500                (not (member ts tab-stop-list))
 501                (progn
 502                  (message "Tab stop set to %d" ts)
 503                  (setq tab-stop-list (sort (cons ts tab-stop-list)
 504                                            #'<)))))))))
 505
 506 (defun ruler-mode-mouse-del-tab-stop (start-event)
 507   "Delete tab stop at the graduation where the mouse pointer is on.
 508 START-EVENT is the mouse click event."
 509   (interactive "e")
 510   (when ruler-mode-show-tab-stops
 511     (let* ((start (event-start start-event))
 512            (end   (event-end   start-event))
 513            col ts)
 514       (when (eq start end) ;; mouse click
 515         (save-selected-window
 516           (select-window (posn-window start))
 517           (setq col (ruler-mode-window-col (car (posn-col-row start)))
 518                 ts  (+ col (window-hscroll)))
 519           (and (>= col 0) (< col (window-width))
 520                (member ts tab-stop-list)
 521                (progn
 522                  (message "Tab stop at %d deleted" ts)
 523                  (setq tab-stop-list (delete ts tab-stop-list)))))))))
 524
 525 (defun ruler-mode-toggle-show-tab-stops ()
 526   "Toggle showing of tab stops on the ruler."
 527   (interactive)
 528   (setq ruler-mode-show-tab-stops (not ruler-mode-show-tab-stops))
 529   (force-mode-line-update))
 530 \f
 531 (defvar ruler-mode-map
 532   (let ((km (make-sparse-keymap)))
 533     (define-key km [header-line down-mouse-1]
 534       #'ignore)
 535     (define-key km [header-line down-mouse-3]
 536       #'ignore)
 537     (define-key km [header-line down-mouse-2]
 538       #'ruler-mode-mouse-grab-any-column)
 539     (define-key km [header-line (shift down-mouse-1)]
 540       #'ruler-mode-mouse-set-left-margin)
 541     (define-key km [header-line (shift down-mouse-3)]
 542       #'ruler-mode-mouse-set-right-margin)
 543     (define-key km [header-line (control down-mouse-1)]
 544       #'ruler-mode-mouse-add-tab-stop)
 545     (define-key km [header-line (control down-mouse-3)]
 546       #'ruler-mode-mouse-del-tab-stop)
 547     (define-key km [header-line (control down-mouse-2)]
 548       #'ruler-mode-toggle-show-tab-stops)
 549     km)
 550   "Keymap for ruler minor mode.")
 551
 552 (defvar ruler-mode-header-line-format-old nil
 553   "Hold previous value of `header-line-format'.")
 554
 555 (defvar ruler-mode-ruler-function 'ruler-mode-ruler
 556   "Function to call to return ruler header line format.
 557 This variable is expected to be made buffer-local by modes.")
 558
 559 (defconst ruler-mode-header-line-format
 560   '(:eval (funcall ruler-mode-ruler-function))
 561   "`header-line-format' used in ruler mode.
 562 Call `ruler-mode-ruler-function' to compute the ruler value.")
 563
 564 ;;;###autoload
 565 (define-minor-mode ruler-mode
 566   "Display a ruler in the header line if ARG > 0."
 567   nil nil
 568   ruler-mode-map
 569   :group 'ruler-mode
 570   (if ruler-mode
 571       (progn
 572         ;; When `ruler-mode' is on save previous header line format
 573         ;; and install the ruler header line format.
 574         (when (local-variable-p 'header-line-format)
 575           (set (make-local-variable 'ruler-mode-header-line-format-old)
 576                header-line-format))
 577         (setq header-line-format ruler-mode-header-line-format)
 578         (add-hook 'post-command-hook 'force-mode-line-update nil t))
 579     ;; When `ruler-mode' is off restore previous header line format if
 580     ;; the current one is the ruler header line format.
 581     (when (eq header-line-format ruler-mode-header-line-format)
 582       (kill-local-variable 'header-line-format)
 583       (when (local-variable-p 'ruler-mode-header-line-format-old)
 584         (setq header-line-format ruler-mode-header-line-format-old)
 585         (kill-local-variable 'ruler-mode-header-line-format-old)))
 586     (remove-hook 'post-command-hook 'force-mode-line-update t)))
 587 \f
 588 ;; Add ruler-mode to the minor mode menu in the mode line
 589 (define-key mode-line-mode-menu [ruler-mode]
 590   `(menu-item "Ruler" ruler-mode
 591               :button (:toggle . ruler-mode)))
 592
 593 (defconst ruler-mode-ruler-help-echo
 594   "\
 595 S-mouse-1/3: set L/R margin, \
 596 mouse-2: set goal column, \
 597 C-mouse-2: show tabs"
 598   "Help string shown when mouse is over the ruler.
 599 `ruler-mode-show-tab-stops' is nil.")
 600
 601 (defconst ruler-mode-ruler-help-echo-when-goal-column
 602   "\
 603 S-mouse-1/3: set L/R margin, \
 604 C-mouse-2: show tabs"
 605   "Help string shown when mouse is over the ruler.
 606 `goal-column' is set and `ruler-mode-show-tab-stops' is nil.")
 607
 608 (defconst ruler-mode-ruler-help-echo-when-tab-stops
 609   "\
 610 C-mouse1/3: set/unset tab, \
 611 C-mouse-2: hide tabs"
 612   "Help string shown when mouse is over the ruler.
 613 `ruler-mode-show-tab-stops' is non-nil.")
 614
 615 (defconst ruler-mode-fill-column-help-echo
 616   "drag-mouse-2: set fill column"
 617   "Help string shown when mouse is on the fill column character.")
 618
 619 (defconst ruler-mode-comment-column-help-echo
 620   "drag-mouse-2: set comment column"
 621   "Help string shown when mouse is on the comment column character.")
 622
 623 (defconst ruler-mode-goal-column-help-echo
 624   "\
 625 drag-mouse-2: set goal column, \
 626 mouse-2: unset goal column"
 627   "Help string shown when mouse is on the goal column character.")
 628
 629 (defconst ruler-mode-margin-help-echo
 630   "%s margin %S"
 631   "Help string shown when mouse is over a margin area.")
 632
 633 (defconst ruler-mode-fringe-help-echo
 634   "%s fringe %S"
 635   "Help string shown when mouse is over a fringe area.")
 636
 637 (defsubst ruler-mode-space (width &rest props)
 638   "Return a single space string of WIDTH times the normal character width.
 639 Optional argument PROPS specifies other text properties to apply."
 640   (apply 'propertize " " 'display (list 'space :width width) props))
 641 \f
 642 (defun ruler-mode-ruler ()
 643   "Compute and return an header line ruler."
 644   (let* ((w (window-width))
 645          (m (window-margins))
 646          (f (window-fringes))
 647          (i 0)
 648          (j (window-hscroll))
 649          ;; Setup the scrollbar, fringes, and margins areas.
 650          (lf (ruler-mode-space
 651               'left-fringe
 652               'face 'ruler-mode-fringes
 653               'help-echo (format ruler-mode-fringe-help-echo
 654                                  "Left" (or (car f) 0))))
 655          (rf (ruler-mode-space
 656               'right-fringe
 657               'face 'ruler-mode-fringes
 658               'help-echo (format ruler-mode-fringe-help-echo
 659                                  "Right" (or (cadr f) 0))))
 660          (lm (ruler-mode-space
 661               'left-margin
 662               'face 'ruler-mode-margins
 663               'help-echo (format ruler-mode-margin-help-echo
 664                                  "Left" (or (car m) 0))))
 665          (rm (ruler-mode-space
 666               'right-margin
 667               'face 'ruler-mode-margins
 668               'help-echo (format ruler-mode-margin-help-echo
 669                                  "Right" (or (cdr m) 0))))
 670          (sb (ruler-mode-space
 671               'scroll-bar
 672               'face 'ruler-mode-pad))
 673          ;; Remember the scrollbar vertical type.
 674          (sbvt (car (window-current-scroll-bars)))
 675          ;; Create an "clean" ruler.
 676          (ruler
 677           (propertize
 678            (make-string w ruler-mode-basic-graduation-char)
 679            'face 'ruler-mode-default
 680            'local-map ruler-mode-map
 681            'help-echo (cond
 682                        (ruler-mode-show-tab-stops
 683                         ruler-mode-ruler-help-echo-when-tab-stops)
 684                        (goal-column
 685                         ruler-mode-ruler-help-echo-when-goal-column)
 686                        (ruler-mode-ruler-help-echo))))
 687          k c)
 688     ;; Setup the active area.
 689     (while (< i w)
 690       ;; Graduations.
 691       (cond
 692        ;; Show a number graduation.
 693        ((= (mod j 10) 0)
 694         (setq c (number-to-string (/ j 10))
 695               m (length c)
 696               k i)
 697         (put-text-property
 698          i (1+ i) 'face 'ruler-mode-column-number
 699          ruler)
 700         (while (and (> m 0) (>= k 0))
 701           (aset ruler k (aref c (setq m (1- m))))
 702           (setq k (1- k))))
 703        ;; Show an intermediate graduation.
 704        ((= (mod j 5) 0)
 705         (aset ruler i ruler-mode-inter-graduation-char)))
 706       ;; Special columns.
 707       (cond
 708        ;; Show the `current-column' marker.
 709        ((= j (current-column))
 710         (aset ruler i ruler-mode-current-column-char)
 711         (put-text-property
 712          i (1+ i) 'face 'ruler-mode-current-column
 713          ruler))
 714        ;; Show the `goal-column' marker.
 715        ((and goal-column (= j goal-column))
 716         (aset ruler i ruler-mode-goal-column-char)
 717         (put-text-property
 718          i (1+ i) 'face 'ruler-mode-goal-column
 719          ruler)
 720         (put-text-property
 721          i (1+ i) 'mouse-face 'mode-line-highlight
 722          ruler)
 723         (put-text-property
 724          i (1+ i) 'help-echo ruler-mode-goal-column-help-echo
 725          ruler))
 726        ;; Show the `comment-column' marker.
 727        ((= j comment-column)
 728         (aset ruler i ruler-mode-comment-column-char)
 729         (put-text-property
 730          i (1+ i) 'face 'ruler-mode-comment-column
 731          ruler)
 732         (put-text-property
 733          i (1+ i) 'mouse-face 'mode-line-highlight
 734          ruler)
 735         (put-text-property
 736          i (1+ i) 'help-echo ruler-mode-comment-column-help-echo
 737          ruler))
 738        ;; Show the `fill-column' marker.
 739        ((= j fill-column)
 740         (aset ruler i ruler-mode-fill-column-char)
 741         (put-text-property
 742          i (1+ i) 'face 'ruler-mode-fill-column
 743          ruler)
 744         (put-text-property
 745          i (1+ i) 'mouse-face 'mode-line-highlight
 746          ruler)
 747         (put-text-property
 748          i (1+ i) 'help-echo ruler-mode-fill-column-help-echo
 749          ruler))
 750        ;; Show the `tab-stop-list' markers.
 751        ((and ruler-mode-show-tab-stops (member j tab-stop-list))
 752         (aset ruler i ruler-mode-tab-stop-char)
 753         (put-text-property
 754          i (1+ i) 'face 'ruler-mode-tab-stop
 755          ruler)))
 756       (setq i (1+ i)
 757             j (1+ j)))
 758     ;; Return the ruler propertized string.  Using list here,
 759     ;; instead of concat visually separate the different areas.
 760     (if (nth 2 (window-fringes))
 761         ;; fringes outside margins.
 762         (list "" (and (eq 'left sbvt) sb) lf lm
 763               ruler rm rf (and (eq 'right sbvt) sb))
 764       ;; fringes inside margins.
 765       (list "" (and (eq 'left sbvt) sb) lm lf
 766             ruler rf rm (and (eq 'right sbvt) sb)))))
 767
 768 (provide 'ruler-mode)
 769
 770 ;; Local Variables:
 771 ;; coding: iso-latin-1
 772 ;; End:
 773
 774 ;;; arch-tag: b2f24546-5605-44c4-b67b-c9a4eeba3ee8
 775 ;;; ruler-mode.el ends here