1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
3 ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.
5 ;; Author: Boris Goldowsky <boris@gnu.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; This file defines a menu of faces (bold, italic, etc) which allows you to
28 ;; set the face used for a region of the buffer. Some faces also have
29 ;; keybindings, which are shown in the menu.
31 ;; The menu also contains submenus for indentation and justification-changing
35 ;; Selecting a face from the menu or typing the keyboard equivalent will
36 ;; change the region to use that face. If you use transient-mark-mode and the
37 ;; region is not active, the face will be remembered and used for the next
38 ;; insertion. It will be forgotten if you move point or make other
39 ;; modifications before inserting or typing anything.
41 ;; Faces can be selected from the keyboard as well.
42 ;; The standard keybindings are M-g (or ESC g) + letter:
43 ;; M-g i = "set italic", M-g b = "set bold", etc.
46 ;; An alternative set of keybindings that may be easier to type can be set up
47 ;; using "Alt" or "Hyper" keys. This requires that you either have or create
48 ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key
49 ;; labeled "Alt", but to make it act as an Alt key I have to put this command
51 ;; xmodmap -e "add Mod3 = Alt_L"
52 ;; Or, I can make it into a Hyper key with this:
53 ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
54 ;; Check with local X-perts for how to do it on your system.
55 ;; Then you can define your keybindings with code like this in your .emacs:
56 ;; (setq facemenu-keybindings
57 ;; '((default . [?\H-d])
60 ;; (bold-italic . [?\H-l])
61 ;; (underline . [?\H-u])))
63 ;; (setq facemenu-keymap global-map)
64 ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
65 ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
67 ;; The order of the faces that appear in the menu and their keybindings can be
68 ;; controlled by setting the variables `facemenu-keybindings' and
69 ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents
70 ;; (eg, `region') in `facemenu-unlisted-faces'.
73 ;; Bold and Italic do not combine to create bold-italic if you select them
74 ;; both, although most other combinations (eg bold + underline + some color)
75 ;; do the intuitive thing.
77 ;; There is at present no way to display what the faces look like in
80 ;; `list-faces-display' shows the faces in a different order than
81 ;; this menu, which could be confusing. I do /not/ sort the list
82 ;; alphabetically, because I like the default order: it puts the most
83 ;; basic, common fonts first.
85 ;; Please send me any other problems, comments or ideas.
96 ;;; Provide some binding for startup:
97 ;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap)
98 ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
101 (define-key global-map
[C-down-mouse-2
] 'facemenu-menu
)
102 (define-key global-map
"\M-g" 'facemenu-keymap
)
104 (defgroup facemenu nil
105 "Create a face menu for interactively adding fonts to text"
109 (defcustom facemenu-keybindings
113 (bold-italic .
"l") ; {bold} intersect {italic} = {l}
115 "Alist of interesting faces and keybindings.
116 Each element is itself a list: the car is the name of the face,
117 the next element is the key to use as a keyboard equivalent of the menu item;
118 the binding is made in `facemenu-keymap'.
120 The faces specifically mentioned in this list are put at the top of
121 the menu, in the order specified. All other faces which are defined,
122 except for those in `facemenu-unlisted-faces', are listed after them,
123 but get no keyboard equivalents.
125 If you change this variable after loading facemenu.el, you will need to call
126 `facemenu-update' to make it take effect."
127 :type
'(repeat (cons face string
))
130 (defcustom facemenu-new-faces-at-end t
131 "*Where in the menu to insert newly-created faces.
132 This should be nil to put them at the top of the menu, or t to put them
133 just before \"Other\" at the end."
137 (defcustom facemenu-unlisted-faces
138 `(modeline region secondary-selection highlight scratch-face
139 ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-")
140 ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-")
141 ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-"))
142 "*List of faces not to include in the Face menu.
143 Each element may be either a symbol, which is the name of a face, or a string,
144 which is a regular expression to be matched against face names. Matching
145 faces will not be added to the menu.
147 You can set this list before loading facemenu.el, or add a face to it before
148 creating that face if you do not want it to be listed. If you change the
149 variable so as to eliminate faces that have already been added to the menu,
150 call `facemenu-update' to recalculate the menu contents.
152 If this variable is t, no faces will be added to the menu. This is useful for
153 temporarily turning off the feature that automatically adds faces to the menu
154 when they are created."
155 :type
'(choice (const :tag
"Don't add faces" t
)
156 (const :tag
"None (do add any face)" nil
)
157 (repeat (choice symbol regexp
)))
161 (defvar facemenu-face-menu
162 (let ((map (make-sparse-keymap "Face")))
163 (define-key map
"o" (cons "Other..." 'facemenu-set-face
))
165 "Menu keymap for faces.")
167 (defalias 'facemenu-face-menu facemenu-face-menu
)
170 (defvar facemenu-foreground-menu
171 (let ((map (make-sparse-keymap "Foreground Color")))
172 (define-key map
"o" (cons "Other..." 'facemenu-set-foreground
))
174 "Menu keymap for foreground colors.")
176 (defalias 'facemenu-foreground-menu facemenu-foreground-menu
)
179 (defvar facemenu-background-menu
180 (let ((map (make-sparse-keymap "Background Color")))
181 (define-key map
"o" (cons "Other..." 'facemenu-set-background
))
183 "Menu keymap for background colors.")
185 (defalias 'facemenu-background-menu facemenu-background-menu
)
188 (defvar facemenu-special-menu
189 (let ((map (make-sparse-keymap "Special")))
190 (define-key map
[?s
] (cons (purecopy "Remove Special")
191 'facemenu-remove-special
))
192 (define-key map
[?t
] (cons (purecopy "Intangible")
193 'facemenu-set-intangible
))
194 (define-key map
[?v
] (cons (purecopy "Invisible")
195 'facemenu-set-invisible
))
196 (define-key map
[?r
] (cons (purecopy "Read-Only")
197 'facemenu-set-read-only
))
199 "Menu keymap for non-face text-properties.")
201 (defalias 'facemenu-special-menu facemenu-special-menu
)
204 (defvar facemenu-justification-menu
205 (let ((map (make-sparse-keymap "Justification")))
206 (define-key map
[?c
] (cons (purecopy "Center") 'set-justification-center
))
207 (define-key map
[?b
] (cons (purecopy "Full") 'set-justification-full
))
208 (define-key map
[?r
] (cons (purecopy "Right") 'set-justification-right
))
209 (define-key map
[?l
] (cons (purecopy "Left") 'set-justification-left
))
210 (define-key map
[?u
] (cons (purecopy "Unfilled") 'set-justification-none
))
212 "Submenu for text justification commands.")
214 (defalias 'facemenu-justification-menu facemenu-justification-menu
)
217 (defvar facemenu-indentation-menu
218 (let ((map (make-sparse-keymap "Indentation")))
219 (define-key map
[decrease-right-margin
]
220 (cons (purecopy "Indent Right Less") 'decrease-right-margin
))
221 (define-key map
[increase-right-margin
]
222 (cons (purecopy "Indent Right More") 'increase-right-margin
))
223 (define-key map
[decrease-left-margin
]
224 (cons (purecopy "Indent Less") 'decrease-left-margin
))
225 (define-key map
[increase-left-margin
]
226 (cons (purecopy "Indent More") 'increase-left-margin
))
228 "Submenu for indentation commands.")
230 (defalias 'facemenu-indentation-menu facemenu-indentation-menu
)
232 ;; This is split up to avoid an overlong line in loaddefs.el.
234 (defvar facemenu-menu nil
235 "Facemenu top-level menu keymap.")
237 (setq facemenu-menu
(make-sparse-keymap "Text Properties"))
239 (let ((map facemenu-menu
))
240 (define-key map
[dc] (cons (purecopy "Display Colors") 'list-colors-display))
241 (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
242 (define-key map [dp] (cons (purecopy "Describe Text")
244 (define-key map [ra] (cons (purecopy "Remove Text Properties")
245 'facemenu-remove-all))
246 (define-key map [rm] (cons (purecopy "Remove Face Properties")
247 'facemenu-remove-face-props))
248 (define-key map [s1] (list (purecopy "--"))))
250 (let ((map facemenu-menu))
251 (define-key map [in] (cons (purecopy "Indentation")
252 'facemenu-indentation-menu))
253 (define-key map [ju] (cons (purecopy "Justification")
254 'facemenu-justification-menu))
255 (define-key map [s2] (list (purecopy "--")))
256 (define-key map [sp] (cons (purecopy "Special Properties")
257 'facemenu-special-menu))
258 (define-key map [bg] (cons (purecopy "Background Color")
259 'facemenu-background-menu))
260 (define-key map [fg] (cons (purecopy "Foreground Color")
261 'facemenu-foreground-menu))
262 (define-key map [fc] (cons (purecopy "Face")
263 'facemenu-face-menu)))
265 (defalias 'facemenu-menu facemenu-menu)
267 (defvar facemenu-keymap
268 (let ((map (make-sparse-keymap "Set face")))
269 (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
271 "Keymap for face-changing commands.
272 `Facemenu-update' fills in the keymap according to the bindings
273 requested in `facemenu-keybindings'.")
274 (defalias 'facemenu-keymap facemenu-keymap)
277 (defcustom facemenu-add-face-function nil
278 "Function called at beginning of text to change or nil.
279 This function is passed the FACE to set and END of text to change, and must
280 return a string which is inserted. It may set `facemenu-end-add-face'."
281 :type '(choice (const :tag "None" nil)
285 (defcustom facemenu-end-add-face nil
286 "String to insert or function called at end of text to change or nil.
287 This function is passed the FACE to set, and must return a string which is
289 :type '(choice (const :tag "None" nil)
294 (defcustom facemenu-remove-face-function nil
295 "When non-nil, this is a function called to remove faces.
296 This function is passed the START and END of text to change.
297 May also be t meaning to use `facemenu-add-face-function'."
298 :type '(choice (const :tag "None" nil)
299 (const :tag "Use add-face" t)
303 ;;; Internal Variables
305 (defvar facemenu-color-alist nil
306 ;; Don't initialize here; that doesn't work if preloaded.
307 "Alist of colors, used for completion.
308 If null, `facemenu-read-color' will set it.")
310 (defun facemenu-update ()
311 "Add or update the \"Face\" menu in the menu bar.
312 You can call this to update things if you change any of the menu configuration
316 ;; Add each defined face to the menu.
317 (facemenu-iterate 'facemenu-add-new-face
318 (facemenu-complete-face-list facemenu-keybindings)))
321 (defun facemenu-set-face (face &optional start end)
322 "Add FACE to the region or next character typed.
323 This adds FACE to the top of the face list; any faces lower on the list that
324 will not show through at all will be removed.
326 Interactively, reads the face name with the minibuffer.
328 If the region is active (normally true except in Transient Mark mode)
329 and there is no prefix argument, this command sets the region to the
332 Otherwise, this command specifies the face for the next character
333 inserted. Moving point or switching buffers before
334 typing a character to insert cancels the specification."
335 (interactive (list (progn
336 (barf-if-buffer-read-only)
337 (read-face-name "Use face"))
338 (if (and mark-active (not current-prefix-arg))
340 (if (and mark-active (not current-prefix-arg))
342 (facemenu-add-new-face face)
343 (facemenu-add-face face start end))
346 (defun facemenu-set-foreground (color &optional start end)
347 "Set the foreground COLOR of the region or next character typed.
348 This command reads the color in the minibuffer.
350 If the region is active (normally true except in Transient Mark mode)
351 and there is no prefix argument, this command sets the region to the
354 Otherwise, this command specifies the face for the next character
355 inserted. Moving point or switching buffers before
356 typing a character to insert cancels the specification."
357 (interactive (list (progn
358 (barf-if-buffer-read-only)
359 (facemenu-read-color "Foreground color: "))
360 (if (and mark-active (not current-prefix-arg))
362 (if (and mark-active (not current-prefix-arg))
364 (unless (color-defined-p color)
365 (message "Color `%s' undefined" color))
366 (facemenu-add-new-color color 'facemenu-foreground-menu)
367 (facemenu-add-face (list (list :foreground color)) start end))
370 (defun facemenu-set-background (color &optional start end)
371 "Set the background COLOR of the region or next character typed.
372 This command reads the color in the minibuffer.
374 If the region is active (normally true except in Transient Mark mode)
375 and there is no prefix argument, this command sets the region to the
378 Otherwise, this command specifies the face for the next character
379 inserted. Moving point or switching buffers before
380 typing a character to insert cancels the specification."
381 (interactive (list (progn
382 (barf-if-buffer-read-only)
383 (facemenu-read-color "Background color: "))
384 (if (and mark-active (not current-prefix-arg))
386 (if (and mark-active (not current-prefix-arg))
388 (unless (color-defined-p color)
389 (message "Color `%s' undefined" color))
390 (facemenu-add-new-color color 'facemenu-background-menu)
391 (facemenu-add-face (list (list :background color)) start end))
394 (defun facemenu-set-face-from-menu (face start end)
395 "Set the FACE of the region or next character typed.
396 This function is designed to be called from a menu; the face to use
397 is the menu item's name.
399 If the region is active (normally true except in Transient Mark mode)
400 and there is no prefix argument, this command sets the region to the
403 Otherwise, this command specifies the face for the next character
404 inserted. Moving point or switching buffers before
405 typing a character to insert cancels the specification."
406 (interactive (list last-command-event
407 (if (and mark-active (not current-prefix-arg))
409 (if (and mark-active (not current-prefix-arg))
411 (barf-if-buffer-read-only)
412 (facemenu-get-face face)
414 (facemenu-add-face face start end)
415 (facemenu-add-face face)))
418 (defun facemenu-set-invisible (start end)
419 "Make the region invisible.
420 This sets the `invisible' text property; it can be undone with
421 `facemenu-remove-special'."
423 (add-text-properties start end '(invisible t)))
426 (defun facemenu-set-intangible (start end)
427 "Make the region intangible: disallow moving into it.
428 This sets the `intangible' text property; it can be undone with
429 `facemenu-remove-special'."
431 (add-text-properties start end '(intangible t)))
434 (defun facemenu-set-read-only (start end)
435 "Make the region unmodifiable.
436 This sets the `read-only' text property; it can be undone with
437 `facemenu-remove-special'."
439 (add-text-properties start end '(read-only t)))
442 (defun facemenu-remove-face-props (start end)
443 "Remove `face' and `mouse-face' text properties."
444 (interactive "*r") ; error if buffer is read-only despite the next line.
445 (let ((inhibit-read-only t))
446 (remove-text-properties
447 start end '(face nil mouse-face nil))))
450 (defun facemenu-remove-all (start end)
451 "Remove all text properties from the region."
452 (interactive "*r") ; error if buffer is read-only despite the next line.
453 (let ((inhibit-read-only t))
454 (set-text-properties start end nil)))
457 (defun facemenu-remove-special (start end)
458 "Remove all the \"special\" text properties from the region.
459 These special properties include `invisible', `intangible' and `read-only'."
460 (interactive "*r") ; error if buffer is read-only despite the next line.
461 (let ((inhibit-read-only t))
462 (remove-text-properties
463 start end '(invisible nil intangible nil read-only nil))))
465 ;;; Describe-Text Mode.
467 (defun describe-text-done ()
468 "Delete the current window or bury the current buffer."
470 (if (> (count-windows) 1)
474 (defvar describe-text-mode-map
475 (let ((map (make-sparse-keymap)))
476 (set-keymap-parent map widget-keymap)
478 "Keymap for `describe-text-mode'.")
480 (defcustom describe-text-mode-hook nil
481 "List of hook functions ran by `describe-text-mode'."
484 (defun describe-text-mode ()
485 "Major mode for buffers created by `describe-text-at'.
487 \\{describe-text-mode-map}
488 Entry to this mode calls the value of `describe-text-mode-hook'
489 if that value is non-nil."
490 (kill-all-local-variables)
491 (setq major-mode 'describe-text-mode
492 mode-name "Describe-Text")
493 (use-local-map describe-text-mode-map)
495 (run-hooks 'describe-text-mode-hook))
497 ;;; Describe-Text Utilities.
499 (defun describe-text-widget (widget)
500 "Insert text to describe WIDGET in the current buffer."
502 :notify `(lambda (&rest ignore)
503 (widget-browse ',widget))
504 (format "%S" (if (symbolp widget)
508 (widget-create 'info-link :tag "widget" "(widget)Top"))
510 (defun describe-text-sexp (sexp)
511 "Insert a short description of SEXP in the current buffer."
512 (let ((pp (condition-case signal
514 (error (prin1-to-string signal)))))
515 (when (string-match "\n\\'" pp)
516 (setq pp (substring pp 0 (1- (length pp)))))
517 (if (cond ((string-match "\n" pp)
519 ((> (length pp) (- (window-width) (current-column)))
523 (widget-create 'push-button
525 :action (lambda (widget &optional event)
526 (with-output-to-temp-buffer
528 (princ (widget-get widget :value))))
532 (defun describe-text-properties (properties)
533 "Insert a description of PROPERTIES in the current buffer.
534 PROPERTIES should be a list of overlay or text properties.
535 The `category' property is made into a widget button that call
536 `describe-text-category' when pushed."
538 (widget-insert (format " %-20s " (car properties)))
539 (let ((key (nth 0 properties))
540 (value (nth 1 properties)))
541 (cond ((eq key 'category)
543 :notify `(lambda (&rest ignore)
544 (describe-text-category ',value))
545 (format "%S" value)))
547 (describe-text-widget value))
549 (describe-text-sexp value))))
551 (setq properties (cdr (cdr properties)))))
553 ;;; Describe-Text Commands.
555 (defun describe-text-category (category)
556 "Describe a text property category."
558 (when (get-buffer "*Text Category*")
559 (kill-buffer "*Text Category*"))
561 (with-output-to-temp-buffer "*Text Category*"
562 (set-buffer "*Text Category*")
563 (widget-insert "Category " (format "%S" category) ":\n\n")
564 (describe-text-properties (symbol-plist category))
566 (goto-char (point-min)))))
569 (defun describe-text-at (pos)
570 "Describe widgets, buttons, overlays and text properties at POS."
572 (when (eq (current-buffer) (get-buffer "*Text Description*"))
573 (error "Can't do self inspection"))
574 (let* ((properties (text-properties-at pos))
575 (overlays (overlays-at pos))
577 (wid-field (get-char-property pos 'field))
578 (wid-button (get-char-property pos 'button))
579 (wid-doc (get-char-property pos 'widget-doc))
580 ;; If button.el is not loaded, we have no buttons in the text.
581 (button (and (fboundp 'button-at) (button-at pos)))
582 (button-type (and button (button-type button)))
583 (button-label (and button (button-label button)))
584 (widget (or wid-field wid-button wid-doc)))
585 (if (not (or properties overlays))
586 (message "This is plain text.")
587 (when (get-buffer "*Text Description*")
588 (kill-buffer "*Text Description*"))
590 (with-output-to-temp-buffer "*Text Description*"
591 (set-buffer "*Text Description*")
592 (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
594 (when (widgetp widget)
595 (widget-insert (cond (wid-field "This is an editable text area")
596 (wid-button "This is an active area")
597 (wid-doc "This is documentation text")))
598 (widget-insert " of a ")
599 (describe-text-widget widget)
600 (widget-insert ".\n\n"))
602 (when (and button (not (widgetp wid-button)))
603 (widget-insert "Here is a " (format "%S" button-type)
604 " button labeled `" button-label "'.\n\n"))
607 (if (eq (length overlays) 1)
608 (widget-insert "There is an overlay here:\n")
609 (widget-insert "There are " (format "%d" (length overlays))
610 " overlays here:\n"))
611 (dolist (overlay overlays)
612 (widget-insert " From " (format "%d" (overlay-start overlay))
613 " to " (format "%d" (overlay-end overlay)) "\n")
614 (describe-text-properties (overlay-properties overlay)))
615 (widget-insert "\n"))
618 (widget-insert "There are text properties here:\n")
619 (describe-text-properties properties))
621 (goto-char (point-min)))))))
623 ;;; List Text Properties
626 (defun list-text-properties-at (p)
627 "Pop up a buffer listing text-properties at LOCATION."
629 (let ((props (text-properties-at p))
634 (if (and (not (cdr (cdr props)))
635 (not (eq (car props) 'category))
636 (< (length (setq str (format "Text property at %d: %s %S"
637 p (car props) (car (cdr props)))))
640 (with-output-to-temp-buffer "*Text Properties*"
641 (princ (format "Text properties at %d:\n\n" p))
642 (setq help-xref-stack nil)
644 (if (eq (car props) 'category)
645 (setq category (car (cdr props))))
646 (princ (format "%-20s %S\n"
647 (car props) (car (cdr props))))
648 (setq props (cdr (cdr props))))
651 (setq props (symbol-plist category))
652 (princ (format "\nCategory %s:\n\n" category))
654 (princ (format "%-20s %S\n"
655 (car props) (car (cdr props))))
656 (if (eq (car props) 'category)
657 (setq category (car (cdr props))))
658 (setq props (cdr (cdr props)))))))))))
661 (defun facemenu-read-color (&optional prompt)
662 "Read a color using the minibuffer."
663 (let ((col (completing-read (or prompt "Color: ")
664 (or facemenu-color-alist
665 (mapcar 'list (defined-colors)))
672 (defun list-colors-display (&optional list)
673 "Display names of defined colors, and show what they look like.
674 If the optional argument LIST is non-nil, it should be a list of
675 colors to display. Otherwise, this command computes a list
676 of colors that the current display can handle."
678 (when (and (null list) (> (display-color-cells) 0))
679 (setq list (defined-colors))
680 ;; Delete duplicate colors.
683 (if (facemenu-color-equal (car l) (car (cdr l)))
684 (setcdr l (cdr (cdr l)))
686 ;; Don't show more than what the display can handle.
687 (let ((lc (nthcdr (1- (display-color-cells)) list)))
690 (with-output-to-temp-buffer "*Colors*"
692 (set-buffer standard-output)
698 (put-text-property s (point) 'face
699 (cons 'background-color (car list)))
701 (insert " " (car list) "\n")
702 (put-text-property s (point) 'face
703 (cons 'foreground-color (car list)))
704 (setq list (cdr list)))))))
706 (defun facemenu-color-equal (a b)
707 "Return t if colors A and B are the same color.
708 A and B should be strings naming colors.
709 This function queries the display system to find out what the color
710 names mean. It returns nil if the colors differ or if it can't
711 determine the correct answer."
712 (cond ((equal a b) t)
713 ((equal (color-values a) (color-values b)))))
715 (defun facemenu-add-face (face &optional start end)
716 "Add FACE to text between START and END.
717 If START is nil or START to END is empty, add FACE to next typed character
718 instead. For each section of that region that has a different face property,
719 FACE will be consed onto it, and other faces that are completely hidden by
720 that will be removed from the list.
721 If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
722 they are used to set the face information.
724 As a special case, if FACE is `default', then the region is left with NO face
725 text property. Otherwise, selecting the default face would not have any
726 effect. See `facemenu-remove-face-function'."
727 (interactive "*xFace: \nr")
728 (if (and (eq face 'default)
729 (not (eq facemenu-remove-face-function t)))
730 (if facemenu-remove-face-function
731 (funcall facemenu-remove-face-function start end)
732 (if (and start (< start end))
733 (remove-text-properties start end '(face default))
734 (setq self-insert-face 'default
735 self-insert-face-command this-command)))
736 (if facemenu-add-face-function
738 (if end (goto-char end))
740 (if start (goto-char start))
741 (insert-before-markers
742 (funcall facemenu-add-face-function face end)))
743 (if facemenu-end-add-face
744 (insert (if (stringp facemenu-end-add-face)
745 facemenu-end-add-face
746 (funcall facemenu-end-add-face face)))))
747 (if (and start (< start end))
748 (let ((part-start start) part-end)
749 (while (not (= part-start end))
750 (setq part-end (next-single-property-change part-start 'face
752 (let ((prev (get-text-property part-start 'face)))
753 (put-text-property part-start part-end 'face
756 (facemenu-active-faces
761 (setq part-start part-end)))
762 (setq self-insert-face (if (eq last-command self-insert-face-command)
763 (cons face (if (listp self-insert-face)
765 (list self-insert-face)))
767 self-insert-face-command this-command)))))
769 (defun facemenu-active-faces (face-list &optional frame)
770 "Return from FACE-LIST those faces that would be used for display.
771 This means each face attribute is not specified in a face earlier in FACE-LIST
772 and such a face is therefore active when used to display text.
773 If the optional argument FRAME is given, use the faces in that frame; otherwise
774 use the selected frame. If t, then the global, non-frame faces are used."
775 (let* ((mask-atts (copy-sequence
776 (if (consp (car face-list))
777 (face-attributes-as-vector (car face-list))
778 (or (internal-lisp-face-p (car face-list) frame)
779 (check-face (car face-list))))))
780 (active-list (list (car face-list)))
781 (face-list (cdr face-list))
782 (mask-len (length mask-atts)))
785 (if (consp (car face-list))
786 (face-attributes-as-vector (car face-list))
787 (or (internal-lisp-face-p (car face-list) frame)
788 (check-face (car face-list)))))
791 (while (> (setq i (1- i)) 1)
792 (and (not (memq (aref face-atts i) '(nil unspecified)))
793 (memq (aref mask-atts i) '(nil unspecified))
794 (aset mask-atts i (setq useful t))))
796 (setq active-list (cons (car face-list) active-list)))
797 (setq face-list (cdr face-list)))
798 (nreverse active-list)))
800 (defun facemenu-get-face (symbol)
801 "Make sure FACE exists.
802 If not, create it and add it to the appropriate menu. Return the SYMBOL."
803 (let ((name (symbol-name symbol)))
804 (cond ((facep symbol))
805 (t (make-face symbol))))
808 (defun facemenu-add-new-face (face)
809 "Add FACE (a face) to the Face menu.
811 This is called whenever you create a new face."
815 (key (cdr (assoc face facemenu-keybindings)))
818 (setq name (symbol-name face)
821 symbol (intern name)))
822 (setq menu 'facemenu-face-menu)
824 (format "Select face `%s' for subsequent insertion."
826 (cond ((eq t facemenu-unlisted-faces))
827 ((memq symbol facemenu-unlisted-faces))
828 ;; test against regexps in facemenu-unlisted-faces
829 ((let ((unlisted facemenu-unlisted-faces)
831 (while (and unlisted (not matched))
832 (if (and (stringp (car unlisted))
833 (string-match (car unlisted) name))
835 (setq unlisted (cdr unlisted))))
837 (key ; has a keyboard equivalent. These go at the front.
838 (setq function (intern (concat "facemenu-set-" name)))
845 (if (and mark-active (not current-prefix-arg))
847 (if (and mark-active (not current-prefix-arg))
849 (define-key 'facemenu-keymap key (cons name function))
850 (define-key menu key (cons name function)))
851 ((facemenu-iterate ; check if equivalent face is already in the menu
852 (lambda (m) (and (listp m)
854 (face-equal (car m) symbol)))
855 (cdr (symbol-function menu))))
856 (t ; No keyboard equivalent. Figure out where to put it:
857 (setq key (vector symbol)
858 function 'facemenu-set-face-from-menu
859 menu-val (symbol-function menu))
860 (if (and facemenu-new-faces-at-end
861 (> (length menu-val) 3))
862 (define-key-after menu-val key (cons name function)
863 (car (nth (- (length menu-val) 3) menu-val)))
864 (define-key menu key (cons name function))))))
865 nil) ; Return nil for facemenu-iterate
867 (defun facemenu-add-new-color (color &optional menu)
868 "Add COLOR (a color name string) to the appropriate Face menu.
869 MENU should be `facemenu-foreground-menu' or
870 `facemenu-background-menu'.
872 This is called whenever you use a new color."
876 function menu-val key
877 (color-p (memq menu '(facemenu-foreground-menu
878 facemenu-background-menu))))
879 (unless (stringp color)
880 (error "%s is not a color" color))
882 symbol (intern name))
884 (cond ((eq menu 'facemenu-foreground-menu)
886 (format "Select foreground color %s for subsequent insertion."
888 ((eq menu 'facemenu-background-menu)
890 (format "Select background color %s for subsequent insertion."
892 (cond ((facemenu-iterate ; check if equivalent face is already in the menu
893 (lambda (m) (and (listp m)
896 (string-equal (cadr m) color)))
897 (cdr (symbol-function menu))))
898 (t ; No keyboard equivalent. Figure out where to put it:
899 (setq key (vector symbol)
900 function 'facemenu-set-face-from-menu
901 menu-val (symbol-function menu))
902 (if (and facemenu-new-faces-at-end
903 (> (length menu-val) 3))
904 (define-key-after menu-val key (cons name function)
905 (car (nth (- (length menu-val) 3) menu-val)))
906 (define-key menu key (cons name function))))))
907 nil) ; Return nil for facemenu-iterate
909 (defun facemenu-complete-face-list (&optional oldlist)
910 "Return list of all faces that look different.
911 Starts with given ALIST of faces, and adds elements only if they display
912 differently from any face already on the list.
913 The faces on ALIST will end up at the end of the returned list, in reverse
915 (let ((list (nreverse (mapcar 'car oldlist))))
918 (if (not (memq new-face list))
919 (setq list (cons new-face list)))
921 (nreverse (face-list)))
924 (defun facemenu-iterate (func list)
925 "Apply FUNC to each element of LIST until one returns non-nil.
926 Returns the non-nil value it found, or nil if all were nil."
927 (while (and list (not (funcall func (car list))))
928 (setq list (cdr list)))
933 ;;; facemenu.el ends here