1 |
;;; facemenu.el --- create a face menu for interactively adding fonts to text |
;;; facemenu.el --- create a face menu for interactively adding fonts to text |
2 |
|
|
3 |
;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc. |
;; Copyright (c) 1994, 1995, 1996, 2001, 2002, 2005 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Boris Goldowsky <boris@gnu.org> |
;; Author: Boris Goldowsky <boris@gnu.org> |
6 |
;; Keywords: faces |
;; Keywords: faces |
135 |
`(modeline region secondary-selection highlight scratch-face |
`(modeline region secondary-selection highlight scratch-face |
136 |
,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") |
,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") |
137 |
,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") |
,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") |
138 |
,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")) |
,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-") |
139 |
|
,(purecopy "^fg:") ,(purecopy "^bg:")) |
140 |
"*List of faces not to include in the Face menu. |
"*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, |
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 |
which is a regular expression to be matched against face names. Matching |
366 |
(region-beginning)) |
(region-beginning)) |
367 |
(if (and mark-active (not current-prefix-arg)) |
(if (and mark-active (not current-prefix-arg)) |
368 |
(region-end)))) |
(region-end)))) |
369 |
(unless (color-defined-p color) |
(facemenu-add-face (facemenu-add-new-color color 'facemenu-foreground-menu) |
370 |
(message "Color `%s' undefined" color)) |
start end)) |
|
(facemenu-add-new-color color 'facemenu-foreground-menu) |
|
|
(facemenu-add-face (list (list :foreground color)) start end)) |
|
371 |
|
|
372 |
;;;###autoload |
;;;###autoload |
373 |
(defun facemenu-set-background (color &optional start end) |
(defun facemenu-set-background (color &optional start end) |
388 |
(region-beginning)) |
(region-beginning)) |
389 |
(if (and mark-active (not current-prefix-arg)) |
(if (and mark-active (not current-prefix-arg)) |
390 |
(region-end)))) |
(region-end)))) |
391 |
(unless (color-defined-p color) |
(facemenu-add-face (facemenu-add-new-color color 'facemenu-background-menu) |
392 |
(message "Color `%s' undefined" color)) |
start end)) |
|
(facemenu-add-new-color color 'facemenu-background-menu) |
|
|
(facemenu-add-face (list (list :background color)) start end)) |
|
393 |
|
|
394 |
;;;###autoload |
;;;###autoload |
395 |
(defun facemenu-set-face-from-menu (face start end) |
(defun facemenu-set-face-from-menu (face start end) |
410 |
(if (and mark-active (not current-prefix-arg)) |
(if (and mark-active (not current-prefix-arg)) |
411 |
(region-end)))) |
(region-end)))) |
412 |
(barf-if-buffer-read-only) |
(barf-if-buffer-read-only) |
|
(facemenu-get-face face) |
|
413 |
(if start |
(if start |
414 |
(facemenu-add-face face start end) |
(facemenu-add-face face start end) |
415 |
(facemenu-add-face face))) |
(facemenu-add-face face))) |
644 |
(setq face-list (cdr face-list))) |
(setq face-list (cdr face-list))) |
645 |
(nreverse active-list))) |
(nreverse active-list))) |
646 |
|
|
|
(defun facemenu-get-face (symbol) |
|
|
"Make sure FACE exists. |
|
|
If not, create it and add it to the appropriate menu. Return the SYMBOL." |
|
|
(let ((name (symbol-name symbol))) |
|
|
(cond ((facep symbol)) |
|
|
(t (make-face symbol)))) |
|
|
symbol) |
|
|
|
|
647 |
(defun facemenu-add-new-face (face) |
(defun facemenu-add-new-face (face) |
648 |
"Add FACE (a face) to the Face menu. |
"Add FACE (a face) to the Face menu. |
649 |
|
|
703 |
(define-key menu key (cons name function)))))) |
(define-key menu key (cons name function)))))) |
704 |
nil) ; Return nil for facemenu-iterate |
nil) ; Return nil for facemenu-iterate |
705 |
|
|
706 |
(defun facemenu-add-new-color (color &optional menu) |
(defun facemenu-add-new-color (color menu) |
707 |
"Add COLOR (a color name string) to the appropriate Face menu. |
"Add COLOR (a color name string) to the appropriate Face menu. |
708 |
MENU should be `facemenu-foreground-menu' or |
MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'. |
709 |
`facemenu-background-menu'. |
Create the appropriate face and return it. |
710 |
|
|
711 |
This is called whenever you use a new color." |
This is called whenever you use a new color." |
712 |
(let* (name |
(let (symbol docstring) |
713 |
symbol |
(unless (color-defined-p color) |
714 |
docstring |
(error "Color `%s' undefined" color)) |
|
function menu-val key |
|
|
(color-p (memq menu '(facemenu-foreground-menu |
|
|
facemenu-background-menu)))) |
|
|
(unless (stringp color) |
|
|
(error "%s is not a color" color)) |
|
|
(setq name color |
|
|
symbol (intern name)) |
|
|
|
|
715 |
(cond ((eq menu 'facemenu-foreground-menu) |
(cond ((eq menu 'facemenu-foreground-menu) |
716 |
(setq docstring |
(setq docstring |
717 |
(format "Select foreground color %s for subsequent insertion." |
(format "Select foreground color %s for subsequent insertion." |
718 |
name))) |
color) |
719 |
|
symbol (intern (concat "fg:" color))) |
720 |
|
(set-face-foreground (make-face symbol) color)) |
721 |
((eq menu 'facemenu-background-menu) |
((eq menu 'facemenu-background-menu) |
722 |
(setq docstring |
(setq docstring |
723 |
(format "Select background color %s for subsequent insertion." |
(format "Select background color %s for subsequent insertion." |
724 |
name)))) |
color) |
725 |
|
symbol (intern (concat "bg:" color))) |
726 |
|
(set-face-background (make-face symbol) color)) |
727 |
|
(t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'"))) |
728 |
(cond ((facemenu-iterate ; check if equivalent face is already in the menu |
(cond ((facemenu-iterate ; check if equivalent face is already in the menu |
729 |
(lambda (m) (and (listp m) |
(lambda (m) (and (listp m) |
730 |
(symbolp (car m)) |
(symbolp (car m)) |
731 |
(stringp (cadr m)) |
(stringp (cadr m)) |
732 |
(string-equal (cadr m) color))) |
(string-equal (cadr m) color))) |
733 |
(cdr (symbol-function menu)))) |
(cdr (symbol-function menu)))) |
734 |
(t ; No keyboard equivalent. Figure out where to put it: |
(t ; No keyboard equivalent. Figure out where to put it: |
735 |
(setq key (vector symbol) |
(let ((key (vector symbol)) |
736 |
function 'facemenu-set-face-from-menu |
(function 'facemenu-set-face-from-menu) |
737 |
menu-val (symbol-function menu)) |
(menu-val (symbol-function menu))) |
738 |
(if (and facemenu-new-faces-at-end |
(if (and facemenu-new-faces-at-end |
739 |
(> (length menu-val) 3)) |
(> (length menu-val) 3)) |
740 |
(define-key-after menu-val key (cons name function) |
(define-key-after menu-val key (cons color function) |
741 |
(car (nth (- (length menu-val) 3) menu-val))) |
(car (nth (- (length menu-val) 3) menu-val))) |
742 |
(define-key menu key (cons name function)))))) |
(define-key menu key (cons color function)))))) |
743 |
nil) ; Return nil for facemenu-iterate |
symbol)) |
744 |
|
|
745 |
(defun facemenu-complete-face-list (&optional oldlist) |
(defun facemenu-complete-face-list (&optional oldlist) |
746 |
"Return list of all faces that look different. |
"Return list of all faces that look different. |