;; 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
;; 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:
(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")
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)
(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).
(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).
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.
(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."
(car iterate-list))
(facemenu-update)
-(add-hook 'menu-bar-final-items 'Face)
(add-hook 'after-change-functions 'facemenu-after-change)
;;; facemenu.el ends here
projects / emacs.git / commitdiff