Mercurial > emacs

--- a/lisp/facemenu.el	Thu Oct 20 18:11:27 1994 +0000
+++ b/lisp/facemenu.el	Thu Oct 20 18:15:25 1994 +0000
@@ -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 @@
 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))
+  ;; Global bindings:
+  (define-key global-map [C-down-mouse-3] facemenu-menu)
+  (if facemenu-key (define-key global-map facemenu-key facemenu-keymap))

-  ;; 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)
-
-;;;###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 @@
     (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 @@
 	(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 @@
      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 @@
 		 (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 @@
   (car iterate-list))

 (facemenu-update)
-(add-hook 'menu-bar-final-items 'Face)
 (add-hook 'after-change-functions 'facemenu-after-change)

 ;;; facemenu.el ends here