;;; facemenu.el --- create a face menu for interactively adding fonts to text
;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
:prefix "facemenu-")
(defcustom facemenu-keybindings
+ (mapcar 'purecopy
'((default . "d")
(bold . "b")
(italic . "i")
(bold-italic . "l") ; {bold} intersect {italic} = {l}
- (underline . "u"))
+ (underline . "u")))
"Alist of interesting faces and keybindings.
Each element is itself a list: the car is the name of the face,
the next element is the key to use as a keyboard equivalent of the menu item;
:group 'facemenu)
(defcustom facemenu-new-faces-at-end t
- "*Where in the menu to insert newly-created faces.
+ "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."
:type 'boolean
"22.1,\n and has no effect on the Face menu")
(defcustom facemenu-listed-faces nil
- "*List of faces to include in the Face menu.
+ "List of faces to include in the Face menu.
Each element should be a symbol, the name of a face.
The \"basic \" faces in `facemenu-keybindings' are automatically
added to the Face menu, and need not be in this list.
(defvar facemenu-face-menu
(let ((map (make-sparse-keymap "Face")))
- (define-key map "o" (cons "Other..." 'facemenu-set-face))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
map)
"Menu keymap for faces.")
(defalias 'facemenu-face-menu facemenu-face-menu)
(defvar facemenu-foreground-menu
(let ((map (make-sparse-keymap "Foreground Color")))
- (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground))
map)
"Menu keymap for foreground colors.")
(defalias 'facemenu-foreground-menu facemenu-foreground-menu)
(defvar facemenu-background-menu
(let ((map (make-sparse-keymap "Background Color")))
- (define-key map "o" (cons "Other..." 'facemenu-set-background))
+ (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background))
map)
"Menu keymap for background colors.")
(defalias 'facemenu-background-menu facemenu-background-menu)
;;; Condition for enabling menu items that set faces.
(defun facemenu-enable-faces-p ()
- (not (and font-lock-mode font-lock-defaults)))
+ ;; Enable the facemenu if facemenu-add-face-function is defined
+ ;; (e.g. in Tex-mode and SGML mode), or if font-lock is off.
+ (or (not (and font-lock-mode font-lock-defaults))
+ facemenu-add-face-function))
(defvar facemenu-special-menu
(let ((map (make-sparse-keymap "Special")))
(defun facemenu-read-color (&optional prompt)
"Read a color using the minibuffer."
(let* ((completion-ignore-case t)
- (require-match (not (eq window-system 'ns)))
- (col (completing-read (or prompt "Color: ")
- (or facemenu-color-alist
- (defined-colors))
- nil require-match)))
+ (color-list (or facemenu-color-alist (defined-colors)))
+ (completer
+ (lambda (string pred all-completions)
+ (if all-completions
+ (or (all-completions string color-list pred)
+ (if (color-defined-p string)
+ (list string)))
+ (or (try-completion string color-list pred)
+ (if (color-defined-p string)
+ string)))))
+ (col (completing-read (or prompt "Color: ") completer nil t)))
(if (equal "" col)
nil
col)))
(if lc
(setcdr lc nil)))))
(with-help-window (or buffer-name "*Colors*")
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
(setq truncate-lines t)
(if temp-buffer-show-function
(list-colors-print list)
;; to get the right value of window-width in list-colors-print
;; after the buffer is displayed.
(add-hook 'temp-buffer-show-hook
- (lambda () (list-colors-print list)) nil t)))))
+ (lambda ()
+ (set-buffer-modified-p
+ (prog1 (buffer-modified-p)
+ (list-colors-print list))))
+ nil t)))))
(defun list-colors-print (list)
(dolist (color list)
(l list))
(while (cdr l)
(if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
- (not (if (boundp 'w32-default-color-map)
- (not (assoc (car (car l)) w32-default-color-map)))))
+ (not (if (fboundp 'w32-default-color-map)
+ (not (assoc (car (car l)) (w32-default-color-map))))))
(progn
(setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
(setcdr l (cdr (cdr l))))
symbol (intern name)))
(setq menu 'facemenu-face-menu)
(setq docstring
- (format "Select face `%s' for subsequent insertion.
+ (purecopy (format "Select face `%s' for subsequent insertion.
If the mark is active and there is no prefix argument,
apply face `%s' to the region instead.
This command was defined by `facemenu-add-new-face'."
- name name))
+ name name)))
(cond ((facemenu-iterate ; check if equivalent face is already in the menu
(lambda (m) (and (listp m)
(symbolp (car m))