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