diff options
Diffstat (limited to 'lisp/facemenu.el')
| -rw-r--r-- | lisp/facemenu.el | 343 |
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 |