;;; facemenu.el --- create a face menu for interactively adding fonts to text
;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(require 'help)
(require 'button))
-;;; Provide some binding for startup:
-;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap)
-;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
-
;; Global bindings:
(define-key global-map [C-down-mouse-2] 'facemenu-menu)
(define-key global-map "\M-o" 'facemenu-keymap)
: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
:group 'facemenu)
+(defvar 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 that are of no interest to the user.")
+(make-obsolete-variable 'facemenu-unlisted-faces 'facemenu-listed-faces
+ "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.
-Each element should be a symbol, which is the name of a face.
+ "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 are not included in this list.
-
-You can set this list before loading facemenu.el, or add a face to it before
-creating that face if you want it to be listed. If you change the
-variable so as to eliminate faces that have already been added to the menu,
-call `facemenu-update' to recalculate the menu contents.
-
-If this variable is t, all faces will be added to the menu. This
-is useful for setting temporarily if you want to add faces to the
-menu when they are created."
+added to the Face menu, and need not be in this list.
+
+This value takes effect when you load facemenu.el. If the
+list includes symbols which are not defined as faces, they
+are ignored; however, subsequently defining or creating
+those faces adds them to the menu then. You can call
+`facemenu-update' to recalculate the menu contents, such as
+if you change the value of this variable,
+
+If this variable is t, all faces that you apply to text
+using the face menu commands (even by name), and all faces
+that you define or create, are added to the menu. You may
+find it useful to set this variable to t temporarily while
+you define some faces, so that they will be added. However,
+if the value is no longer t and you call `facemenu-update',
+it will remove any faces not explicitly in the list."
:type '(choice (const :tag "List all faces" t)
(const :tag "None" nil)
(repeat symbol))
:group 'facemenu
:version "22.1")
-;;;###autoload
(defvar facemenu-face-menu
(let ((map (make-sparse-keymap "Face")))
(define-key map "o" (cons "Other..." 'facemenu-set-face))
map)
"Menu keymap for faces.")
-;;;###autoload
(defalias 'facemenu-face-menu facemenu-face-menu)
(put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
-;;;###autoload
(defvar facemenu-foreground-menu
(let ((map (make-sparse-keymap "Foreground Color")))
(define-key map "o" (cons "Other..." 'facemenu-set-foreground))
map)
"Menu keymap for foreground colors.")
-;;;###autoload
(defalias 'facemenu-foreground-menu facemenu-foreground-menu)
(put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
-;;;###autoload
(defvar facemenu-background-menu
(let ((map (make-sparse-keymap "Background Color")))
(define-key map "o" (cons "Other..." 'facemenu-set-background))
map)
"Menu keymap for background colors.")
-;;;###autoload
(defalias 'facemenu-background-menu facemenu-background-menu)
(put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
(defun facemenu-enable-faces-p ()
(not (and font-lock-mode font-lock-defaults)))
-;;;###autoload
(defvar facemenu-special-menu
(let ((map (make-sparse-keymap "Special")))
(define-key map [?s] (cons (purecopy "Remove Special")
'facemenu-set-read-only))
map)
"Menu keymap for non-face text-properties.")
-;;;###autoload
(defalias 'facemenu-special-menu facemenu-special-menu)
-;;;###autoload
(defvar facemenu-justification-menu
(let ((map (make-sparse-keymap "Justification")))
(define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
(define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
map)
"Submenu for text justification commands.")
-;;;###autoload
(defalias 'facemenu-justification-menu facemenu-justification-menu)
-;;;###autoload
(defvar facemenu-indentation-menu
(let ((map (make-sparse-keymap "Indentation")))
(define-key map [decrease-right-margin]
(cons (purecopy "Indent More") 'increase-left-margin))
map)
"Submenu for indentation commands.")
-;;;###autoload
(defalias 'facemenu-indentation-menu facemenu-indentation-menu)
;; This is split up to avoid an overlong line in loaddefs.el.
-;;;###autoload
(defvar facemenu-menu nil
"Facemenu top-level menu keymap.")
-;;;###autoload
(setq facemenu-menu (make-sparse-keymap "Text Properties"))
-;;;###autoload
(let ((map facemenu-menu))
(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 [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 (purecopy "Indentation")
'facemenu-indentation-menu))
'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 (purecopy "Other...") 'facemenu-set-face))
+ (define-key map "\M-o" 'font-lock-fontify-block)
map)
"Keymap for face-changing commands.
`Facemenu-update' fills in the keymap according to the bindings
(facemenu-iterate 'facemenu-add-new-face
(facemenu-complete-face-list facemenu-keybindings)))
-;;;###autoload
(defun facemenu-set-face (face &optional start end)
- "Add FACE to the region or next character typed.
-This adds FACE to the top of the face list; any faces lower on the list that
-will not show through at all will be removed.
-
-Interactively, reads the face name with the minibuffer.
-
-If the region is active (normally true except in Transient Mark mode)
-and there is no prefix argument, this command sets the region to the
-requested face.
-
-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."
+ "Apply FACE to the region or next character typed.
+
+If the region is active (normally true except in Transient
+Mark mode) and nonempty, and there is no prefix argument,
+this command applies FACE to the region. Otherwise, it applies FACE
+to the faces to use for the next character
+inserted. (Moving point or switching buffers before typing
+a character to insert cancels the specification.)
+
+If FACE is `default', to \"apply\" it means clearing
+the list of faces to be used. For any other value of FACE,
+to \"apply\" it means putting FACE at the front of the list
+of faces to be used, and removing any faces further
+along in the list that would be completely overridden by
+preceding faces (including FACE).
+
+This command can also add FACE to the menu of faces,
+if `facemenu-listed-faces' says to do that."
(interactive (list (progn
(barf-if-buffer-read-only)
(read-face-name "Use face"))
(facemenu-add-new-face face)
(facemenu-add-face face start end))
-;;;###autoload
(defun facemenu-set-foreground (color &optional start end)
"Set the foreground COLOR of the region or next character typed.
This command reads the color in the minibuffer.
(facemenu-add-new-color color 'facemenu-foreground-menu)
start end))
-;;;###autoload
(defun facemenu-set-background (color &optional start end)
"Set the background COLOR of the region or next character typed.
This command reads the color in the minibuffer.
(facemenu-add-new-color color 'facemenu-background-menu)
start end))
-;;;###autoload
(defun facemenu-set-face-from-menu (face start end)
"Set the FACE of the region or next character typed.
This function is designed to be called from a menu; FACE is determined
face))
start end))
-;;;###autoload
(defun facemenu-set-invisible (start end)
"Make the region invisible.
This sets the `invisible' text property; it can be undone with
(interactive "r")
(add-text-properties start end '(invisible t)))
-;;;###autoload
(defun facemenu-set-intangible (start end)
"Make the region intangible: disallow moving into it.
This sets the `intangible' text property; it can be undone with
(interactive "r")
(add-text-properties start end '(intangible t)))
-;;;###autoload
(defun facemenu-set-read-only (start end)
"Make the region unmodifiable.
This sets the `read-only' text property; it can be undone with
(interactive "r")
(add-text-properties start end '(read-only t)))
-;;;###autoload
(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.
(remove-text-properties
start end '(face nil mouse-face nil))))
-;;;###autoload
(defun facemenu-remove-all (start end)
"Remove all text properties from the region."
(interactive "*r") ; error if buffer is read-only despite the next line.
(let ((inhibit-read-only t))
(set-text-properties start end nil)))
-;;;###autoload
(defun facemenu-remove-special (start end)
"Remove all the \"special\" text properties from the region.
These special properties include `invisible', `intangible' and `read-only'."
(remove-text-properties
start end '(invisible nil intangible nil read-only nil))))
\f
-;;;###autoload
(defun facemenu-read-color (&optional prompt)
"Read a color using the minibuffer."
(let* ((completion-ignore-case t)
- (col (completing-read (or prompt "Color: ")
- (or facemenu-color-alist
- (defined-colors))
- nil t)))
+ (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)))
-;;;###autoload
(defun list-colors-display (&optional list buffer-name)
"Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
(let ((lc (nthcdr (1- (display-color-cells)) list)))
(if lc
(setcdr lc nil)))))
- (with-output-to-temp-buffer (or buffer-name "*Colors*")
+ (with-help-window (or buffer-name "*Colors*")
(save-excursion
(set-buffer standard-output)
(setq truncate-lines t)
(insert (car color))
(indent-to 22))
(point)
- 'face (cons 'background-color (car color)))
+ 'face (list ':background (car color)))
(put-text-property
(prog1 (point)
(insert " " (if (cdr color)
(mapconcat 'identity (cdr color) ", ")
(car color))))
(point)
- 'face (cons 'foreground-color (car color)))
+ 'face (list ':foreground (car color)))
(indent-to (max (- (window-width) 8) 44))
(insert (apply 'format "#%02x%02x%02x"
(mapcar (lambda (c) (lsh c -8))
(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))))
(cons face
(if (listp prev)
prev
- (list prev)))))))
+ (list prev)))
+ ;; Specify the selected frame
+ ;; because nil would mean to use
+ ;; the new-frame default settings,
+ ;; and those are usually nil.
+ (selected-frame)))))
(setq part-start part-end)))
(setq self-insert-face (if (eq last-command self-insert-face-command)
(cons face (if (listp self-insert-face)
(nreverse active-list)))
(defun facemenu-add-new-face (face)
- "Add FACE (a face) to the Face menu.
-
-This is called whenever you create a new face."
+ "Add FACE (a face) to the Face menu if `facemenu-listed-faces' says so.
+This is called whenever you create a new face, and at other times."
(let* (name
symbol
menu docstring
symbol (intern name)))
(setq menu 'facemenu-face-menu)
(setq docstring
- (format "Select face `%s' for subsequent insertion."
- name))
+ (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))
(cond ((facemenu-iterate ; check if equivalent face is already in the menu
(lambda (m) (and (listp m)
(symbolp (car m))
+ ;; Avoid error in face-equal
+ ;; when a non-face is erroneously present.
+ (facep (car m))
(face-equal (car m) symbol)))
(cdr (symbol-function menu))))
;; Faces with a keyboard equivalent. These go at the front.
(provide 'facemenu)
-;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
+;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
;;; facemenu.el ends here