;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc.
-;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu>
+;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
;; This file is part of GNU Emacs.
(define-key global-map [C-down-mouse-2] 'facemenu-menu)
(define-key global-map "\M-g" 'facemenu-keymap)
-(defvar facemenu-keybindings
+(defgroup facemenu nil
+ "Create a face menu for interactively adding fonts to text"
+ :group 'faces
+ :prefix "facemenu-")
+
+(defcustom facemenu-keybindings
'((default . "d")
(bold . "b")
(italic . "i")
but get no keyboard equivalents.
If you change this variable after loading facemenu.el, you will need to call
-`facemenu-update' to make it take effect.")
+`facemenu-update' to make it take effect."
+ :type '(repeat (cons face string))
+ :group 'facemenu)
-(defvar facemenu-new-faces-at-end t
+(defcustom facemenu-new-faces-at-end t
"*Where in the menu to insert newly-created faces.
This should be nil to put them at the top of the menu, or t to put them
-just before \"Other\" at the end.")
-
-(defvar facemenu-unlisted-faces
- '(modeline region secondary-selection highlight scratch-face)
+just before \"Other\" at the end."
+ :type 'boolean
+ :group 'facemenu)
+
+(defcustom facemenu-unlisted-faces
+ '(modeline region secondary-selection highlight scratch-face
+ (purecopy "^font-lock-") (purecopy "^gnus-") (purecopy "^message-")
+ (purecopy "^ediff-") (purecopy "^term-") (purecopy "^vc-")
+ (purecopy "^widget-") (purecopy "^custom-") (purecopy "^vm-"))
"*List of faces not to include in the Face menu.
+Each element may be either a symbol, which is the name of a face, or a string,
+which is a regular expression to be matched against face names. Matching
+faces will not be added to the menu.
+
You can set this list before loading facemenu.el, or add a face to it before
creating that face if you do not want it to be listed. If you change the
variable so as to eliminate faces that have already been added to the menu,
If this variable is t, no faces will be added to the menu. This is useful for
temporarily turning off the feature that automatically adds faces to the menu
-when they are created.")
+when they are created."
+ :type '(choice (const :tag "Don't add" t)
+ (const :tag "None" nil)
+ (repeat (choice symbol regexp)))
+ :group 'facemenu)
;;;###autoload
(defvar facemenu-face-menu
(let ((map (make-sparse-keymap "Background Color")))
(define-key map "o" (cons "Other..." 'facemenu-set-background))
map)
- "Menu keymap for background colors")
+ "Menu keymap for background colors.")
;;;###autoload
(defalias 'facemenu-background-menu facemenu-background-menu)
;;;###autoload
(defvar facemenu-special-menu
(let ((map (make-sparse-keymap "Special")))
- (define-key map [?s] (cons "Remove Special" 'facemenu-remove-special))
- (define-key map [?t] (cons "Intangible" 'facemenu-set-intangible))
- (define-key map [?v] (cons "Invisible" 'facemenu-set-invisible))
- (define-key map [?r] (cons "Read-Only" 'facemenu-set-read-only))
+ (define-key map [?s] (cons (purecopy "Remove Special")
+ 'facemenu-remove-special))
+ (define-key map [?t] (cons (purecopy "Intangible")
+ 'facemenu-set-intangible))
+ (define-key map [?v] (cons (purecopy "Invisible")
+ 'facemenu-set-invisible))
+ (define-key map [?r] (cons (purecopy "Read-Only")
+ 'facemenu-set-read-only))
map)
"Menu keymap for non-face text-properties.")
;;;###autoload
;;;###autoload
(defvar facemenu-justification-menu
(let ((map (make-sparse-keymap "Justification")))
- (define-key map [?c] (cons "Center" 'set-justification-center))
- (define-key map [?b] (cons "Full" 'set-justification-full))
- (define-key map [?r] (cons "Right" 'set-justification-right))
- (define-key map [?l] (cons "Left" 'set-justification-left))
- (define-key map [?u] (cons "Unfilled" 'set-justification-none))
+ (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
+ (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
+ (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
+ (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
+ (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
map)
"Submenu for text justification commands.")
;;;###autoload
(defvar facemenu-indentation-menu
(let ((map (make-sparse-keymap "Indentation")))
(define-key map [decrease-right-margin]
- (cons "Indent Right Less" 'decrease-right-margin))
+ (cons (purecopy "Indent Right Less") 'decrease-right-margin))
(define-key map [increase-right-margin]
- (cons "Indent Right More" 'increase-right-margin))
+ (cons (purecopy "Indent Right More") 'increase-right-margin))
(define-key map [decrease-left-margin]
- (cons "Indent Less" 'decrease-left-margin))
+ (cons (purecopy "Indent Less") 'decrease-left-margin))
(define-key map [increase-left-margin]
- (cons "Indent More" 'increase-left-margin))
+ (cons (purecopy "Indent More") 'increase-left-margin))
map)
"Submenu for indentation commands.")
;;;###autoload
(setq facemenu-menu (make-sparse-keymap "Text Properties"))
;;;###autoload
(let ((map facemenu-menu))
- (define-key map [dc] (cons "Display Colors" 'list-colors-display))
- (define-key map [df] (cons "Display Faces" 'list-faces-display))
- (define-key map [dp] (cons "List Properties" 'list-text-properties-at))
- (define-key map [ra] (cons "Remove All" 'facemenu-remove-all))
- (define-key map [rm] (cons "Remove Properties" 'facemenu-remove-props))
- (define-key map [s1] (list "-----------------")))
+ (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
+ (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
+ (define-key map [dp] (cons (purecopy "List Properties")
+ 'list-text-properties-at))
+ (define-key map [ra] (cons (purecopy "Remove Text Properties")
+ 'facemenu-remove-all))
+ (define-key map [rm] (cons (purecopy "Remove Face Properties")
+ 'facemenu-remove-face-props))
+ (define-key map [s1] (list (purecopy "--"))))
;;;###autoload
(let ((map facemenu-menu))
- (define-key map [in] (cons "Indentation" 'facemenu-indentation-menu))
- (define-key map [ju] (cons "Justification" 'facemenu-justification-menu))
- (define-key map [s2] (list "-----------------"))
- (define-key map [sp] (cons "Special Properties" 'facemenu-special-menu))
- (define-key map [bg] (cons "Background Color" 'facemenu-background-menu))
- (define-key map [fg] (cons "Foreground Color" 'facemenu-foreground-menu))
- (define-key map [fc] (cons "Face" 'facemenu-face-menu)))
+ (define-key map [in] (cons (purecopy "Indentation")
+ 'facemenu-indentation-menu))
+ (define-key map [ju] (cons (purecopy "Justification")
+ 'facemenu-justification-menu))
+ (define-key map [s2] (list (purecopy "--")))
+ (define-key map [sp] (cons (purecopy "Special Properties")
+ 'facemenu-special-menu))
+ (define-key map [bg] (cons (purecopy "Background Color")
+ 'facemenu-background-menu))
+ (define-key map [fg] (cons (purecopy "Foreground Color")
+ 'facemenu-foreground-menu))
+ (define-key map [fc] (cons (purecopy "Face")
+ 'facemenu-face-menu)))
;;;###autoload
(defalias 'facemenu-menu facemenu-menu)
(defvar facemenu-keymap
(let ((map (make-sparse-keymap "Set face")))
- (define-key map "o" (cons "Other..." 'facemenu-set-face))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
map)
"Keymap for face-changing commands.
`Facemenu-update' fills in the keymap according to the bindings
(defalias 'facemenu-keymap facemenu-keymap)
-(defvar facemenu-add-face-function nil
- "Function called at beginning of text to change or `nil'.
+(defcustom facemenu-add-face-function nil
+ "Function called at beginning of text to change or nil.
This function is passed the FACE to set and END of text to change, and must
-return a string which is inserted. It may set `facemenu-end-add-face'.")
+return a string which is inserted. It may set `facemenu-end-add-face'."
+ :type '(choice (const :tag "None" nil)
+ function)
+ :group 'facemenu)
-(defvar facemenu-end-add-face nil
- "String to insert or function called at end of text to change or `nil'.
+(defcustom facemenu-end-add-face nil
+ "String to insert or function called at end of text to change or nil.
This function is passed the FACE to set, and must return a string which is
-inserted.")
+inserted."
+ :type '(choice (const :tag "None" nil)
+ string
+ function)
+ :group 'facemenu)
-(defvar facemenu-remove-face-function nil
+(defcustom facemenu-remove-face-function nil
"When non-nil, this is a function called to remove faces.
This function is passed the START and END of text to change.
-May also be `t' meaning to use `facemenu-add-face-function'.")
+May also be t meaning to use `facemenu-add-face-function'."
+ :type '(choice (const :tag "None" nil)
+ (const :tag "Use add-face" t)
+ function)
+ :group 'facemenu)
;;; Internal Variables
Otherwise, this command specifies the face for the next character
inserted. Moving point or switching buffers before
typing a character to insert cancels the specification."
- (interactive (list (read-face-name "Use face: ")))
+ (interactive (list (read-face-name "Use face")))
(barf-if-buffer-read-only)
(facemenu-add-new-face face)
(if (and mark-active (not current-prefix-arg))
;;;###autoload
(defun facemenu-set-foreground (color &optional start end)
- "Set the foreground color of the region or next character typed.
+ "Set the foreground COLOR of the region or next character typed.
The color is prompted for. A face named `fg:color' is used \(or created).
If the region is active, it will be set to the requested face. If
it is inactive \(even if mark-even-if-inactive is set) the next
;;;###autoload
(defun facemenu-set-background (color &optional start end)
- "Set the background color of the region or next character typed.
+ "Set the background COLOR of the region or next character typed.
The color is prompted for. A face named `bg:color' is used \(or created).
If the region is active, it will be set to the requested face. If
it is inactive \(even if mark-even-if-inactive is set) the next
;;;###autoload
(defun facemenu-set-face-from-menu (face start end)
- "Set the face of the region or next character typed.
+ "Set the FACE of the region or next character typed.
This function is designed to be called from a menu; the face to use
is the menu item's name.
(add-text-properties start end '(read-only t)))
;;;###autoload
-(defun facemenu-remove-props (start end)
- "Remove all text properties that facemenu added to region."
+(defun facemenu-remove-face-props (start end)
+ "Remove `face' and `mouse-face' text properties."
(interactive "*r") ; error if buffer is read-only despite the next line.
(let ((inhibit-read-only t))
(remove-text-properties
- start end '(face nil invisible nil intangible nil
- read-only nil category nil))))
+ start end '(face nil mouse-face nil))))
;;;###autoload
(defun facemenu-remove-all (start end)
(message "%s" str)
(with-output-to-temp-buffer "*Text Properties*"
(princ (format "Text properties at %d:\n\n" p))
+ (setq help-xref-stack nil)
(while props
(if (eq (car props) 'category)
(setq category (car (cdr props))))
"Read a color using the minibuffer."
(let ((col (completing-read (or prompt "Color: ")
(or facemenu-color-alist
- (if window-system
- (mapcar 'list (x-defined-colors))))
+ (mapcar 'list (defined-colors)))
nil t)))
(if (equal "" col)
nil
colors to display. Otherwise, this command computes a list
of colors that the current display can handle."
(interactive)
- (if (and (null list) window-system)
- (progn
- (setq list (x-defined-colors))
- ;; Delete duplicate colors.
- (let ((l list))
- (while (cdr l)
- (if (facemenu-color-equal (car l) (car (cdr l)))
- (setcdr l (cdr (cdr l)))
- (setq l (cdr l)))))))
+ (when (null list)
+ (setq list (defined-colors))
+ ;; Delete duplicate colors.
+ (let ((l list))
+ (while (cdr l)
+ (if (facemenu-color-equal (car l) (car (cdr l)))
+ (setcdr l (cdr (cdr l)))
+ (setq l (cdr l))))))
(with-output-to-temp-buffer "*Colors*"
(save-excursion
(set-buffer standard-output)
- (let ((facemenu-unlisted-faces t)
- s)
+ (let (s)
(while list
(setq s (point))
(insert (car list))
(indent-to 20)
(put-text-property s (point) 'face
- (facemenu-get-face
- (intern (concat "bg:" (car list)))))
+ (cons 'background-color (car list)))
(setq s (point))
(insert " " (car list) "\n")
(put-text-property s (point) 'face
- (facemenu-get-face
- (intern (concat "fg:" (car list)))))
+ (cons 'foreground-color (car list)))
(setq list (cdr list)))))))
(defun facemenu-color-equal (a b)
"Return t if colors A and B are the same color.
A and B should be strings naming colors.
-This function queries the window-system server to find out what the
-color names mean. It returns nil if the colors differ or if it can't
+This function queries the display system to find out what the color
+names mean. It returns nil if the colors differ or if it can't
determine the correct answer."
(cond ((equal a b) t)
- ((and (memq window-system '(x w32))
- (equal (x-color-values a) (x-color-values b))))
- ((eq window-system 'pc)
- (and (x-color-defined-p a) (x-color-defined-p b)
- (eq (msdos-color-translate a) (msdos-color-translate b))))))
+ ((equal (color-values a) (color-values b)))))
(defun facemenu-add-face (face &optional start end)
"Add FACE to text between START and END.
-If START is `nil' or START to END is empty, add FACE to next typed character
+If START is nil or START to END is empty, add FACE to next typed character
instead. For each section of that region that has a different face property,
FACE will be consed onto it, and other faces that are completely hidden by
that will be removed from the list.
(defun facemenu-get-face (symbol)
"Make sure FACE exists.
-If not, it is created. If it is created and is of the form `fg:color', then
-set the foreground to that color. If of the form `bg:color', set the
-background. In any case, add it to the appropriate menu. Returns the face,
-or nil if given a bad color."
- (if (or (internal-find-face symbol)
- (let* ((face (make-face symbol))
- (name (symbol-name symbol))
+If not, create it and add it to the appropriate menu. Return the SYMBOL.
+
+If a window system is in use, and this function creates a face named
+`fg:color', then it sets the foreground to that color. Likewise, `bg:color'
+means to set the background. In either case, if the color is undefined,
+no color is set and a warning is issued."
+ (let ((name (symbol-name symbol))
+ foreground)
+ (cond ((facep symbol))
+ ((and (display-color-p)
+ (or (setq foreground (string-match "^fg:" name))
+ (string-match "^bg:" name)))
+ (let ((face (make-face symbol))
(color (substring name 3)))
- (cond ((string-match "^fg:" name)
- (set-face-foreground face color)
- (and window-system
- (x-color-defined-p color)))
- ((string-match "^bg:" name)
- (set-face-background face color)
- (and window-system
- (x-color-defined-p color)))
- (t))))
- symbol))
+ (if (x-color-defined-p color)
+ (if foreground
+ (set-face-foreground face color)
+ (set-face-background face color))
+ (message "Color \"%s\" undefined" color))))
+ (t (make-face symbol))))
+ symbol)
(defun facemenu-add-new-face (face)
"Add a FACE to the appropriate Face menu.
(setq menu 'facemenu-face-menu)))
(cond ((eq t facemenu-unlisted-faces))
((memq face facemenu-unlisted-faces))
+ ;; test against regexps in facemenu-unlisted-faces
+ ((let ((unlisted facemenu-unlisted-faces)
+ (matched nil))
+ (while (and unlisted (not matched))
+ (if (and (stringp (car unlisted))
+ (string-match (car unlisted) name))
+ (setq matched t)
+ (setq unlisted (cdr unlisted))))
+ matched))
(key ; has a keyboard equivalent. These go at the front.
(setq function (intern (concat "facemenu-set-" name)))
(fset function
`(lambda ()
,docstring
(interactive)
- (facemenu-set-face (quote (, face)))))
+ (facemenu-set-face (quote ,face))))
(define-key 'facemenu-keymap key (cons name function))
(define-key menu key (cons name function)))
((facemenu-iterate ; check if equivalent face is already in the menu
(nreverse (face-list)))
list))
-(defun facemenu-iterate (func iterate-list)
+(defun facemenu-iterate (func list)
"Apply FUNC to each element of LIST until one returns non-nil.
Returns the non-nil value it found, or nil if all were nil."
- (while (and iterate-list (not (funcall func (car iterate-list))))
- (setq iterate-list (cdr iterate-list)))
- (car iterate-list))
+ (while (and list (not (funcall func (car list))))
+ (setq list (cdr list)))
+ (car list))
(facemenu-update)