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