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