*** empty log message ***
[emacs.git] / lisp / facemenu.el
blob00fb13fe8f993c9e1ef106c96ea15cd5f185a7ce
1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
3 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
6 ;; Author: Boris Goldowsky <boris@gnu.org>
7 ;; Keywords: faces
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
26 ;;; Commentary:
28 ;; This file defines a menu of faces (bold, italic, etc) which allows you to
29 ;; set the face used for a region of the buffer. Some faces also have
30 ;; keybindings, which are shown in the menu.
32 ;; The menu also contains submenus for indentation and justification-changing
33 ;; commands.
35 ;;; Usage:
36 ;; Selecting a face from the menu or typing the keyboard equivalent will
37 ;; change the region to use that face. If you use transient-mark-mode and the
38 ;; region is not active, the face will be remembered and used for the next
39 ;; insertion. It will be forgotten if you move point or make other
40 ;; modifications before inserting or typing anything.
42 ;; Faces can be selected from the keyboard as well.
43 ;; The standard keybindings are M-o (or ESC o) + letter:
44 ;; M-o i = "set italic", M-o b = "set bold", etc.
46 ;;; Customization:
47 ;; An alternative set of keybindings that may be easier to type can be set up
48 ;; using "Alt" or "Hyper" keys. This requires that you either have or create
49 ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key
50 ;; labeled "Alt", but to make it act as an Alt key I have to put this command
51 ;; into my .xinitrc:
52 ;; xmodmap -e "add Mod3 = Alt_L"
53 ;; Or, I can make it into a Hyper key with this:
54 ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
55 ;; Check with local X-perts for how to do it on your system.
56 ;; Then you can define your keybindings with code like this in your .emacs:
57 ;; (setq facemenu-keybindings
58 ;; '((default . [?\H-d])
59 ;; (bold . [?\H-b])
60 ;; (italic . [?\H-i])
61 ;; (bold-italic . [?\H-l])
62 ;; (underline . [?\H-u])))
63 ;; (facemenu-update)
64 ;; (setq facemenu-keymap global-map)
65 ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
66 ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
68 ;; The order of the faces that appear in the menu and their keybindings can be
69 ;; controlled by setting the variables `facemenu-keybindings' and
70 ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents
71 ;; (eg, `region') in `facemenu-unlisted-faces'.
73 ;;; Known Problems:
74 ;; Bold and Italic do not combine to create bold-italic if you select them
75 ;; both, although most other combinations (eg bold + underline + some color)
76 ;; do the intuitive thing.
78 ;; There is at present no way to display what the faces look like in
79 ;; the menu itself.
81 ;; `list-faces-display' shows the faces in a different order than
82 ;; this menu, which could be confusing. I do /not/ sort the list
83 ;; alphabetically, because I like the default order: it puts the most
84 ;; basic, common fonts first.
86 ;; Please send me any other problems, comments or ideas.
88 ;;; Code:
90 (eval-when-compile
91 (require 'help)
92 (require 'button))
94 ;;; Provide some binding for startup:
95 ;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap)
96 ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
98 ;; Global bindings:
99 (define-key global-map [C-down-mouse-2] 'facemenu-menu)
100 (define-key global-map "\M-o" 'facemenu-keymap)
102 (defgroup facemenu nil
103 "Create a face menu for interactively adding fonts to text."
104 :group 'faces
105 :prefix "facemenu-")
107 (defcustom facemenu-keybindings
108 '((default . "d")
109 (bold . "b")
110 (italic . "i")
111 (bold-italic . "l") ; {bold} intersect {italic} = {l}
112 (underline . "u"))
113 "Alist of interesting faces and keybindings.
114 Each element is itself a list: the car is the name of the face,
115 the next element is the key to use as a keyboard equivalent of the menu item;
116 the binding is made in `facemenu-keymap'.
118 The faces specifically mentioned in this list are put at the top of
119 the menu, in the order specified. All other faces which are defined,
120 except for those in `facemenu-unlisted-faces', are listed after them,
121 but get no keyboard equivalents.
123 If you change this variable after loading facemenu.el, you will need to call
124 `facemenu-update' to make it take effect."
125 :type '(repeat (cons face string))
126 :group 'facemenu)
128 (defcustom facemenu-new-faces-at-end t
129 "*Where in the menu to insert newly-created faces.
130 This should be nil to put them at the top of the menu, or t to put them
131 just before \"Other\" at the end."
132 :type 'boolean
133 :group 'facemenu)
135 (defcustom facemenu-unlisted-faces
136 `(modeline region secondary-selection highlight scratch-face
137 ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-")
138 ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-")
139 ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-"))
140 "*List of faces not to include in the Face menu.
141 Each element may be either a symbol, which is the name of a face, or a string,
142 which is a regular expression to be matched against face names. Matching
143 faces will not be added to the menu.
145 You can set this list before loading facemenu.el, or add a face to it before
146 creating that face if you do not want it to be listed. If you change the
147 variable so as to eliminate faces that have already been added to the menu,
148 call `facemenu-update' to recalculate the menu contents.
150 If this variable is t, no faces will be added to the menu. This is useful for
151 temporarily turning off the feature that automatically adds faces to the menu
152 when they are created."
153 :type '(choice (const :tag "Don't add faces" t)
154 (const :tag "None (do add any face)" nil)
155 (repeat (choice symbol regexp)))
156 :group 'facemenu)
158 ;;;###autoload
159 (defvar facemenu-face-menu
160 (let ((map (make-sparse-keymap "Face")))
161 (define-key map "o" (cons "Other..." 'facemenu-set-face))
162 map)
163 "Menu keymap for faces.")
164 ;;;###autoload
165 (defalias 'facemenu-face-menu facemenu-face-menu)
166 (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
168 ;;;###autoload
169 (defvar facemenu-foreground-menu
170 (let ((map (make-sparse-keymap "Foreground Color")))
171 (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
172 map)
173 "Menu keymap for foreground colors.")
174 ;;;###autoload
175 (defalias 'facemenu-foreground-menu facemenu-foreground-menu)
176 (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
178 ;;;###autoload
179 (defvar facemenu-background-menu
180 (let ((map (make-sparse-keymap "Background Color")))
181 (define-key map "o" (cons "Other..." 'facemenu-set-background))
182 map)
183 "Menu keymap for background colors.")
184 ;;;###autoload
185 (defalias 'facemenu-background-menu facemenu-background-menu)
186 (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
188 ;;; Condition for enabling menu items that set faces.
189 (defun facemenu-enable-faces-p ()
190 (not (and font-lock-mode font-lock-defaults)))
192 ;;;###autoload
193 (defvar facemenu-special-menu
194 (let ((map (make-sparse-keymap "Special")))
195 (define-key map [?s] (cons (purecopy "Remove Special")
196 'facemenu-remove-special))
197 (define-key map [?t] (cons (purecopy "Intangible")
198 'facemenu-set-intangible))
199 (define-key map [?v] (cons (purecopy "Invisible")
200 'facemenu-set-invisible))
201 (define-key map [?r] (cons (purecopy "Read-Only")
202 'facemenu-set-read-only))
203 map)
204 "Menu keymap for non-face text-properties.")
205 ;;;###autoload
206 (defalias 'facemenu-special-menu facemenu-special-menu)
208 ;;;###autoload
209 (defvar facemenu-justification-menu
210 (let ((map (make-sparse-keymap "Justification")))
211 (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
212 (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
213 (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
214 (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
215 (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
216 map)
217 "Submenu for text justification commands.")
218 ;;;###autoload
219 (defalias 'facemenu-justification-menu facemenu-justification-menu)
221 ;;;###autoload
222 (defvar facemenu-indentation-menu
223 (let ((map (make-sparse-keymap "Indentation")))
224 (define-key map [decrease-right-margin]
225 (cons (purecopy "Indent Right Less") 'decrease-right-margin))
226 (define-key map [increase-right-margin]
227 (cons (purecopy "Indent Right More") 'increase-right-margin))
228 (define-key map [decrease-left-margin]
229 (cons (purecopy "Indent Less") 'decrease-left-margin))
230 (define-key map [increase-left-margin]
231 (cons (purecopy "Indent More") 'increase-left-margin))
232 map)
233 "Submenu for indentation commands.")
234 ;;;###autoload
235 (defalias 'facemenu-indentation-menu facemenu-indentation-menu)
237 ;; This is split up to avoid an overlong line in loaddefs.el.
238 ;;;###autoload
239 (defvar facemenu-menu nil
240 "Facemenu top-level menu keymap.")
241 ;;;###autoload
242 (setq facemenu-menu (make-sparse-keymap "Text Properties"))
243 ;;;###autoload
244 (let ((map facemenu-menu))
245 (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
246 (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
247 (define-key map [dp] (cons (purecopy "Describe Properties")
248 'describe-text-properties))
249 (define-key map [ra] (cons (purecopy "Remove Text Properties")
250 'facemenu-remove-all))
251 (define-key map [rm] (cons (purecopy "Remove Face Properties")
252 'facemenu-remove-face-props))
253 (define-key map [s1] (list (purecopy "--"))))
254 ;;;###autoload
255 (let ((map facemenu-menu))
256 (define-key map [in] (cons (purecopy "Indentation")
257 'facemenu-indentation-menu))
258 (define-key map [ju] (cons (purecopy "Justification")
259 'facemenu-justification-menu))
260 (define-key map [s2] (list (purecopy "--")))
261 (define-key map [sp] (cons (purecopy "Special Properties")
262 'facemenu-special-menu))
263 (define-key map [bg] (cons (purecopy "Background Color")
264 'facemenu-background-menu))
265 (define-key map [fg] (cons (purecopy "Foreground Color")
266 'facemenu-foreground-menu))
267 (define-key map [fc] (cons (purecopy "Face")
268 'facemenu-face-menu)))
269 ;;;###autoload
270 (defalias 'facemenu-menu facemenu-menu)
272 (defvar facemenu-keymap
273 (let ((map (make-sparse-keymap "Set face")))
274 (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
275 map)
276 "Keymap for face-changing commands.
277 `Facemenu-update' fills in the keymap according to the bindings
278 requested in `facemenu-keybindings'.")
279 (defalias 'facemenu-keymap facemenu-keymap)
282 (defcustom facemenu-add-face-function nil
283 "Function called at beginning of text to change or nil.
284 This function is passed the FACE to set and END of text to change, and must
285 return a string which is inserted. It may set `facemenu-end-add-face'."
286 :type '(choice (const :tag "None" nil)
287 function)
288 :group 'facemenu)
290 (defcustom facemenu-end-add-face nil
291 "String to insert or function called at end of text to change or nil.
292 This function is passed the FACE to set, and must return a string which is
293 inserted."
294 :type '(choice (const :tag "None" nil)
295 string
296 function)
297 :group 'facemenu)
299 (defcustom facemenu-remove-face-function nil
300 "When non-nil, this is a function called to remove faces.
301 This function is passed the START and END of text to change.
302 May also be t meaning to use `facemenu-add-face-function'."
303 :type '(choice (const :tag "None" nil)
304 (const :tag "Use add-face" t)
305 function)
306 :group 'facemenu)
308 ;;; Internal Variables
310 (defvar facemenu-color-alist nil
311 ;; Don't initialize here; that doesn't work if preloaded.
312 "Alist of colors, used for completion.
313 If null, `facemenu-read-color' will set it.")
315 (defun facemenu-update ()
316 "Add or update the \"Face\" menu in the menu bar.
317 You can call this to update things if you change any of the menu configuration
318 variables."
319 (interactive)
321 ;; Add each defined face to the menu.
322 (facemenu-iterate 'facemenu-add-new-face
323 (facemenu-complete-face-list facemenu-keybindings)))
325 ;;;###autoload
326 (defun facemenu-set-face (face &optional start end)
327 "Add FACE to the region or next character typed.
328 This adds FACE to the top of the face list; any faces lower on the list that
329 will not show through at all will be removed.
331 Interactively, reads the face name with the minibuffer.
333 If the region is active (normally true except in Transient Mark mode)
334 and there is no prefix argument, this command sets the region to the
335 requested face.
337 Otherwise, this command specifies the face for the next character
338 inserted. Moving point or switching buffers before
339 typing a character to insert cancels the specification."
340 (interactive (list (progn
341 (barf-if-buffer-read-only)
342 (read-face-name "Use face"))
343 (if (and mark-active (not current-prefix-arg))
344 (region-beginning))
345 (if (and mark-active (not current-prefix-arg))
346 (region-end))))
347 (facemenu-add-new-face face)
348 (facemenu-add-face face start end))
350 ;;;###autoload
351 (defun facemenu-set-foreground (color &optional start end)
352 "Set the foreground COLOR of the region or next character typed.
353 This command reads the color in the minibuffer.
355 If the region is active (normally true except in Transient Mark mode)
356 and there is no prefix argument, this command sets the region to the
357 requested face.
359 Otherwise, this command specifies the face for the next character
360 inserted. Moving point or switching buffers before
361 typing a character to insert cancels the specification."
362 (interactive (list (progn
363 (barf-if-buffer-read-only)
364 (facemenu-read-color "Foreground color: "))
365 (if (and mark-active (not current-prefix-arg))
366 (region-beginning))
367 (if (and mark-active (not current-prefix-arg))
368 (region-end))))
369 (facemenu-set-face-from-menu
370 (facemenu-add-new-color color 'facemenu-foreground-menu)
371 start end))
373 ;;;###autoload
374 (defun facemenu-set-background (color &optional start end)
375 "Set the background COLOR of the region or next character typed.
376 This command reads the color in the minibuffer.
378 If the region is active (normally true except in Transient Mark mode)
379 and there is no prefix argument, this command sets the region to the
380 requested face.
382 Otherwise, this command specifies the face for the next character
383 inserted. Moving point or switching buffers before
384 typing a character to insert cancels the specification."
385 (interactive (list (progn
386 (barf-if-buffer-read-only)
387 (facemenu-read-color "Background color: "))
388 (if (and mark-active (not current-prefix-arg))
389 (region-beginning))
390 (if (and mark-active (not current-prefix-arg))
391 (region-end))))
392 (facemenu-set-face-from-menu
393 (facemenu-add-new-color color 'facemenu-background-menu)
394 start end))
396 ;;;###autoload
397 (defun facemenu-set-face-from-menu (face start end)
398 "Set the FACE of the region or next character typed.
399 This function is designed to be called from a menu; FACE is determined
400 using the event type of the menu entry. If FACE is a symbol whose
401 name starts with \"fg:\" or \"bg:\", then this functions sets the
402 foreground or background to the color specified by the rest of the
403 symbol's name. Any other symbol is considered the name of a face.
405 If the region is active (normally true except in Transient Mark mode)
406 and there is no prefix argument, this command sets the region to the
407 requested face.
409 Otherwise, this command specifies the face for the next character
410 inserted. Moving point or switching buffers before typing a character
411 to insert cancels the specification."
412 (interactive (list last-command-event
413 (if (and mark-active (not current-prefix-arg))
414 (region-beginning))
415 (if (and mark-active (not current-prefix-arg))
416 (region-end))))
417 (barf-if-buffer-read-only)
418 (facemenu-add-face
419 (let ((fn (symbol-name face)))
420 (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn)
421 (list (list (if (string= (match-string 1 fn) "f")
422 :foreground
423 :background)
424 (match-string 2 fn)))
425 face))
426 start end))
428 ;;;###autoload
429 (defun facemenu-set-invisible (start end)
430 "Make the region invisible.
431 This sets the `invisible' text property; it can be undone with
432 `facemenu-remove-special'."
433 (interactive "r")
434 (add-text-properties start end '(invisible t)))
436 ;;;###autoload
437 (defun facemenu-set-intangible (start end)
438 "Make the region intangible: disallow moving into it.
439 This sets the `intangible' text property; it can be undone with
440 `facemenu-remove-special'."
441 (interactive "r")
442 (add-text-properties start end '(intangible t)))
444 ;;;###autoload
445 (defun facemenu-set-read-only (start end)
446 "Make the region unmodifiable.
447 This sets the `read-only' text property; it can be undone with
448 `facemenu-remove-special'."
449 (interactive "r")
450 (add-text-properties start end '(read-only t)))
452 ;;;###autoload
453 (defun facemenu-remove-face-props (start end)
454 "Remove `face' and `mouse-face' text properties."
455 (interactive "*r") ; error if buffer is read-only despite the next line.
456 (let ((inhibit-read-only t))
457 (remove-text-properties
458 start end '(face nil mouse-face nil))))
460 ;;;###autoload
461 (defun facemenu-remove-all (start end)
462 "Remove all text properties from the region."
463 (interactive "*r") ; error if buffer is read-only despite the next line.
464 (let ((inhibit-read-only t))
465 (set-text-properties start end nil)))
467 ;;;###autoload
468 (defun facemenu-remove-special (start end)
469 "Remove all the \"special\" text properties from the region.
470 These special properties include `invisible', `intangible' and `read-only'."
471 (interactive "*r") ; error if buffer is read-only despite the next line.
472 (let ((inhibit-read-only t))
473 (remove-text-properties
474 start end '(invisible nil intangible nil read-only nil))))
476 ;;;###autoload
477 (defun facemenu-read-color (&optional prompt)
478 "Read a color using the minibuffer."
479 (let* ((completion-ignore-case t)
480 (col (completing-read (or prompt "Color: ")
481 (or facemenu-color-alist
482 (defined-colors))
483 nil t)))
484 (if (equal "" col)
486 col)))
488 ;;;###autoload
489 (defun list-colors-display (&optional list buffer-name)
490 "Display names of defined colors, and show what they look like.
491 If the optional argument LIST is non-nil, it should be a list of
492 colors to display. Otherwise, this command computes a list of
493 colors that the current display can handle. If the optional
494 argument BUFFER-NAME is nil, it defaults to *Colors*."
495 (interactive)
496 (when (and (null list) (> (display-color-cells) 0))
497 (setq list (list-colors-duplicates (defined-colors)))
498 (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
499 ;; Don't show more than what the display can handle.
500 (let ((lc (nthcdr (1- (display-color-cells)) list)))
501 (if lc
502 (setcdr lc nil)))))
503 (with-output-to-temp-buffer (or buffer-name "*Colors*")
504 (save-excursion
505 (set-buffer standard-output)
506 (setq truncate-lines t)
507 (if temp-buffer-show-function
508 (list-colors-print list)
509 ;; Call list-colors-print from temp-buffer-show-hook
510 ;; to get the right value of window-width in list-colors-print
511 ;; after the buffer is displayed.
512 (add-hook 'temp-buffer-show-hook
513 (lambda () (list-colors-print list)) nil t)))))
515 (defun list-colors-print (list)
516 (dolist (color list)
517 (if (consp color)
518 (if (cdr color)
519 (setq color (sort color (lambda (a b)
520 (string< (downcase a)
521 (downcase b))))))
522 (setq color (list color)))
523 (put-text-property
524 (prog1 (point)
525 (insert (car color))
526 (indent-to 22))
527 (point)
528 'face (cons 'background-color (car color)))
529 (put-text-property
530 (prog1 (point)
531 (insert " " (if (cdr color)
532 (mapconcat 'identity (cdr color) ", ")
533 (car color))))
534 (point)
535 'face (cons 'foreground-color (car color)))
536 (indent-to (max (- (window-width) 8) 44))
537 (insert (apply 'format "#%02x%02x%02x"
538 (mapcar (lambda (c) (lsh c -8))
539 (color-values (car color)))))
541 (insert "\n"))
542 (goto-char (point-min)))
544 (defun list-colors-duplicates (&optional list)
545 "Return a list of colors with grouped duplicate colors.
546 If a color has no duplicates, then the element of the returned list
547 has the form '(COLOR-NAME). The element of the returned list with
548 duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
549 This function uses the predicate `facemenu-color-equal' to compare
550 color names. If the optional argument LIST is non-nil, it should
551 be a list of colors to display. Otherwise, this function uses
552 a list of colors that the current display can handle."
553 (let* ((list (mapcar 'list (or list (defined-colors))))
554 (l list))
555 (while (cdr l)
556 (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
557 (not (if (boundp 'w32-default-color-map)
558 (not (assoc (car (car l)) w32-default-color-map)))))
559 (progn
560 (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
561 (setcdr l (cdr (cdr l))))
562 (setq l (cdr l))))
563 list))
565 (defun facemenu-color-equal (a b)
566 "Return t if colors A and B are the same color.
567 A and B should be strings naming colors.
568 This function queries the display system to find out what the color
569 names mean. It returns nil if the colors differ or if it can't
570 determine the correct answer."
571 (cond ((equal a b) t)
572 ((equal (color-values a) (color-values b)))))
574 (defun facemenu-add-face (face &optional start end)
575 "Add FACE to text between START and END.
576 If START is nil or START to END is empty, add FACE to next typed character
577 instead. For each section of that region that has a different face property,
578 FACE will be consed onto it, and other faces that are completely hidden by
579 that will be removed from the list.
580 If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
581 they are used to set the face information.
583 As a special case, if FACE is `default', then the region is left with NO face
584 text property. Otherwise, selecting the default face would not have any
585 effect. See `facemenu-remove-face-function'."
586 (interactive "*xFace: \nr")
587 (if (and (eq face 'default)
588 (not (eq facemenu-remove-face-function t)))
589 (if facemenu-remove-face-function
590 (funcall facemenu-remove-face-function start end)
591 (if (and start (< start end))
592 (remove-text-properties start end '(face default))
593 (setq self-insert-face 'default
594 self-insert-face-command this-command)))
595 (if facemenu-add-face-function
596 (save-excursion
597 (if end (goto-char end))
598 (save-excursion
599 (if start (goto-char start))
600 (insert-before-markers
601 (funcall facemenu-add-face-function face end)))
602 (if facemenu-end-add-face
603 (insert (if (stringp facemenu-end-add-face)
604 facemenu-end-add-face
605 (funcall facemenu-end-add-face face)))))
606 (if (and start (< start end))
607 (let ((part-start start) part-end)
608 (while (not (= part-start end))
609 (setq part-end (next-single-property-change part-start 'face
610 nil end))
611 (let ((prev (get-text-property part-start 'face)))
612 (put-text-property part-start part-end 'face
613 (if (null prev)
614 face
615 (facemenu-active-faces
616 (cons face
617 (if (listp prev)
618 prev
619 (list prev)))))))
620 (setq part-start part-end)))
621 (setq self-insert-face (if (eq last-command self-insert-face-command)
622 (cons face (if (listp self-insert-face)
623 self-insert-face
624 (list self-insert-face)))
625 face)
626 self-insert-face-command this-command))))
627 (unless (facemenu-enable-faces-p)
628 (message "Font-lock mode will override any faces you set in this buffer")))
630 (defun facemenu-active-faces (face-list &optional frame)
631 "Return from FACE-LIST those faces that would be used for display.
632 This means each face attribute is not specified in a face earlier in FACE-LIST
633 and such a face is therefore active when used to display text.
634 If the optional argument FRAME is given, use the faces in that frame; otherwise
635 use the selected frame. If t, then the global, non-frame faces are used."
636 (let* ((mask-atts (copy-sequence
637 (if (consp (car face-list))
638 (face-attributes-as-vector (car face-list))
639 (or (internal-lisp-face-p (car face-list) frame)
640 (check-face (car face-list))))))
641 (active-list (list (car face-list)))
642 (face-list (cdr face-list))
643 (mask-len (length mask-atts)))
644 (while face-list
645 (if (let ((face-atts
646 (if (consp (car face-list))
647 (face-attributes-as-vector (car face-list))
648 (or (internal-lisp-face-p (car face-list) frame)
649 (check-face (car face-list)))))
650 (i mask-len)
651 (useful nil))
652 (while (>= (setq i (1- i)) 0)
653 (and (not (memq (aref face-atts i) '(nil unspecified)))
654 (memq (aref mask-atts i) '(nil unspecified))
655 (aset mask-atts i (setq useful t))))
656 useful)
657 (setq active-list (cons (car face-list) active-list)))
658 (setq face-list (cdr face-list)))
659 (nreverse active-list)))
661 (defun facemenu-add-new-face (face)
662 "Add FACE (a face) to the Face menu.
664 This is called whenever you create a new face."
665 (let* (name
666 symbol
667 menu docstring
668 (key (cdr (assoc face facemenu-keybindings)))
669 function menu-val)
670 (if (symbolp face)
671 (setq name (symbol-name face)
672 symbol face)
673 (setq name face
674 symbol (intern name)))
675 (setq menu 'facemenu-face-menu)
676 (setq docstring
677 (format "Select face `%s' for subsequent insertion."
678 name))
679 (cond ((eq t facemenu-unlisted-faces))
680 ((memq symbol facemenu-unlisted-faces))
681 ;; test against regexps in facemenu-unlisted-faces
682 ((let ((unlisted facemenu-unlisted-faces)
683 (matched nil))
684 (while (and unlisted (not matched))
685 (if (and (stringp (car unlisted))
686 (string-match (car unlisted) name))
687 (setq matched t)
688 (setq unlisted (cdr unlisted))))
689 matched))
690 (key ; has a keyboard equivalent. These go at the front.
691 (setq function (intern (concat "facemenu-set-" name)))
692 (fset function
693 `(lambda ()
694 ,docstring
695 (interactive)
696 (facemenu-set-face
697 (quote ,symbol)
698 (if (and mark-active (not current-prefix-arg))
699 (region-beginning))
700 (if (and mark-active (not current-prefix-arg))
701 (region-end)))))
702 (define-key 'facemenu-keymap key (cons name function))
703 (define-key menu key (cons name function)))
704 ((facemenu-iterate ; check if equivalent face is already in the menu
705 (lambda (m) (and (listp m)
706 (symbolp (car m))
707 (face-equal (car m) symbol)))
708 (cdr (symbol-function menu))))
709 (t ; No keyboard equivalent. Figure out where to put it:
710 (setq key (vector symbol)
711 function 'facemenu-set-face-from-menu
712 menu-val (symbol-function menu))
713 (if (and facemenu-new-faces-at-end
714 (> (length menu-val) 3))
715 (define-key-after menu-val key (cons name function)
716 (car (nth (- (length menu-val) 3) menu-val)))
717 (define-key menu key (cons name function))))))
718 nil) ; Return nil for facemenu-iterate
720 (defun facemenu-add-new-color (color menu)
721 "Add COLOR (a color name string) to the appropriate Face menu.
722 MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
723 Return the event type (a symbol) of the added menu entry.
725 This is called whenever you use a new color."
726 (let (symbol docstring)
727 (unless (color-defined-p color)
728 (error "Color `%s' undefined" color))
729 (cond ((eq menu 'facemenu-foreground-menu)
730 (setq docstring
731 (format "Select foreground color %s for subsequent insertion."
732 color)
733 symbol (intern (concat "fg:" color))))
734 ((eq menu 'facemenu-background-menu)
735 (setq docstring
736 (format "Select background color %s for subsequent insertion."
737 color)
738 symbol (intern (concat "bg:" color))))
739 (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
740 (unless (facemenu-iterate ; Check if color is already in the menu.
741 (lambda (m) (and (listp m)
742 (eq (car m) symbol)))
743 (cdr (symbol-function menu)))
744 ;; Color is not in the menu. Figure out where to put it.
745 (let ((key (vector symbol))
746 (function 'facemenu-set-face-from-menu)
747 (menu-val (symbol-function menu)))
748 (if (and facemenu-new-faces-at-end
749 (> (length menu-val) 3))
750 (define-key-after menu-val key (cons color function)
751 (car (nth (- (length menu-val) 3) menu-val)))
752 (define-key menu key (cons color function)))))
753 symbol))
755 (defun facemenu-complete-face-list (&optional oldlist)
756 "Return list of all faces that look different.
757 Starts with given ALIST of faces, and adds elements only if they display
758 differently from any face already on the list.
759 The faces on ALIST will end up at the end of the returned list, in reverse
760 order."
761 (let ((list (nreverse (mapcar 'car oldlist))))
762 (facemenu-iterate
763 (lambda (new-face)
764 (if (not (memq new-face list))
765 (setq list (cons new-face list)))
766 nil)
767 (nreverse (face-list)))
768 list))
770 (defun facemenu-iterate (func list)
771 "Apply FUNC to each element of LIST until one returns non-nil.
772 Returns the non-nil value it found, or nil if all were nil."
773 (while (and list (not (funcall func (car list))))
774 (setq list (cdr list)))
775 (car list))
777 (facemenu-update)
779 (provide 'facemenu)
781 ;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
782 ;;; facemenu.el ends here