X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f61deddc6d2cc98b73e95e31cd3716a456a5d94d..dc3eeeb48af706de824b7b8bae62dc868d26637e:/lisp/facemenu.el

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 1c9c5de811..13cf7fbd73 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -1,7 +1,9 @@
-;;; facemenu.el -- Create a face menu for interactively adding fonts to text
-;; Copyright (c) 1994, 1995 Free Software Foundation, Inc.
+;;; facemenu.el --- create a face menu for interactively adding fonts to text
 
-;; Author: Boris Goldowsky <boris@cs.rochester.edu>
+;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
+;;   2005, 2006 Free Software Foundation, Inc.
+
+;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Keywords: faces
 
 ;; This file is part of GNU Emacs.
@@ -17,19 +19,15 @@
 ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; 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.
 
 ;;; Commentary:
+
 ;; This file defines a menu of faces (bold, italic, etc) which allows you to
 ;; set the face used for a region of the buffer.  Some faces also have
-;; keybindings, which are shown in the menu.  Faces with names beginning with
-;; "fg:" or "bg:", as in "fg:red", are treated specially.
-;; Such faces are assumed to consist only of a foreground (if "fg:") or
-;; background (if "bg:") color.  They are thus put into the color submenus
-;; rather than the general Face submenu.  These faces can also be
-;; automatically created by selecting the "Other..." menu items in the
-;; "Foreground" and "Background" submenus.
+;; keybindings, which are shown in the menu.
 ;;
 ;; The menu also contains submenus for indentation and justification-changing
 ;; commands.
@@ -41,9 +39,9 @@
 ;; insertion.  It will be forgotten if you move point or make other
 ;; modifications before inserting or typing anything.
 ;;
-;; Faces can be selected from the keyboard as well.  
-;; The standard keybindings are M-g (or ESC g) + letter:
-;; M-g i = "set italic",  M-g b = "set bold", etc.
+;; Faces can be selected from the keyboard as well.
+;; The standard keybindings are M-o (or ESC o) + letter:
+;; M-o i = "set italic",  M-o b = "set bold", etc.
 
 ;;; Customization:
 ;; An alternative set of keybindings that may be easier to type can be set up
@@ -62,16 +60,15 @@
 ;;      (italic      . [?\H-i])
 ;;      (bold-italic . [?\H-l])
 ;;      (underline   . [?\H-u])))
+;;   (facemenu-update)
 ;;   (setq facemenu-keymap global-map)
-;;   (setq facemenu-key nil)
 ;;   (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
 ;;   (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
-;;   (require 'facemenu)
 ;;
 ;; The order of the faces that appear in the menu and their keybindings can be
 ;; controlled by setting the variables `facemenu-keybindings' and
-;; `facemenu-new-faces-at-end'.  List faces that you don't use in documents
-;; (eg, `region') in `facemenu-unlisted-faces'.
+;; `facemenu-new-faces-at-end'.  List faces that you want to use in documents
+;; in `facemenu-listed-faces'.
 
 ;;; Known Problems:
 ;; Bold and Italic do not combine to create bold-italic if you select them
@@ -90,51 +87,76 @@
 
 ;;; Code:
 
-(provide 'facemenu)
+(eval-when-compile
+  (require 'help)
+  (require 'button))
 
 ;;; Provide some binding for startup:
-;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap)
+;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap)
 ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
 
-(defvar facemenu-key "\M-g"
-  "Prefix key to use for facemenu commands.")
+;; Global bindings:
+(define-key global-map [C-down-mouse-2] 'facemenu-menu)
+(define-key global-map "\M-o" 'facemenu-keymap)
+
+(defgroup facemenu nil
+  "Create a face menu for interactively adding fonts to text."
+  :group 'faces
+  :prefix "facemenu-")
 
-(defvar facemenu-keybindings
+(defcustom facemenu-keybindings
   '((default     . "d")
     (bold        . "b")
     (italic      . "i")
     (bold-italic . "l") ; {bold} intersect {italic} = {l}
     (underline   . "u"))
-  "Alist of interesting faces and keybindings. 
+  "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;
-the binding is made in facemenu-keymap.
+the binding is made in `facemenu-keymap'.
 
 The faces specifically mentioned in this list are put at the top of
-the menu, in the order specified.  All other faces which are defined,
-except for those in `facemenu-unlisted-faces', are listed after them, 
-but get no keyboard equivalents.
+the menu, in the order specified.  All other faces which are defined
+in `facemenu-listed-faces' are listed after them, 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
-  "Where in the menu to insert newly-created faces.
+(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
-    font-lock-comment-face font-lock-string-face font-lock-keyword-face
-    font-lock-function-name-face font-lock-variable-name-face
-    font-lock-type-face font-lock-reference-face)
-  "List of faces not to include in the Face menu.
-Set this before loading facemenu.el, or call `facemenu-update' after
-changing it.
-
-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.")
+just before \"Other\" at the end."
+  :type 'boolean
+  :group 'facemenu)
+
+(defcustom facemenu-listed-faces nil
+  "*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.
+
+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
@@ -144,31 +166,43 @@ when they are created.")
   "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 
+(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 "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))
+    (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)
+(put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
+
+;;; Condition for enabling menu items that set faces.
+(defun facemenu-enable-faces-p ()
+  (not (and font-lock-mode font-lock-defaults)))
 
 ;;;###autoload
-(defvar facemenu-special-menu 
+(defvar facemenu-special-menu
   (let ((map (make-sparse-keymap "Special")))
-    (define-key map [read-only] (cons "Read-Only" 'facemenu-set-read-only))
-    (define-key map [invisible] (cons "Invisible" 'facemenu-set-invisible))
-    (define-key map [intangible] (cons "Intangible" 'facemenu-set-intangible))
+    (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
@@ -177,11 +211,11 @@ when they are created.")
 ;;;###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
@@ -190,64 +224,101 @@ when they are created.")
 ;;;###autoload
 (defvar facemenu-indentation-menu
   (let ((map (make-sparse-keymap "Indentation")))
-    (define-key map [UnIndentRight] 
-      (cons "UnIndentRight" 'decrease-right-margin))
-    (define-key map [IndentRight]
-      (cons "IndentRight" 'increase-right-margin))
-    (define-key map [Unindent]
-      (cons "UnIndent" 'decrease-left-margin))
-    (define-key map [Indent]
-      (cons "Indent" 'increase-left-margin))
+    (define-key map [decrease-right-margin]
+      (cons (purecopy "Indent Right Less") 'decrease-right-margin))
+    (define-key map [increase-right-margin]
+      (cons (purecopy "Indent Right More") 'increase-right-margin))
+    (define-key map [decrease-left-margin]
+      (cons (purecopy "Indent Less") 'decrease-left-margin))
+    (define-key map [increase-left-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 
-  (let ((map (make-sparse-keymap "Face")))
-    (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 [rm] (cons "Remove Properties" 'facemenu-remove-all))
-    (define-key map [s1] (list "-----------------"))
-    (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 Props" '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))
-    map)
+(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 [dp] (cons (purecopy "Describe Properties")
+			     'describe-text-properties))
+  (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 (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 
+(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
 requested in `facemenu-keybindings'.")
 (defalias 'facemenu-keymap facemenu-keymap)
 
+
+(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'."
+  :type '(choice (const :tag "None" nil)
+		 function)
+  :group 'facemenu)
+
+(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."
+  :type '(choice (const :tag "None" nil)
+		 string
+		 function)
+  :group 'facemenu)
+
+(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'."
+  :type '(choice (const :tag "None" nil)
+		 (const :tag "Use add-face" t)
+		 function)
+  :group 'facemenu)
+
 ;;; Internal Variables
 
 (defvar facemenu-color-alist nil
-  ;; Don't initialize here; that doesn't work if preloaded.
   "Alist of colors, used for completion.
-If null, `facemenu-read-color' will set it.")
+If this is nil, then the value of (defined-colors) is used.")
 
 (defun facemenu-update ()
   "Add or update the \"Face\" menu in the menu bar.
 You can call this to update things if you change any of the menu configuration
 variables."
   (interactive)
-  
-  ;; Global bindings:
-  (define-key global-map [C-down-mouse-2] 'facemenu-menu)
-  (if facemenu-key (define-key global-map facemenu-key 'facemenu-keymap))
 
   ;; Add each defined face to the menu.
   (facemenu-iterate 'facemenu-add-new-face
@@ -255,312 +326,463 @@ variables."
 
 ;;;###autoload
 (defun facemenu-set-face (face &optional start end)
-  "Add FACE to the region or next character typed.
-It will be added to the top of the face list; any faces lower on the list that
-will not show through at all will be removed.
-
-Interactively, the face to be used is prompted for.
-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
-character that is typed \(or otherwise inserted) will be set to
-the selected face.  Moving point or switching buffers before
-typing a character cancels the request." 
-  (interactive (list (read-face-name "Use face: ")))
-  (barf-if-buffer-read-only)
+  "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"))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-beginning))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-end))))
   (facemenu-add-new-face face)
-  (if mark-active
-      (let ((start (or start (region-beginning)))
-	    (end (or end (region-end))))
-	(facemenu-add-face face start end))
-    (facemenu-self-insert-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.
-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
-character that is typed \(via `self-insert-command') will be set to
-the selected face.  Moving point or switching buffers before
-typing a character cancels the request." 
-  (interactive (list (facemenu-read-color "Foreground color: ")))
-  (let ((face (intern (concat "fg:" color))))
-    (or (facemenu-get-face face)
-	(error "Unknown color: %s" color))
-    (facemenu-set-face face start end)))
+  "Set the foreground COLOR of the region or next character typed.
+This command reads the color in 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."
+  (interactive (list (progn
+		       (barf-if-buffer-read-only)
+		       (facemenu-read-color "Foreground color: "))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-beginning))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-end))))
+  (facemenu-set-face-from-menu
+   (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.
-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
-character that is typed \(via `self-insert-command') will be set to
-the selected face.  Moving point or switching buffers before
-typing a character cancels the request." 
-  (interactive (list (facemenu-read-color "Background color: ")))
-  (let ((face (intern (concat "bg:" color))))
-    (or (facemenu-get-face face)
-	(error "Unknown color: %s" color))
-    (facemenu-set-face face start end)))
+  "Set the background COLOR of the region or next character typed.
+This command reads the color in 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."
+  (interactive (list (progn
+		       (barf-if-buffer-read-only)
+		       (facemenu-read-color "Background color: "))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-beginning))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-end))))
+  (facemenu-set-face-from-menu
+   (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; the face to use
-is the menu item's name.
-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
-character that is typed \(or otherwise inserted) will be set to
-the selected face.  Moving point or switching buffers before
-typing a character cancels the request." 
+  "Set the FACE of the region or next character typed.
+This function is designed to be called from a menu; FACE is determined
+using the event type of the menu entry.  If FACE is a symbol whose
+name starts with \"fg:\" or \"bg:\", then this functions sets the
+foreground or background to the color specified by the rest of the
+symbol's name.  Any other symbol is considered the name of a face.
+
+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."
   (interactive (list last-command-event
-		     (if mark-active (region-beginning))
-		     (if mark-active (region-end))))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-beginning))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-end))))
   (barf-if-buffer-read-only)
-  (facemenu-get-face face)
-  (if start 
-      (facemenu-add-face face start end)
-    (facemenu-self-insert-face face)))
-
-(defun facemenu-self-insert-face (face)
-  (setq self-insert-face (if (eq last-command self-insert-face-command)
-			     (cons face (if (listp self-insert-face)
-					    self-insert-face
-					  (list self-insert-face)))
-			   face)
-	self-insert-face-command this-command))
+  (facemenu-add-face
+   (let ((fn (symbol-name face)))
+     (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn)
+	 (list (list (if (string= (match-string 1 fn) "f")
+			 :foreground
+		       :background)
+		     (match-string 2 fn)))
+       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
-`facemenu-remove-all'."
+`facemenu-remove-special'."
   (interactive "r")
-  (put-text-property start end 'invisible t))
+  (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
-`facemenu-remove-all'."
+`facemenu-remove-special'."
   (interactive "r")
-  (put-text-property start end 'intangible t))
+  (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
-`facemenu-remove-all'."
+`facemenu-remove-special'."
   (interactive "r")
-  (put-text-property start end 'read-only t))
+  (add-text-properties start end '(read-only t)))
 
 ;;;###autoload
-(defun facemenu-remove-all (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))))
+    (remove-text-properties
+     start end '(face nil mouse-face nil))))
 
 ;;;###autoload
-(defun list-text-properties-at (p)
-  "Pop up a buffer listing text-properties at LOCATION."
-  (interactive "d")
-  (let ((props (text-properties-at p)))
-    (if (null props)
-	(message "None")
-      (with-output-to-temp-buffer "*Text Properties*"
-	(princ (format "Text properties at %d:\n\n" p))
-	(while props
-	  (princ (format "%-20s %S\n"
-			 (car props) (car (cdr props))))
-	  (setq props (cdr (cdr props))))))))
+(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'."
+  (interactive "*r") ; error if buffer is read-only despite the next line.
+  (let ((inhibit-read-only t))
+    (remove-text-properties
+     start end '(invisible nil intangible nil read-only nil))))
+
 ;;;###autoload
 (defun facemenu-read-color (&optional prompt)
   "Read a color using the minibuffer."
-  (let ((col (completing-read (or prompt "Color: ") 
-			      (or facemenu-color-alist
-				  (if (eq 'x window-system)
-				      (mapcar 'list (x-defined-colors))))
-			      nil t)))
+  (let* ((completion-ignore-case t)
+	 (col (completing-read (or prompt "Color: ")
+			       (or facemenu-color-alist
+				   (defined-colors))
+			       nil t)))
     (if (equal "" col)
 	nil
       col)))
 
 ;;;###autoload
-(defun list-colors-display (&optional list)
+(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
-colors to display.  Otherwise, this command computes a list
-of colors that the current display can handle."
+colors to display.  Otherwise, this command computes a list of
+colors that the current display can handle.  If the optional
+argument BUFFER-NAME is nil, it defaults to *Colors*."
   (interactive)
-  (if (and (null list) (eq 'x 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)))))))
-  (with-output-to-temp-buffer "*Colors*"
+  (when (and (null list) (> (display-color-cells) 0))
+    (setq list (list-colors-duplicates (defined-colors)))
+    (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
+      ;; Don't show more than what the display can handle.
+      (let ((lc (nthcdr (1- (display-color-cells)) list)))
+	(if lc
+	    (setcdr lc nil)))))
+  (with-output-to-temp-buffer (or buffer-name "*Colors*")
     (save-excursion
       (set-buffer standard-output)
-      (let ((facemenu-unlisted-faces t)
-	    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)))))
-	  (setq s (point))
-	  (insert "  " (car list) "\n")
-	  (put-text-property s (point) 'face 
-			     (facemenu-get-face 
-			      (intern (concat "fg:" (car list)))))
-	  (setq list (cdr list)))))))
+      (setq truncate-lines t)
+      (if temp-buffer-show-function
+	  (list-colors-print list)
+	;; Call list-colors-print from temp-buffer-show-hook
+	;; 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)))))
+
+(defun list-colors-print (list)
+  (dolist (color list)
+    (if (consp color)
+	(if (cdr color)
+	    (setq color (sort color (lambda (a b)
+				      (string< (downcase a)
+					       (downcase b))))))
+      (setq color (list color)))
+    (put-text-property
+     (prog1 (point)
+       (insert (car color))
+       (indent-to 22))
+     (point)
+     'face (cons 'background-color (car color)))
+    (put-text-property
+     (prog1 (point)
+       (insert " " (if (cdr color)
+		       (mapconcat 'identity (cdr color) ", ")
+		     (car color))))
+     (point)
+     'face (cons 'foreground-color (car color)))
+    (indent-to (max (- (window-width) 8) 44))
+    (insert (apply 'format "#%02x%02x%02x"
+		   (mapcar (lambda (c) (lsh c -8))
+			   (color-values (car color)))))
+
+    (insert "\n"))
+  (goto-char (point-min)))
+
+(defun list-colors-duplicates (&optional list)
+  "Return a list of colors with grouped duplicate colors.
+If a color has no duplicates, then the element of the returned list
+has the form '(COLOR-NAME).  The element of the returned list with
+duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
+This function uses the predicate `facemenu-color-equal' to compare
+color names.  If the optional argument LIST is non-nil, it should
+be a list of colors to display.  Otherwise, this function uses
+a list of colors that the current display can handle."
+  (let* ((list (mapcar 'list (or list (defined-colors))))
+	 (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)))))
+	  (progn
+	    (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
+	    (setcdr l (cdr (cdr l))))
+	(setq l (cdr l))))
+    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 (eq 'x window-system)
-	      (equal (x-color-values a) (x-color-values b))))))
+	((equal (color-values a) (color-values b)))))
 
-(defun facemenu-add-face (face start end)
+(defun facemenu-add-face (face &optional start end)
   "Add FACE to text between START and END.
-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.
+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.
+If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
+they are used to set the face information.
 
 As a special case, if FACE is `default', then the region is left with NO face
 text property.  Otherwise, selecting the default face would not have any
-effect."
-  (interactive "*xFace:\nr")
-  (if (eq face 'default)
-      (remove-text-properties start end '(face default))
-    (let ((part-start start) part-end)
-      (while (not (= part-start end))
-	(setq part-end (next-single-property-change part-start 'face nil end))
-	(let ((prev (get-text-property part-start 'face)))
-	  (put-text-property part-start part-end 'face
-			     (if (null prev)
-				 face
-			       (facemenu-discard-redundant-faces
-				(cons face
-				      (if (listp prev) prev (list prev)))))))
-	(setq part-start part-end)))))
-
-(defun facemenu-discard-redundant-faces (face-list &optional mask)
-  "Remove from FACE-LIST any faces that won't show at all.
-This means they have no non-nil elements that aren't also non-nil in an
-earlier face."
-  (let ((useful nil))
-    (cond ((null face-list) nil)
-	  ((null mask)
-	   (cons (car face-list)
-		 (facemenu-discard-redundant-faces
-		  (cdr face-list) 
-		  (copy-sequence (internal-get-face (car face-list))))))
-	  ((let ((i (length mask))
-		 (face (internal-get-face (car face-list))))
-	     (while (>= (setq i (1- i)) 0)
-	       (if (and (aref face i)
-			(not (aref mask i)))
-		   (progn (setq useful t)
-			  (aset mask i t))))
-	     useful)
-	   (cons (car face-list)
-		 (facemenu-discard-redundant-faces (cdr face-list) mask)))
-	  (t (facemenu-discard-redundant-faces (cdr face-list) mask)))))
-
-(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))
-		 (color (substring name 3)))
-	    (cond ((string-match "^fg:" name)
-		   (set-face-foreground face color)
-		   (and (eq 'x window-system) (x-color-defined-p color)))
-		  ((string-match "^bg:" name)
-		   (set-face-background face color)
-		   (and (eq 'x window-system) (x-color-defined-p color)))
-		  (t))))
-      symbol))
+effect.  See `facemenu-remove-face-function'."
+  (interactive "*xFace: \nr")
+  (if (and (eq face 'default)
+	   (not (eq facemenu-remove-face-function t)))
+      (if facemenu-remove-face-function
+	  (funcall facemenu-remove-face-function start end)
+	(if (and start (< start end))
+	    (remove-text-properties start end '(face default))
+	  (setq self-insert-face 'default
+		self-insert-face-command this-command)))
+    (if facemenu-add-face-function
+	(save-excursion
+	  (if end (goto-char end))
+	  (save-excursion
+	    (if start (goto-char start))
+	    (insert-before-markers
+	     (funcall facemenu-add-face-function face end)))
+	  (if facemenu-end-add-face
+	      (insert (if (stringp facemenu-end-add-face)
+			  facemenu-end-add-face
+			(funcall facemenu-end-add-face face)))))
+      (if (and start (< start end))
+	  (let ((part-start start) part-end)
+	    (while (not (= part-start end))
+	      (setq part-end (next-single-property-change part-start 'face
+							  nil end))
+	      (let ((prev (get-text-property part-start 'face)))
+		(put-text-property part-start part-end 'face
+				   (if (null prev)
+				       face
+				     (facemenu-active-faces
+				      (cons face
+					    (if (listp prev)
+						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)
+						  self-insert-face
+						(list self-insert-face)))
+				 face)
+	      self-insert-face-command this-command))))
+  (unless (facemenu-enable-faces-p)
+    (message "Font-lock mode will override any faces you set in this buffer")))
+
+(defun facemenu-active-faces (face-list &optional frame)
+  "Return from FACE-LIST those faces that would be used for display.
+This means each face attribute is not specified in a face earlier in FACE-LIST
+and such a face is therefore active when used to display text.
+If the optional argument FRAME is given, use the faces in that frame; otherwise
+use the selected frame.  If t, then the global, non-frame faces are used."
+  (let* ((mask-atts (copy-sequence
+		     (if (consp (car face-list))
+			 (face-attributes-as-vector (car face-list))
+		       (or (internal-lisp-face-p (car face-list) frame)
+			   (check-face (car face-list))))))
+	 (active-list (list (car face-list)))
+	 (face-list (cdr face-list))
+	 (mask-len (length mask-atts)))
+    (while face-list
+      (if (let ((face-atts
+		 (if (consp (car face-list))
+		     (face-attributes-as-vector (car face-list))
+		   (or (internal-lisp-face-p (car face-list) frame)
+		       (check-face (car face-list)))))
+		(i mask-len)
+		(useful nil))
+	    (while (>= (setq i (1- i)) 0)
+	      (and (not (memq (aref face-atts i) '(nil unspecified)))
+		   (memq (aref mask-atts i) '(nil unspecified))
+		   (aset mask-atts i (setq useful t))))
+	    useful)
+	  (setq active-list (cons (car face-list) active-list)))
+      (setq face-list (cdr face-list)))
+    (nreverse active-list)))
 
 (defun facemenu-add-new-face (face)
-  "Add a FACE to the appropriate Face menu.
-Automatically called when a new face is created."
-  (let* ((name (symbol-name face))
-	 (menu (cond ((string-match "^fg:" name) 
-		      (setq name (substring name 3))
-		      'facemenu-foreground-menu)
-		     ((string-match "^bg:" name) 
-		      (setq name (substring name 3))
-		      'facemenu-background-menu)
-		     (t 'facemenu-face-menu)))
+  "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
 	 (key (cdr (assoc face facemenu-keybindings)))
 	 function menu-val)
-    (cond ((eq t facemenu-unlisted-faces))
-	  ((memq face facemenu-unlisted-faces))
-	  (key ; has a keyboard equivalent.  These go at the front.
+    (if (symbolp face)
+	(setq name (symbol-name face)
+	      symbol face)
+      (setq name face
+	    symbol (intern name)))
+    (setq menu 'facemenu-face-menu)
+    (setq docstring
+	  (format "Select face `%s' for subsequent insertion."
+		  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.
+	  (key
 	   (setq function (intern (concat "facemenu-set-" name)))
 	   (fset function
-		 (` (lambda () (interactive)
-		      (facemenu-set-face (quote (, face))))))
+		 `(lambda ()
+		    ,docstring
+		    (interactive)
+		    (facemenu-set-face
+		     (quote ,symbol)
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-beginning))
+		     (if (and mark-active (not current-prefix-arg))
+			 (region-end)))))
 	   (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
-	    (lambda (m) (and (listp m) 
-			     (symbolp (car m))
-			     (face-equal (car m) face)))
-	    (cdr (symbol-function menu))))
-	  (t   ; No keyboard equivalent.  Figure out where to put it:
-	   (setq key (vector face)
+	  ;; Faces with no keyboard equivalent.  Figure out where to put it:
+	  ((or (eq t facemenu-listed-faces)
+	       (memq symbol facemenu-listed-faces))
+	   (setq key (vector symbol)
 		 function 'facemenu-set-face-from-menu
 		 menu-val (symbol-function menu))
 	   (if (and facemenu-new-faces-at-end
-		   (> (length menu-val) 3))
+		    (> (length menu-val) 3))
 	       (define-key-after menu-val key (cons name function)
 		 (car (nth (- (length menu-val) 3) menu-val)))
 	     (define-key menu key (cons name function))))))
   nil) ; Return nil for facemenu-iterate
 
+(defun facemenu-add-new-color (color menu)
+  "Add COLOR (a color name string) to the appropriate Face menu.
+MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
+Return the event type (a symbol) of the added menu entry.
+
+This is called whenever you use a new color."
+  (let (symbol docstring)
+    (unless (color-defined-p color)
+      (error "Color `%s' undefined" color))
+    (cond ((eq menu 'facemenu-foreground-menu)
+	   (setq docstring
+		 (format "Select foreground color %s for subsequent insertion."
+			 color)
+		 symbol (intern (concat "fg:" color))))
+	  ((eq menu 'facemenu-background-menu)
+	   (setq docstring
+		 (format "Select background color %s for subsequent insertion."
+			 color)
+		 symbol (intern (concat "bg:" color))))
+	  (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
+    (unless (facemenu-iterate ; Check if color is already in the menu.
+	     (lambda (m) (and (listp m)
+			      (eq (car m) symbol)))
+	     (cdr (symbol-function menu)))
+      ;; Color is not in the menu.  Figure out where to put it.
+      (let ((key (vector symbol))
+	    (function 'facemenu-set-face-from-menu)
+	    (menu-val (symbol-function menu)))
+	(if (and facemenu-new-faces-at-end
+		 (> (length menu-val) 3))
+	    (define-key-after menu-val key (cons color function)
+	      (car (nth (- (length menu-val) 3) menu-val)))
+	  (define-key menu key (cons color function)))))
+    symbol))
+
 (defun facemenu-complete-face-list (&optional oldlist)
-  "Return list of all faces that are look different.
-Starts with given ALIST of faces, and adds elements only if they display 
+  "Return list of all faces that look different.
+Starts with given ALIST of faces, and adds elements only if they display
 differently from any face already on the list.
-The faces on ALIST will end up at the end of the returned list, in reverse 
+The faces on ALIST will end up at the end of the returned list, in reverse
 order."
   (let ((list (nreverse (mapcar 'car oldlist))))
-    (facemenu-iterate 
-     (lambda (new-face) 
+    (facemenu-iterate
+     (lambda (new-face)
        (if (not (memq new-face list))
 	   (setq list (cons new-face list)))
        nil)
      (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)
 
+(provide 'facemenu)
+
+;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
 ;;; facemenu.el ends here