X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/41e7728940ada2a9370cd7b3cd23006b434e1d22..ca088b04376178d1305ff9d0866c20263f4a79bf:/lisp/facemenu.el diff --git a/lisp/facemenu.el b/lisp/facemenu.el dissimilarity index 69% index f01b493f6d..cd3998520a 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -1,291 +1,780 @@ -;;; facemenu.el -- Create a face menu for interactively adding fonts to text -;; Copyright (c) 1994 Free Software Foundation, Inc. - -;; Author: Boris Goldowsky -;; Keywords: faces - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; 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. - -;;; 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. - -;;; Installation: -;; Put this file somewhere on emacs's load-path, and put -;; (require 'facemenu) -;; 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. -;; -;; Faces can be selected from the keyboard as well. -;; The standard keybindings are M-s (or ESC s) + letter: -;; M-s i = "set italic", M-s b = "set bold", etc. - -;;; Customization: -;; An alternative set of keybindings that may be easier to type can be set up -;; using "Hyper" keys. This requires that you set up a hyper-key on your -;; keyboard. On my system, putting the following command in my .xinitrc: -;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" -;; makes the key labelled "Alt" act as a hyper key, but check with local -;; X-perts for how to do it on your system. If you do this, then put the -;; following in your .emacs before the (require 'facemenu): -;; (setq facemenu-keybindings -;; '((default . [?\H-d]) -;; (bold . [?\H-b]) -;; (italic . [?\H-i]) -;; (bold-italic . [?\H-o]) -;; (underline . [?\H-u]))) -;; (setq facemenu-keymap global-map) -;; (setq facemenu-key nil) -;; -;; In general, the order of the faces that appear in the menu and their -;; keybindings can be controlled by setting the variable -;; `facemenu-keybindings'. Faces that you never want to add to your -;; document (e.g., `region') are listed in `facemenu-unlisted-faces'. - -;;; Known Problems: -;; Only works with Emacs 19.23 and later. -;; -;; There is at present no way to display what the faces look like in -;; the menu itself. -;; -;; `list-faces-display' shows the faces in a different order than -;; this menu, which could be confusing. I do /not/ sort the list -;; alphabetically, because I like the default order: it puts the most -;; basic, common fonts first. -;; -;; Please send me any other problems, comments or ideas. - -;;; Code: - -(provide 'facemenu) - -(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") - (italic . "i") - (bold-italic . "o") ; O for "Oblique" or "bOld"... - (underline . "u")) - "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 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. - -If you change this variable after loading facemenu.el, you will need to call -`facemenu-update' to make it take effect.") - -(defvar facemenu-unlisted-faces - '(modeline region secondary-selection highlight scratch-face) - "Faces that are not included in the Face menu. -Set this before loading facemenu.el, or call `facemenu-update' after -changing it.") - -(defvar facemenu-next nil) ; set when we are going to set a face on next char. -(defvar facemenu-loc nil) - -(defun facemenu-update () - "Add or update the \"Face\" menu in the menu bar." - (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 [other] (cons "Other..." 'facemenu-set-face)) - (define-key facemenu-menu [sep2] (list "---Special---")) - (define-key facemenu-menu [invisible] (cons "Invisible" - 'facemenu-set-invisible)) - (define-key facemenu-menu [read-only] (cons "Read-Only" - 'facemenu-set-read-only)) - (define-key facemenu-menu [remove] (cons "Remove Properties" - 'facemenu-remove-all)) - (define-key facemenu-menu [sep1] (list "-------------")) - (define-key facemenu-menu [display] (cons "Display" 'list-faces-display)) - (define-key facemenu-menu [update] (cons "Update Menu" 'facemenu-update)) - - ;; Define commands for face-changing - (facemenu-iterate - (function - (lambda (f) - (let ((face (car f)) - (name (symbol-name (car f))) - (key (cdr f))) - (cond ((memq face facemenu-unlisted-faces) - nil) - ((null key) (define-key facemenu-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 facemenu-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-set-face (face &optional start end) - "Set the face of the region or next character typed. -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 \(via `self-insert-command') will be set to -the the selected face. Moving point or switching buffers before -typing a character cancels the request." - (interactive (list (read-face-name "Use face: "))) - (if mark-active - (put-text-property (or start (region-beginning)) - (or end (region-end)) - 'face face) - (setq facemenu-next face facemenu-loc (point)))) - -(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 \(via `self-insert-command') will be set to -the the selected face. Moving point or switching buffers before -typing a character cancels the request." - (interactive (let ((keys (this-command-keys))) - (list (elt keys (1- (length keys))) - (if mark-active (region-beginning)) - (if mark-active (region-end))))) - (if start - (put-text-property start end 'face face) - (setq facemenu-next face facemenu-loc (point)))) - -(defun facemenu-set-invisible (start end) - "Make the region invisible. -This sets the `invisible' text property; it can be undone with -`facemenu-remove-all'." - (interactive "r") - (put-text-property start end 'invisible t)) - -(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'." - (interactive "r") - (put-text-property start end 'intangible t)) - -(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'." - (interactive "r") - (put-text-property start end 'read-only t)) - -(defun facemenu-remove-all (start end) - "Remove all text properties that facemenu added to region." - (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)))) - -(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 - (put-text-property begin end 'face facemenu-next)) - (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)) - -(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." - (while (and iterate-list (not (funcall func (car iterate-list)))) - (setq iterate-list (cdr iterate-list))) - (car iterate-list)) - -(facemenu-update) -(add-hook 'menu-bar-final-items 'Face) -(add-hook 'after-change-functions 'facemenu-after-change) - -;;; facemenu.el ends here - +;;; facemenu.el --- create a face menu for interactively adding fonts to text + +;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Boris Goldowsky +;; Keywords: faces + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; 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, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, 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. +;; +;; The menu also contains submenus for indentation and justification-changing +;; commands. + +;;; 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. +;; +;; 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 +;; using "Alt" or "Hyper" keys. This requires that you either have or create +;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key +;; labeled "Alt", but to make it act as an Alt key I have to put this command +;; into my .xinitrc: +;; xmodmap -e "add Mod3 = Alt_L" +;; Or, I can make it into a Hyper key with this: +;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" +;; Check with local X-perts for how to do it on your system. +;; Then you can define your keybindings with code like this in your .emacs: +;; (setq facemenu-keybindings +;; '((default . [?\H-d]) +;; (bold . [?\H-b]) +;; (italic . [?\H-i]) +;; (bold-italic . [?\H-l]) +;; (underline . [?\H-u]))) +;; (facemenu-update) +;; (setq facemenu-keymap global-map) +;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color +;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color +;; +;; 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'. + +;;; Known Problems: +;; Bold and Italic do not combine to create bold-italic if you select them +;; both, although most other combinations (eg bold + underline + some color) +;; do the intuitive thing. +;; +;; There is at present no way to display what the faces look like in +;; the menu itself. +;; +;; `list-faces-display' shows the faces in a different order than +;; this menu, which could be confusing. I do /not/ sort the list +;; alphabetically, because I like the default order: it puts the most +;; basic, common fonts first. +;; +;; Please send me any other problems, comments or ideas. + +;;; Code: + +(eval-when-compile + (require 'help) + (require 'button)) + +;;; Provide some binding for startup: +;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap) +;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap) + +;; 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-") + +(defcustom facemenu-keybindings + '((default . "d") + (bold . "b") + (italic . "i") + (bold-italic . "l") ; {bold} intersect {italic} = {l} + (underline . "u")) + "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 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. + +If you change this variable after loading facemenu.el, you will need to call +`facemenu-update' to make it take effect." + :type '(repeat (cons face string)) + :group 'facemenu) + +(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." + :type 'boolean + :group 'facemenu) + +(defcustom facemenu-unlisted-faces + `(modeline region secondary-selection highlight scratch-face + ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") + ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") + ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")) + "*List of faces not to include in the Face menu. +Each element may be either a symbol, which is the name of a face, or a string, +which is a regular expression to be matched against face names. Matching +faces will not be added to the menu. + +You can set this list before loading facemenu.el, or add a face to it before +creating that face if you do not want it to be listed. If you change the +variable so as to eliminate faces that have already been added to the menu, +call `facemenu-update' to recalculate the menu contents. + +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." + :type '(choice (const :tag "Don't add faces" t) + (const :tag "None (do add any face)" nil) + (repeat (choice symbol regexp))) + :group 'facemenu) + +;;;###autoload +(defvar facemenu-face-menu + (let ((map (make-sparse-keymap "Face"))) + (define-key map "o" (cons "Other..." 'facemenu-set-face)) + map) + "Menu keymap for faces.") +;;;###autoload +(defalias 'facemenu-face-menu facemenu-face-menu) + +;;;###autoload +(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.") +;;;###autoload +(defalias 'facemenu-foreground-menu facemenu-foreground-menu) + +;;;###autoload +(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.") +;;;###autoload +(defalias 'facemenu-background-menu facemenu-background-menu) + +;;;###autoload +(defvar facemenu-special-menu + (let ((map (make-sparse-keymap "Special"))) + (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 +(defalias 'facemenu-special-menu facemenu-special-menu) + +;;;###autoload +(defvar facemenu-justification-menu + (let ((map (make-sparse-keymap "Justification"))) + (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 +(defalias 'facemenu-justification-menu facemenu-justification-menu) + +;;;###autoload +(defvar facemenu-indentation-menu + (let ((map (make-sparse-keymap "Indentation"))) + (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 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 + (let ((map (make-sparse-keymap "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.") + +(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) + + ;; 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) + "Add FACE to the region or next character typed. +This adds FACE to the top of the face list; any faces lower on the list that +will not show through at all will be removed. + +Interactively, reads the face name with 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) + (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) + (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. +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)))) + (unless (color-defined-p color) + (message "Color `%s' undefined" color)) + (facemenu-add-new-color color 'facemenu-foreground-menu) + (facemenu-add-face (list (list :foreground color)) start end)) + +;;;###autoload +(defun facemenu-set-background (color &optional 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)))) + (unless (color-defined-p color) + (message "Color `%s' undefined" color)) + (facemenu-add-new-color color 'facemenu-background-menu) + (facemenu-add-face (list (list :background color)) 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 (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 (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-add-face face))) + +;;;###autoload +(defun facemenu-set-invisible (start end) + "Make the region invisible. +This sets the `invisible' text property; it can be undone with +`facemenu-remove-special'." + (interactive "r") + (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-special'." + (interactive "r") + (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-special'." + (interactive "r") + (add-text-properties start end '(read-only t))) + +;;;###autoload +(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 mouse-face nil)))) + +;;;###autoload +(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 + (defined-colors)) + nil t))) + (if (equal "" col) + nil + col))) + +;;;###autoload +(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. If the optional +argument BUFFER-NAME is nil, it defaults to *Colors*." + (interactive) + (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) + (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 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) + ((equal (color-values a) (color-values b))))) + +(defun facemenu-add-face (face &optional start end) + "Add FACE to text between START and END. +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. 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))))))) + (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))))) + +(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-get-face (symbol) + "Make sure FACE exists. +If not, create it and add it to the appropriate menu. Return the SYMBOL." + (let ((name (symbol-name symbol))) + (cond ((facep symbol)) + (t (make-face symbol)))) + symbol) + +(defun facemenu-add-new-face (face) + "Add FACE (a face) to the Face menu. + +This is called whenever you create a new face." + (let* (name + symbol + menu docstring + (key (cdr (assoc face facemenu-keybindings))) + function menu-val) + (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 ((eq t facemenu-unlisted-faces)) + ((memq symbol facemenu-unlisted-faces)) + ;; test against regexps in facemenu-unlisted-faces + ((let ((unlisted facemenu-unlisted-faces) + (matched nil)) + (while (and unlisted (not matched)) + (if (and (stringp (car unlisted)) + (string-match (car unlisted) name)) + (setq matched t) + (setq unlisted (cdr unlisted)))) + matched)) + (key ; has a keyboard equivalent. These go at the front. + (setq function (intern (concat "facemenu-set-" name))) + (fset function + `(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) symbol))) + (cdr (symbol-function menu)))) + (t ; No keyboard equivalent. Figure out where to put it: + (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)) + (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 &optional menu) + "Add COLOR (a color name string) to the appropriate Face menu. +MENU should be `facemenu-foreground-menu' or +`facemenu-background-menu'. + +This is called whenever you use a new color." + (let* (name + symbol + docstring + function menu-val key + (color-p (memq menu '(facemenu-foreground-menu + facemenu-background-menu)))) + (unless (stringp color) + (error "%s is not a color" color)) + (setq name color + symbol (intern name)) + + (cond ((eq menu 'facemenu-foreground-menu) + (setq docstring + (format "Select foreground color %s for subsequent insertion." + name))) + ((eq menu 'facemenu-background-menu) + (setq docstring + (format "Select background color %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)) + (stringp (cadr m)) + (string-equal (cadr m) color))) + (cdr (symbol-function menu)))) + (t ; No keyboard equivalent. Figure out where to put it: + (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)) + (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-complete-face-list (&optional oldlist) + "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 +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 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 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