(facemenu-get-face): Don't add to menu here.

(facemenu-face-menu, facemenu-foreground-menu,
	facemenu-background-menu): New or renamed variables for submenus.(facemenu-color-alist): Renamed from facemenu-colors.
(facemenu-add-new-face): New function.
(facemenu-update): Don't redo top-level menu;
	nothing should change.  Move menu setup to defvars.  Use
	facemenu-add-new-face. Changed global binding to C-down-mouse-3.
(facemenu-menu): "Update" item removed; should
	no longer be needed interactively.
(facemenu-complete-face-list): Just return faces,
	not keybindings.

1 files changed, 172 insertions, 171 deletions

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index f520ed43490..e5e2ba81001 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -21,9 +21,14 @@
 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, 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.  
+;; 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.  It is assumed that
+;; 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.  Such faces can also be created on
+;; demand from the "Other..." menu items.
 
 ;;; Installation:
 ;; Put this file somewhere on emacs's load-path, and put
@@ -31,12 +36,11 @@
 ;; in your .emacs file.
 
 ;;; Usage:
-;; Selecting a face from the menu or typing the keyboard equivalent
-;; will change the region to use that face.  
-;; If you use transient-mark-mode and the region is not active, the
-;; face will be remembered and used for the next insertion.  It will
-;; be forgotten if you move point or make other modifications before
-;; inserting or typing anything.
+;; Selecting a face from the menu or typing the keyboard equivalent will
+;; change the region to use that face.  If you use transient-mark-mode and the
+;; region is not active, the face will be remembered and used for the next
+;; 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-s (or ESC s) + letter:
@@ -82,12 +86,6 @@
 (defvar facemenu-key "\M-s"
   "Prefix to use for facemenu commands.")
 
-(defvar facemenu-keymap nil
-  "Map for keybindings of face commands.
-If nil, `facemenu-update' will create one.
-`Facemenu-update' also fills in the keymap according to the bindings
-requested in facemenu-keybindings.")
-
 (defvar facemenu-keybindings
   '((default     . "d")
     (bold        . "b")
@@ -113,94 +111,71 @@ If you change this variable after loading facemenu.el, you will need to call
 Set this before loading facemenu.el, or call `facemenu-update' after
 changing it.")
 
-(defvar facemenu-colors
-  (if (eq 'x window-system)
-      (mapcar 'list (x-defined-colors)))
-  "Alist of colors, used for completion.")
+(defvar facemenu-face-menu 
+  (let ((map (make-sparse-keymap "Face")))
+    (define-key map [other] (cons "Other..." 'facemenu-set-face))
+    map)
+  "Menu keymap for faces.")
+
+(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.")
+
+(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")
+
+(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))
+    map)
+  "Menu keymap for non-face text-properties.")
+
+(defvar facemenu-menu 
+  (let ((map (make-sparse-keymap "Face")))
+    (define-key map [display]  (cons "Display Faces" 'list-faces-display))
+    (define-key map [remove]   (cons "Remove Props" 'facemenu-remove-all))
+    (define-key map [sep1]     (list "-----------------"))
+    (define-key map [special]  (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 [face]     (cons "Face" facemenu-face-menu))
+    map)
+  "Facemenu top-level menu keymap")
+
+(defvar facemenu-keymap (make-sparse-keymap "Set face")
+  "Map for keyboard face-changing commands.
+`Facemenu-update' fills in the keymap according to the bindings
+requested in facemenu-keybindings.")
+
+;;; 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.")
 
 (defvar facemenu-next nil) ; set when we are going to set a face on next char.
 (defvar facemenu-loc nil)
 
-(defalias 'facemenu-foreground (make-sparse-keymap "Foreground"))
-(defalias 'facemenu-background (make-sparse-keymap "Background"))
-
 (defun facemenu-update ()
-  "Add or update the \"Face\" menu in the menu bar."
+  "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)
   
-  ;; Set up keymaps
-  (fset 'facemenu-menu (setq facemenu-menu (make-sparse-keymap "Face")))
-  (if (null facemenu-keymap)
-      (fset 'facemenu-keymap 
-            (setq facemenu-keymap (make-sparse-keymap "Set face"))))
-  (if facemenu-key
-      (define-key global-map facemenu-key facemenu-keymap))
-
-  ;; Define basic keys
-  ;; We construct this list structure explicitly because a quoted constant
-  ;; would be pure.
-  (define-key facemenu-menu [update]    (cons "Update Menu" 'facemenu-update))
-  (define-key facemenu-menu [display]   (cons "Display Faces" 
-                                              'list-faces-display))
-  (define-key facemenu-menu [sep1]      (list "-------------"))
-  (define-key facemenu-menu [remove]    (cons "Remove Properties"
-                                              'facemenu-remove-all))
-  (define-key facemenu-menu [read-only] (cons "Read-Only"
-                                              'facemenu-set-read-only))
-  (define-key facemenu-menu [invisible] (cons "Invisible"
-                                              'facemenu-set-invisible))
-  (define-key facemenu-menu [sep2]      (list "-------------"))
-  (define-key facemenu-menu [bg]        (cons "Background Color"
-                                              'facemenu-background))
-  (define-key facemenu-menu [fg]        (cons "Foreground Color"
-                                              'facemenu-foreground))
-  (define-key facemenu-menu [sep3]      (list "-------------"))
-  (define-key facemenu-menu [other]     (cons "Other..." 'facemenu-set-face))
-
-  (define-key 'facemenu-foreground "o" (cons "Other" 'facemenu-set-foreground))
-  (define-key 'facemenu-background "o" (cons "Other" 'facemenu-set-background))
-
-  ;; Define commands for face-changing
-  (facemenu-iterate
-   (lambda (f)
-     (let* ((face (car f))
-            (name (symbol-name face))
-            (key  (cdr f))
-            (menu (cond ((string-match "^fg:" name) 'facemenu-foreground)
-                        ((string-match "^bg:" name) 'facemenu-background)
-                        (t facemenu-menu))))
-       (if (memq menu '(facemenu-foreground facemenu-background))
-           (setq name (substring name 3)))
-       (cond ((memq face facemenu-unlisted-faces)
-              nil)
-             ((null key) (define-key menu (vector face) 
-                           (cons name 'facemenu-set-face-from-menu)))
-             (t (let ((function (intern (concat "facemenu-set-" name))))
-                  (fset function
-                        (` (lambda () (interactive)
-                             (facemenu-set-face (quote (, face))))))
-                  (define-key facemenu-keymap key (cons name function))
-                  (define-key menu key (cons name function))))))
-     nil)
-   (facemenu-complete-face-list facemenu-keybindings))
-
-  (define-key global-map (vector 'menu-bar 'Face) 
-    (cons "Face" facemenu-menu)))
-
-; We'd really like to name the menu items as follows,
-; but we can't since menu entries don't display text properties (yet?)
-; (let ((s (copy-sequence (symbol-name face))))
-;    (put-text-property 0 (1- (length s)) 
-;                       'face face s)
-;   s)
+  ;; Global bindings:
+  (define-key global-map [C-down-mouse-3] facemenu-menu)
+  (if facemenu-key (define-key global-map facemenu-key facemenu-keymap))
 
-;;;###autoload
-(defun facemenu-read-color (prompt)
-  "Read a color using the minibuffer."
-  (let ((col (completing-read (or  "Color: ") facemenu-colors nil t)))
-    (if (equal "" col)
-        nil
-      col)))
+  ;; Add each defined face to the menu.
+  (facemenu-iterate 'facemenu-add-new-face
+                    (facemenu-complete-face-list facemenu-keybindings)))
 
 ;;;###autoload
 (defun facemenu-set-face (face &optional start end)
@@ -222,6 +197,7 @@ typing a character cancels the request."
     (setq facemenu-next face
           facemenu-loc (point))))
 
+;;;###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).
@@ -236,6 +212,7 @@ typing a character cancels the request."
         (error "Unknown color: %s" color))
     (facemenu-set-face face 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).
@@ -296,87 +273,41 @@ This sets the `read-only' text property; it can be undone with
      start end '(face nil invisible nil intangible nil 
                       read-only nil category nil))))
 
-(defun facemenu-get-face (face)
-  "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 nil if
-given a bad color."
-  (if (internal-find-face face)
-      t
-    (make-face face)
-    (let* ((name (symbol-name face))
-           (color (substring name 3)))
-      (cond ((string-match "^fg:" name)
-             (set-face-foreground face color)
-             (define-key 'facemenu-foreground (vector face) 
-               (cons color 'facemenu-set-face-from-menu))
-             (x-color-defined-p color))
-            ((string-match "^bg:" name)
-             (set-face-background face color)
-             (define-key 'facemenu-background (vector face) 
-               (cons color 'facemenu-set-face-from-menu))
-             (x-color-defined-p color))
-            (t
-             (define-key facemenu-menu (vector face)
-               (cons name 'facemenu-set-face-from-menu))
-             t)))))
-
-(defun facemenu-after-change (begin end old-length)
-  "May set the face of just-inserted text to user's request.
-This only happens if the change is an insertion, and
-`facemenu-set-face[-from-menu]' was called with point at the
-beginning of the insertion."
-  (if (null facemenu-next)              ; exit immediately if no work
-      nil
-    (if (and (= 0 old-length)           ; insertion
-             (= facemenu-loc begin))    ; point wasn't moved in between
-        (facemenu-add-face facemenu-next begin end))
-    (setq facemenu-next nil)))
-
-(defun facemenu-complete-face-list (&optional oldlist)
-  "Return alist of all faces that are look different.
-Starts with given LIST of faces, and adds elements only if they display 
-differently from any face already on the list.
-The original LIST will end up at the end of the returned list, in reverse 
-order.  The elements added will have null cdrs."
-  (let ((list nil))
-    (facemenu-iterate 
-     (function
-      (lambda (item)
-        (if (internal-find-face (car item))
-            (setq list (cons item list)))
-        nil))
-     oldlist)
-    (facemenu-iterate 
-     (function
-      (lambda (new-face) 
-        (if (not (facemenu-iterate 
-                  (function 
-                   (lambda (item) (face-equal (car item) new-face t)))
-                  list))
-            (setq list (cons (cons new-face nil) list)))
-        nil))
-     (nreverse (face-list)))
-    list))
+;;;###autoload
+(defun facemenu-read-color (prompt)
+  "Read a color using the minibuffer."
+  (let ((col (completing-read (or  "Color: ") 
+                              (or facemenu-color-alist
+                                  (if (eq 'x window-system)
+                                      (mapcar 'list (x-defined-colors))))
+                              nil t)))
+    (if (equal "" col)
+        nil
+      col)))
 
 (defun facemenu-add-face (face 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."
+removed from the list.
+
+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")
-  (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))))
+  (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.
@@ -401,6 +332,77 @@ earlier face."
                  (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 nil if
+given a bad color."
+  (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)))))
+
+(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)))
+         key)
+    (cond ((memq face facemenu-unlisted-faces)
+           nil)
+          ((setq key (cdr (assoc face facemenu-keybindings)))
+           (let ((function (intern (concat "facemenu-set-" name))))
+             (fset function
+                   (` (lambda () (interactive)
+                        (facemenu-set-face (quote (, face))))))
+             (define-key facemenu-keymap key (cons name function))
+             (define-key menu key (cons name function))))
+          (t (define-key menu (vector face) 
+               (cons name 'facemenu-set-face-from-menu)))))
+  ;; Return nil for facemenu-iterate's benefit:
+  nil)
+
+(defun facemenu-after-change (begin end old-length)
+  "May set the face of just-inserted text to user's request.
+This only happens if the change is an insertion, and
+`facemenu-set-face[-from-menu]' was called with point at the
+beginning of the insertion."
+  (if (null facemenu-next)              ; exit immediately if no work
+      nil
+    (if (and (= 0 old-length)           ; insertion
+             (= facemenu-loc begin))    ; point wasn't moved in between
+        (facemenu-add-face facemenu-next begin end))
+    (setq facemenu-next nil)))
+
+(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 
+differently from any face already on the list.
+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) 
+       (if (not (memq new-face list))
+           (setq list (cons new-face list)))
+       nil)
+     (nreverse (face-list)))
+    list))
+
 (defun facemenu-iterate (func iterate-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."
@@ -409,7 +411,6 @@ Returns the non-nil value it found, or nil if all were nil."
   (car iterate-list))
 
 (facemenu-update)
-(add-hook 'menu-bar-final-items 'Face)
 (add-hook 'after-change-functions 'facemenu-after-change)
 
 ;;; facemenu.el ends here