Mercurial > hg > xemacs-beta

comparison lisp/modes/whitespace-mode.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents
children
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
1 ;;; whitespace-mode.el -- minor mode for making whitespace visible
2
3 ;; Copyright (C) 1994, 1995, 1996 Heiko Muenkel
4
5 ;; Author: Heiko Muenkel <muenkel@tnt.uni-hannover.de>
6 ;; Keywords: modes, extensions
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your
13 ;; option) any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; if not, write to the Free Software
22 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: FSF 19.34.
26
27 ;;; Commentary:
28
29 ;; $Id: whitespace-mode.el,v 1.2 1997/02/22 22:07:27 steve Exp $
30 ;; Description:
31 ;;
32 ;; This is a minor mode, which highlights whitespaces (blanks and
33 ;; tabs) with different faces, so that it is easier to
34 ;; distinguish between them.
35 ;; Toggle the mode with: M-x whitespace-mode
36 ;; or with: M-x whitespace-incremental-mode
37 ;; The second one should be used in big files.
38 ;;
39 ;; If you want to know how the whitespaces are highlighted then
40 ;; type: M-x whitespace-show-faces
41 ;;
42 ;; There are 2 hook variables `whitespace-incremental-mode-hook'
43 ;; and `whitespace-mode-hook' to customize the mode.
44 ;;
45 ;; Look at the variable `whitespace-chars', if you only want to
46 ;; highlight tabs or blanks and not both.
47 ;;
48 ;; Set `whitespace-install-toolbar-icon' to t, if you want a
49 ;; toolbar icon for this mode.
50 ;;
51 ;; Set `whitespace-install-submenu' to t, if you want a submenu
52 ;; for this mode. Sorry, at the moment there is no menu for the
53 ;; Emacs 19.
54 ;;
55 ;; Thanks to Mike Scheidler for the toolbar icon code.
56 ;;
57 ;; Installation:
58 ;;
59 ;; Put the files whitespace-mode.el and adapt.el in one of your
60 ;; load-path directories and the following lines (without the
61 ;; comment signs) in your .emacs (adapt.el is already in the
62 ;; XEmacs 19.12).
63 ;;
64 ;; (autoload 'whitespace-mode "whitespace-mode"
65 ;; "Toggle whitespace mode.
66 ;; With arg, turn whitespace mode on iff arg is positive.
67 ;; In whitespace mode the different whitespaces (tab, blank return)
68 ;; are highlighted with different faces. The faces are:
69 ;; `whitespace-blank-face', `whitespace-tab-face' and
70 ;; `whitespace-return-face'."
71 ;; t)
72 ;;
73 ;; (autoload 'whitespace-incremental-mode "whitespace-mode"
74 ;; "Toggle whitespace incremental mode.
75 ;; With arg, turn whitespace incremental mode on iff arg is positive.
76 ;; In whitespace incremental mode the different whitespaces (tab and
77 ;; blank) are highlighted with different faces. The faces are:
78 ;; `whitespace-blank-face' and `whitespace-tab-face'.
79 ;; Use the command `whitespace-show-faces' to show their values.
80 ;; In this mode only these tabs and blanks are highlighted, which are in
81 ;; the region from (point) - (window-heigh) to (point) + (window-heigh)."
82
83 ;;; Code:
84
85 (provide 'whitespace-mode)
86 (require 'adapt)
87
88 ;;; variables:
89
90 (defvar whitespace-chars 'tabs-and-blanks
91 "*Determines, which whitespaces are highlighted.
92 Valid values are:
93 'tabs-and-blanks => tabs and blanks are highlighted;
94 'tabs => only tabs are highlighted;
95 'blanks => only blanks are highlighted;.
96
97 Changing this variable during the whitespace-*-mode is active could lead
98 to wrong highlighted whitespaces.")
99
100 (make-variable-buffer-local 'whitespace-chars)
101
102 (defvar whitespace-mode-hook nil
103 "*Run after the `whitespace-mode' is switched on.")
104
105 (defvar whitespace-incremental-mode-hook nil
106 "*Run after the `whitespace-incremental-mode' is switched on.")
107
108
109 (if (adapt-xemacsp)
110 (progn
111
112 (defvar whitespace-install-toolbar-icon nil
113 "Set it to t, if a toolbar icon should be installed during loading this file.
114 The icon calls the function 'whitespace-toolbar-function'.")
115
116 (defvar whitespace-install-submenu nil
117 "Set it to t, if a submenu should be installed during loading this file.")
118
119 ))
120
121
122 (defvar whitespace-toolbar-function 'whitespace-incremental-mode
123 "*The toolbar icon for the whitespace mode calls this function.
124 Valid values are: 'whitespace--mode and 'whitespace-incremental-mode.")
125
126 (defvar whitespace-blank-and-tab-search-string "\\( \\)\\|\\(\t\\)"
127 "The regexp used to search for tabs and blanks.")
128
129 (defvar whitespace-tab-search-string "\t"
130 "The search string used to find tabs.")
131
132 (defvar whitespace-blank-search-string " "
133 "The search string used to find blanks.")
134
135 ;;; Defining faces
136 (if (facep 'whitespace-blank-face)
137 nil
138 (make-face 'whitespace-blank-face)
139 (set-face-background 'whitespace-blank-face "LightBlue1"))
140
141 (if (facep 'whitespace-tab-face)
142 nil
143 (make-face 'whitespace-tab-face)
144 (set-face-background 'whitespace-tab-face "yellow")
145 (set-face-underline-p 'whitespace-tab-face t))
146
147 (defun whitespace-show-faces ()
148 "Shows the faces used by the `whitespace-mode'."
149 (interactive)
150 (save-excursion
151 (let ((actual-buffer-name (buffer-name (current-buffer)))
152 (actual-whitespace-chars whitespace-chars)
153 (whitespace-mode-active (or whitespace-mode
154 whitespace-incremental-mode))
155 (buffer (get-buffer-create "*Help*")))
156 (set-buffer buffer)
157 (setq whitespace-chars actual-whitespace-chars)
158 (delete-region (point-min) (point-max))
159 (insert "In the whitespace minor mode\n"
160 " this \" ")
161 (whitespace-highlight-region (1- (point)) (point))
162 (insert "\" is a blank, highlighted with `whitespace-blank-face' and\n"
163 " this \"\t")
164 (whitespace-highlight-region (1- (point)) (point))
165 (insert "\" is a tab, highlighted with `whitespace-tab-face'.")
166
167 (newline 2)
168 (if (eq whitespace-chars 'blanks)
169 (insert
170 "The highlighting of tabs is switched off.\n")
171 (if (eq whitespace-chars 'tabs)
172 (insert
173 "The highlighting of blanks is switched off.\n")))
174 (newline)
175 (if whitespace-mode-active
176 (insert "A whitespace minor mode is active in the buffer\n "
177 actual-buffer-name
178 ".\n")
179 (insert "No whitespace minor mode is active in the buffer\n "
180 actual-buffer-name
181 ".\n"))
182 (show-temp-buffer-in-current-frame buffer)
183 )))
184
185 ;;;
186 (defun whitespace-highlight-chars-in-region (char-string from to face)
187 "Highlights the CHAR-STRING in the region from FROM to TO with the FACE."
188 (while (search-forward char-string end t)
189 (let ((extent))
190 (cond ((match-beginning 0)
191 (setq extent (make-extent (match-beginning 0) (match-end 0)))
192 (set-extent-face extent face)
193 ))
194 (set-extent-property extent 'start-open t)
195 (set-extent-property extent 'end-open t)
196 )))
197
198 (defun whitespace-highlight-region (from to)
199 "Highlights the whitespaces in the region from FROM to TO."
200 (let ((start (min from to))
201 (end (max from to)))
202 (save-excursion
203 ;; (message "Highlighting tabs and blanks...")
204 (goto-char start)
205 (cond ((eq whitespace-chars 'tabs-and-blanks)
206 (while (search-forward-regexp
207 whitespace-blank-and-tab-search-string end t)
208 (let ((extent))
209 (cond ((match-beginning 1) ; blanks ?
210 (setq extent (make-extent (match-beginning 1)
211 (match-end 1)))
212 (set-extent-face extent 'whitespace-blank-face)
213 )
214 ((match-beginning 2) ; tabs ?
215 (setq extent (make-extent (match-beginning 2)
216 (match-end 2)))
217 (set-extent-face extent 'whitespace-tab-face)
218 )
219 )
220 (set-extent-property extent 'start-open t)
221 (set-extent-property extent 'end-open t)
222 )))
223 ((eq whitespace-chars 'tabs)
224 (whitespace-highlight-chars-in-region whitespace-tab-search-string
225 from
226 to
227 'whitespace-tab-face))
228 ((eq whitespace-chars 'blanks)
229 (whitespace-highlight-chars-in-region
230 whitespace-blank-search-string
231 from
232 to
233 'whitespace-blank-face))
234 (t (error "ERROR: Bad value of whitespace-highlight-char")))
235 ;; (message "")
236 )))
237
238 (defun whitespace-highlight-buffer ()
239 "Highlights the whitespaces in the current buffer."
240 (whitespace-highlight-region (point-min) (point-max))
241 )
242
243 (defsubst whitespace-find-next-highlighted-region (from to)
244 "Returns nil or the next highlighted region."
245 (map-extents '(lambda (extent dummy)
246 (if (extent-property extent 'whitespace-highlighted-region)
247 extent))
248 nil
249 from
250 to))
251
252 (defun whitespace-incremental-highlight (from to)
253 "Highligthts the region from FROM to TO incremental."
254 (save-excursion
255 (goto-char from)
256 (let ((extent (extent-at (point) nil 'whitespace-highlighted-region))
257 (next-extent nil)
258 (start nil))
259 (while (< (point) to)
260 (if extent
261 (goto-char (extent-end-position extent)))
262 (if (< (point) to)
263 (progn
264 (setq start (point))
265
266 (setq next-extent (whitespace-find-next-highlighted-region
267 start
268 to))
269 (if extent
270 (if next-extent
271 (progn
272 (set-extent-endpoints extent
273 (extent-start-position extent)
274 (extent-end-position next-extent)
275 )
276 (whitespace-highlight-region start
277 (1-
278 (extent-start-position
279 next-extent)))
280 (delete-extent next-extent))
281 (set-extent-endpoints extent
282 (extent-start-position extent)
283 to)
284 (whitespace-highlight-region start to))
285 (if next-extent
286 (progn
287 (setq extent next-extent)
288 (whitespace-highlight-region start
289 (1- (extent-start-position
290 next-extent)))
291 (set-extent-endpoints extent
292 start
293 (extent-end-position next-extent)))
294 (setq extent (make-extent start to))
295 (set-extent-property extent 'whitespace-highlighted-region t)
296 (whitespace-highlight-region start to)))
297 ))))))
298
299
300 (defun whitespace-highlight-window ()
301 "Highlights the whitespaces in the current window."
302 (whitespace-incremental-highlight (save-excursion
303 (forward-line (- (window-height)))
304 (point))
305 (save-excursion
306 (forward-line (window-height))
307 (point))))
308
309 (defun whitespace-dehighlight-region (start end)
310 "Dehighlights the whitespaces in the region from START to END."
311 (map-extents '(lambda (extent dummy)
312 (if (or (eq (extent-face extent) 'whitespace-blank-face)
313 (eq (extent-face extent) 'whitespace-tab-face)
314 (extent-property extent
315 'whitespace-highlighted-region))
316 (progn
317 (delete-extent extent)
318 nil)))
319 nil
320 start
321 end
322 )
323 )
324
325 (defun whitespace-dehighlight-buffer ()
326 "Dehighlights the whitespaces in the current buffer."
327 (whitespace-dehighlight-region (point-min) (point-max))
328 )
329
330 (defun whitespace-highlight-after-change-function (beg end old-len)
331 "Called, when any modification is made to buffer text. Highlights
332 the whitespaces (blanks and tabs) in the region from BEG to
333 END. OLD-LEN isn't used, but provided from the after-change hook."
334 (if (or (eq beg end)
335 (null whitespace-mode))
336 nil
337 (whitespace-dehighlight-region beg end)
338 (whitespace-highlight-region beg end)))
339
340 (defvar whitespace-mode nil
341 "Non-nil, if the `whitespace-mode' is active.")
342
343 (make-variable-buffer-local 'whitespace-mode)
344
345 (defun whitespace-mode (&optional arg)
346 "Toggle whitespace mode.
347 With arg, turn whitespace mode on iff arg is positive.
348 In whitespace mode the different whitespaces (tab and blank)
349 are highlighted with different faces. The faces are:
350 `whitespace-blank-face' and `whitespace-tab-face'.
351 Use the command `whitespace-show-faces' to show their values."
352 (interactive "P")
353 (setq whitespace-mode
354 (if (null arg) (not whitespace-mode)
355 (> (prefix-numeric-value arg) 0)))
356 (if (and whitespace-mode whitespace-incremental-mode)
357 (progn
358 (whitespace-incremental-highlight (point-min) (point-max))
359 (setq whitespace-incremental-mode nil)
360 (remove-hook 'post-command-hook 'whitespace-highlight-window)
361 (run-hooks 'whitespace-mode-hook)
362 )
363 (setq whitespace-incremental-mode nil)
364 (remove-hook 'post-command-hook 'whitespace-highlight-window)
365 (redraw-modeline) ;(force-mode-line-update)
366 (if whitespace-mode
367 (progn
368 (whitespace-highlight-buffer)
369 (make-local-variable 'after-change-functions)
370 (add-hook 'after-change-functions
371 'whitespace-highlight-after-change-function)
372 (run-hooks 'whitespace-mode-hook))
373 (whitespace-dehighlight-buffer)
374 (remove-hook 'after-change-functions
375 'whitespace-highlight-after-change-function)
376 (remove-hook 'post-command-hook 'whitespace-highlight-window)
377 )))
378
379 (defvar whitespace-incremental-mode nil
380 "Non-nil, if the `whitespace-incremental-mode' is active.")
381
382 (make-variable-buffer-local 'whitespace-incremental-mode)
383
384 (defun whitespace-incremental-mode (&optional arg)
385 "Toggle whitespace incremental mode.
386 With arg, turn whitespace incremental mode on iff arg is positive.
387 In whitespace incremental mode the different whitespaces (tab and blank)
388 are highlighted with different faces. The faces are:
389 `whitespace-blank-face' and `whitespace-tab-face'.
390 Use the command `whitespace-show-faces' to show their values.
391 In this mode only these tabs and blanks are highlighted, which are in
392 the region from (point) - (window-heigh) to (point) + (window-heigh)."
393 (interactive "P")
394 (setq whitespace-incremental-mode
395 (if (null arg) (not whitespace-incremental-mode)
396 (> (prefix-numeric-value arg) 0)))
397 (if (and whitespace-mode whitespace-incremental-mode)
398 (set-extent-property (make-extent (point-min) (point-max))
399 'whitespace-highlighted-region
400 t))
401 (setq whitespace-mode nil)
402 (redraw-modeline) ;(force-mode-line-update)
403 ;(set-buffer-modified-p (buffer-modified-p)) ;No-op, but updates mode line.
404 (if whitespace-incremental-mode
405 (progn
406 (whitespace-highlight-window)
407 (make-local-variable 'post-command-hook)
408 (add-hook 'post-command-hook 'whitespace-highlight-window)
409 (make-local-variable 'after-change-functions)
410 (add-hook 'after-change-functions
411 'whitespace-highlight-after-change-function)
412 (run-hooks 'whitespace-incremental-mode-hook))
413 (whitespace-dehighlight-buffer)
414 (remove-hook 'after-change-functions
415 'whitespace-highlight-after-change-function)
416 (remove-hook 'post-command-hook 'whitespace-highlight-window)
417 ))
418
419
420 ;;; Add whitespace-mode and whitespace-incremental-mode to the minor-mode-alist
421
422 (or (assq 'whitespace-mode minor-mode-alist)
423 (setq minor-mode-alist
424 (cons '(whitespace-mode " WSP") minor-mode-alist)))
425
426 (or (assq 'whitespace-incremental-mode minor-mode-alist)
427 (setq minor-mode-alist
428 (cons '(whitespace-incremental-mode " WSPI") minor-mode-alist)))
429
430
431 ;;; Menu for the whitespace mode
432
433 (defun whitespace-set-whitespace-chars (new-whitespace-chars)
434 "Sets the variable `whitespace-chars' and activates the change."
435 (interactive (list (read (completing-read "Whitespaces to highlight: "
436 '(("tabs-and-blanks")
437 ("tabs")
438 ("blanks"))
439 nil
440 t
441 (symbol-name 'whitespace-chars)))))
442 (if (eq whitespace-chars new-whitespace-chars)
443 nil ; nothing to do
444 (setq whitespace-chars new-whitespace-chars)
445 (setq-default whitespace-chars new-whitespace-chars)
446 (cond (whitespace-mode (whitespace-mode)
447 (whitespace-mode))
448 (whitespace-incremental-mode (whitespace-incremental-mode)
449 (whitespace-incremental-mode))
450 )))
451
452 (defvar whitespace-menu nil
453 "A menu for the whitespace minor mode.")
454
455 (setq whitespace-menu
456 '("Whitespace Menu"
457 ["Highlight Whitespaces"
458 whitespace-mode
459 :style toggle
460 :selected whitespace-mode]
461 ["Incremental Highlighting"
462 whitespace-incremental-mode
463 :style toggle
464 :selected whitespace-incremental-mode
465 ]
466 "---"
467 ["Show Whitespace Faces" whitespace-show-faces t]
468 "---"
469 ["Highlight Tabs & Blanks"
470 (whitespace-set-whitespace-chars 'tabs-and-blanks)
471 :style radio
472 :selected (eq whitespace-chars 'tabs-and-blanks)]
473 ["Highlight Only Tabs"
474 (whitespace-set-whitespace-chars 'tabs)
475 :style radio
476 :selected (eq whitespace-chars 'tabs)]
477 ["Highlight Only Blanks"
478 (whitespace-set-whitespace-chars 'blanks)
479 :style radio
480 :selected (eq whitespace-chars 'blanks)]
481 ))
482
483 (if (and (boundp 'whitespace-install-submenu) whitespace-install-submenu)
484 (add-submenu '("Apps") whitespace-menu))
485
486 ;;; Toolbar icon for the XEmacs
487
488 (if (featurep 'toolbar)
489
490 (defvar toolbar-wspace-icon
491 (toolbar-make-button-list
492 "/* XPM */
493 static char * whitespace[] = {
494 \"28 28 4 1\",
495 \" c Gray75 s backgroundToolBarColor\",
496 \". c black\",
497 \"X c Gray60\",
498 \"o c white\",
499 \" \",
500 \" \",
501 \" \",
502 \" \",
503 \" .. . \",
504 \" XXX.XXXXXX . \",
505 \" Xoo.oooooXX . \",
506 \" .. .. ..o.o..oo..X... .. \",
507 \" . . X.o..o.ooX. X. . . \",
508 \" . . .oo.oo.ooX.XX. .... \",
509 \" ... .oo.oo.ooo.oo. . \",
510 \" . .Xoo.oo.ooo.oo. . . \",
511 \" . .Xo...o..o...o.. .. \",
512 \" XooooooooooooX \",
513 \" XooooooooooooX \",
514 \" .... ....ooo...ooo... .. \",
515 \" . . .oo.o.oo.oo.oX. . . \",
516 \" . .oo.ooo..oo.oX .... \",
517 \" .. .oo.o..o.oo.oX . \",
518 \" . . .oo.o.oo.oo.oX. . . \",
519 \" .... ...oo.....oo.. .. \",
520 \" .ooooooooooooX \",
521 \" .XXXXXXXXXXXXX \",
522 \" . \",
523 \" ... \",
524 \" \",
525 \" \",
526 \" \"
527 };")
528 "A whitespace icon.")
529 )
530
531 (defun whitespace-toolbar-function ()
532 "Calls the function determined by `whitespace-toolbar-function'."
533 (interactive)
534 (call-interactively whitespace-toolbar-function))
535
536 (if (and (adapt-xemacsp)
537 whitespace-install-toolbar-icon
538 (featurep 'toolbar)
539 (eq (device-type (selected-device)) 'x))
540 (add-spec-list-to-specifier
541 default-toolbar
542 '((global
543 (nil
544 [toolbar-file-icon find-file t "Open a file" ]
545 [toolbar-folder-icon dired t "View directory"]
546 [toolbar-disk-icon save-buffer t "Save buffer" ]
547 [toolbar-printer-icon print-buffer t "Print buffer" ]
548 [toolbar-cut-icon x-kill-primary-selection t "Kill region"]
549 [toolbar-copy-icon x-copy-primary-selection t "Copy region"]
550 [toolbar-paste-icon
551 x-yank-clipboard-selection t "Paste from clipboard"]
552 [toolbar-undo-icon undo t "Undo edit" ]
553 [toolbar-replace-icon query-replace t "Replace text" ]
554 [toolbar-wspace-icon
555 whitespace-toolbar-function t "Toggle whitespace mode"]
556 nil
557 [toolbar-compile-icon toolbar-compile t "Compile" ]
558 [toolbar-debug-icon toolbar-debug t "Debug" ]
559 [toolbar-spell-icon toolbar-ispell t "Spellcheck" ]
560 [toolbar-mail-icon toolbar-mail t "Mail" ]
561 [toolbar-news-icon toolbar-news t "News" ]
562 [toolbar-info-icon toolbar-info t "Information" ]
563 )))))
564
565 ;;; whitespace-mode.el ends here