lisp/facemenu.el

   1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
   2
   3 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Boris Goldowsky <boris@gnu.org>
   7 ;; Keywords: faces
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This file defines a menu of faces (bold, italic, etc) which allows you to
  29 ;; set the face used for a region of the buffer.  Some faces also have
  30 ;; keybindings, which are shown in the menu.
  31 ;;
  32 ;; The menu also contains submenus for indentation and justification-changing
  33 ;; commands.
  34
  35 ;;; Usage:
  36 ;; Selecting a face from the menu or typing the keyboard equivalent will
  37 ;; change the region to use that face.  If you use transient-mark-mode and the
  38 ;; region is not active, the face will be remembered and used for the next
  39 ;; insertion.  It will be forgotten if you move point or make other
  40 ;; modifications before inserting or typing anything.
  41 ;;
  42 ;; Faces can be selected from the keyboard as well.
  43 ;; The standard keybindings are M-o (or ESC o) + letter:
  44 ;; M-o i = "set italic",  M-o b = "set bold", etc.
  45
  46 ;;; Customization:
  47 ;; An alternative set of keybindings that may be easier to type can be set up
  48 ;; using "Alt" or "Hyper" keys.  This requires that you either have or create
  49 ;; an Alt or Hyper key on your keyboard.  On my keyboard, there is a key
  50 ;; labeled "Alt", but to make it act as an Alt key I have to put this command
  51 ;; into my .xinitrc:
  52 ;;    xmodmap -e "add Mod3 = Alt_L"
  53 ;; Or, I can make it into a Hyper key with this:
  54 ;;    xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
  55 ;; Check with local X-perts for how to do it on your system.
  56 ;; Then you can define your keybindings with code like this in your .emacs:
  57 ;;   (setq facemenu-keybindings
  58 ;;    '((default     . [?\H-d])
  59 ;;      (bold        . [?\H-b])
  60 ;;      (italic      . [?\H-i])
  61 ;;      (bold-italic . [?\H-l])
  62 ;;      (underline   . [?\H-u])))
  63 ;;   (facemenu-update)
  64 ;;   (setq facemenu-keymap global-map)
  65 ;;   (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
  66 ;;   (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
  67 ;;
  68 ;; The order of the faces that appear in the menu and their keybindings can be
  69 ;; controlled by setting the variables `facemenu-keybindings' and
  70 ;; `facemenu-new-faces-at-end'.  List faces that you want to use in documents
  71 ;; in `facemenu-listed-faces'.
  72
  73 ;;; Known Problems:
  74 ;; Bold and Italic do not combine to create bold-italic if you select them
  75 ;; both, although most other combinations (eg bold + underline + some color)
  76 ;; do the intuitive thing.
  77 ;;
  78 ;; There is at present no way to display what the faces look like in
  79 ;; the menu itself.
  80 ;;
  81 ;; `list-faces-display' shows the faces in a different order than
  82 ;; this menu, which could be confusing.  I do /not/ sort the list
  83 ;; alphabetically, because I like the default order: it puts the most
  84 ;; basic, common fonts first.
  85 ;;
  86 ;; Please send me any other problems, comments or ideas.
  87
  88 ;;; Code:
  89
  90 (eval-when-compile
  91   (require 'help)
  92   (require 'button))
  93
  94 ;;; Provide some binding for startup:
  95 ;;;###autoload (define-key global-map "\M-o" 'facemenu-keymap)
  96 ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
  97
  98 ;; Global bindings:
  99 (define-key global-map [C-down-mouse-2] 'facemenu-menu)
 100 (define-key global-map "\M-o" 'facemenu-keymap)
 101
 102 (defgroup facemenu nil
 103   "Create a face menu for interactively adding fonts to text."
 104   :group 'faces
 105   :prefix "facemenu-")
 106
 107 (defcustom facemenu-keybindings
 108   '((default     . "d")
 109     (bold        . "b")
 110     (italic      . "i")
 111     (bold-italic . "l") ; {bold} intersect {italic} = {l}
 112     (underline   . "u"))
 113   "Alist of interesting faces and keybindings.
 114 Each element is itself a list: the car is the name of the face,
 115 the next element is the key to use as a keyboard equivalent of the menu item;
 116 the binding is made in `facemenu-keymap'.
 117
 118 The faces specifically mentioned in this list are put at the top of
 119 the menu, in the order specified.  All other faces which are defined
 120 in `facemenu-listed-faces' are listed after them, but get no
 121 keyboard equivalents.
 122
 123 If you change this variable after loading facemenu.el, you will need to call
 124 `facemenu-update' to make it take effect."
 125   :type '(repeat (cons face string))
 126   :group 'facemenu)
 127
 128 (defcustom facemenu-new-faces-at-end t
 129   "*Where in the menu to insert newly-created faces.
 130 This should be nil to put them at the top of the menu, or t to put them
 131 just before \"Other\" at the end."
 132   :type 'boolean
 133   :group 'facemenu)
 134
 135 (defcustom facemenu-listed-faces nil
 136   "*List of faces to include in the Face menu.
 137 Each element should be a symbol, which is the name of a face.
 138 The \"basic \" faces in `facemenu-keybindings' are automatically
 139 added to the Face menu, and are not included in this list.
 140
 141 You can set this list before loading facemenu.el, or add a face to it before
 142 creating that face if you want it to be listed.  If you change the
 143 variable so as to eliminate faces that have already been added to the menu,
 144 call `facemenu-update' to recalculate the menu contents.
 145
 146 If this variable is t, all faces will be added to the menu.  This
 147 is useful for setting temporarily if you want to add faces to the
 148 menu when they are created."
 149   :type '(choice (const :tag "List all faces" t)
 150                  (const :tag "None" nil)
 151                  (repeat symbol))
 152   :group 'facemenu
 153   :version "22.1")
 154
 155 ;;;###autoload
 156 (defvar facemenu-face-menu
 157   (let ((map (make-sparse-keymap "Face")))
 158     (define-key map "o" (cons "Other..." 'facemenu-set-face))
 159     map)
 160   "Menu keymap for faces.")
 161 ;;;###autoload
 162 (defalias 'facemenu-face-menu facemenu-face-menu)
 163 (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
 164
 165 ;;;###autoload
 166 (defvar facemenu-foreground-menu
 167   (let ((map (make-sparse-keymap "Foreground Color")))
 168     (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
 169     map)
 170   "Menu keymap for foreground colors.")
 171 ;;;###autoload
 172 (defalias 'facemenu-foreground-menu facemenu-foreground-menu)
 173 (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
 174
 175 ;;;###autoload
 176 (defvar facemenu-background-menu
 177   (let ((map (make-sparse-keymap "Background Color")))
 178     (define-key map "o" (cons "Other..." 'facemenu-set-background))
 179     map)
 180   "Menu keymap for background colors.")
 181 ;;;###autoload
 182 (defalias 'facemenu-background-menu facemenu-background-menu)
 183 (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
 184
 185 ;;; Condition for enabling menu items that set faces.
 186 (defun facemenu-enable-faces-p ()
 187   (not (and font-lock-mode font-lock-defaults)))
 188
 189 ;;;###autoload
 190 (defvar facemenu-special-menu
 191   (let ((map (make-sparse-keymap "Special")))
 192     (define-key map [?s] (cons (purecopy "Remove Special")
 193                                'facemenu-remove-special))
 194     (define-key map [?t] (cons (purecopy "Intangible")
 195                                'facemenu-set-intangible))
 196     (define-key map [?v] (cons (purecopy "Invisible")
 197                                'facemenu-set-invisible))
 198     (define-key map [?r] (cons (purecopy "Read-Only")
 199                                'facemenu-set-read-only))
 200     map)
 201   "Menu keymap for non-face text-properties.")
 202 ;;;###autoload
 203 (defalias 'facemenu-special-menu facemenu-special-menu)
 204
 205 ;;;###autoload
 206 (defvar facemenu-justification-menu
 207   (let ((map (make-sparse-keymap "Justification")))
 208     (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
 209     (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
 210     (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
 211     (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
 212     (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
 213     map)
 214   "Submenu for text justification commands.")
 215 ;;;###autoload
 216 (defalias 'facemenu-justification-menu facemenu-justification-menu)
 217
 218 ;;;###autoload
 219 (defvar facemenu-indentation-menu
 220   (let ((map (make-sparse-keymap "Indentation")))
 221     (define-key map [decrease-right-margin]
 222       (cons (purecopy "Indent Right Less") 'decrease-right-margin))
 223     (define-key map [increase-right-margin]
 224       (cons (purecopy "Indent Right More") 'increase-right-margin))
 225     (define-key map [decrease-left-margin]
 226       (cons (purecopy "Indent Less") 'decrease-left-margin))
 227     (define-key map [increase-left-margin]
 228       (cons (purecopy "Indent More") 'increase-left-margin))
 229     map)
 230   "Submenu for indentation commands.")
 231 ;;;###autoload
 232 (defalias 'facemenu-indentation-menu facemenu-indentation-menu)
 233
 234 ;; This is split up to avoid an overlong line in loaddefs.el.
 235 ;;;###autoload
 236 (defvar facemenu-menu nil
 237   "Facemenu top-level menu keymap.")
 238 ;;;###autoload
 239 (setq facemenu-menu (make-sparse-keymap "Text Properties"))
 240 ;;;###autoload
 241 (let ((map facemenu-menu))
 242   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
 243   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
 244   (define-key map [dp] (cons (purecopy "Describe Properties")
 245                              'describe-text-properties))
 246   (define-key map [ra] (cons (purecopy "Remove Text Properties")
 247                              'facemenu-remove-all))
 248   (define-key map [rm] (cons (purecopy "Remove Face Properties")
 249                              'facemenu-remove-face-props))
 250   (define-key map [s1] (list (purecopy "--"))))
 251 ;;;###autoload
 252 (let ((map facemenu-menu))
 253   (define-key map [in] (cons (purecopy "Indentation")
 254                              'facemenu-indentation-menu))
 255   (define-key map [ju] (cons (purecopy "Justification")
 256                              'facemenu-justification-menu))
 257   (define-key map [s2] (list (purecopy "--")))
 258   (define-key map [sp] (cons (purecopy "Special Properties")
 259                              'facemenu-special-menu))
 260   (define-key map [bg] (cons (purecopy "Background Color")
 261                              'facemenu-background-menu))
 262   (define-key map [fg] (cons (purecopy "Foreground Color")
 263                              'facemenu-foreground-menu))
 264   (define-key map [fc] (cons (purecopy "Face")
 265                              'facemenu-face-menu)))
 266 ;;;###autoload
 267 (defalias 'facemenu-menu facemenu-menu)
 268
 269 (defvar facemenu-keymap
 270   (let ((map (make-sparse-keymap "Set face")))
 271     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
 272     map)
 273   "Keymap for face-changing commands.
 274 `Facemenu-update' fills in the keymap according to the bindings
 275 requested in `facemenu-keybindings'.")
 276 (defalias 'facemenu-keymap facemenu-keymap)
 277
 278
 279 (defcustom facemenu-add-face-function nil
 280   "Function called at beginning of text to change or nil.
 281 This function is passed the FACE to set and END of text to change, and must
 282 return a string which is inserted.  It may set `facemenu-end-add-face'."
 283   :type '(choice (const :tag "None" nil)
 284                  function)
 285   :group 'facemenu)
 286
 287 (defcustom facemenu-end-add-face nil
 288   "String to insert or function called at end of text to change or nil.
 289 This function is passed the FACE to set, and must return a string which is
 290 inserted."
 291   :type '(choice (const :tag "None" nil)
 292                  string
 293                  function)
 294   :group 'facemenu)
 295
 296 (defcustom facemenu-remove-face-function nil
 297   "When non-nil, this is a function called to remove faces.
 298 This function is passed the START and END of text to change.
 299 May also be t meaning to use `facemenu-add-face-function'."
 300   :type '(choice (const :tag "None" nil)
 301                  (const :tag "Use add-face" t)
 302                  function)
 303   :group 'facemenu)
 304
 305 ;;; Internal Variables
 306
 307 (defvar facemenu-color-alist nil
 308   "Alist of colors, used for completion.
 309 If this is nil, then the value of (defined-colors) is used.")
 310
 311 (defun facemenu-update ()
 312   "Add or update the \"Face\" menu in the menu bar.
 313 You can call this to update things if you change any of the menu configuration
 314 variables."
 315   (interactive)
 316
 317   ;; Add each defined face to the menu.
 318   (facemenu-iterate 'facemenu-add-new-face
 319                     (facemenu-complete-face-list facemenu-keybindings)))
 320
 321 ;;;###autoload
 322 (defun facemenu-set-face (face &optional start end)
 323   "Add FACE to the region or next character typed.
 324 This adds FACE to the top of the face list; any faces lower on the list that
 325 will not show through at all will be removed.
 326
 327 Interactively, reads the face name with the minibuffer.
 328
 329 If the region is active (normally true except in Transient Mark mode)
 330 and there is no prefix argument, this command sets the region to the
 331 requested face.
 332
 333 Otherwise, this command specifies the face for the next character
 334 inserted.  Moving point or switching buffers before
 335 typing a character to insert cancels the specification."
 336   (interactive (list (progn
 337                        (barf-if-buffer-read-only)
 338                        (read-face-name "Use face"))
 339                      (if (and mark-active (not current-prefix-arg))
 340                          (region-beginning))
 341                      (if (and mark-active (not current-prefix-arg))
 342                          (region-end))))
 343   (facemenu-add-new-face face)
 344   (facemenu-add-face face start end))
 345
 346 ;;;###autoload
 347 (defun facemenu-set-foreground (color &optional start end)
 348   "Set the foreground COLOR of the region or next character typed.
 349 This command reads the color in the minibuffer.
 350
 351 If the region is active (normally true except in Transient Mark mode)
 352 and there is no prefix argument, this command sets the region to the
 353 requested face.
 354
 355 Otherwise, this command specifies the face for the next character
 356 inserted.  Moving point or switching buffers before
 357 typing a character to insert cancels the specification."
 358   (interactive (list (progn
 359                        (barf-if-buffer-read-only)
 360                        (facemenu-read-color "Foreground color: "))
 361                      (if (and mark-active (not current-prefix-arg))
 362                          (region-beginning))
 363                      (if (and mark-active (not current-prefix-arg))
 364                          (region-end))))
 365   (facemenu-set-face-from-menu
 366    (facemenu-add-new-color color 'facemenu-foreground-menu)
 367    start end))
 368
 369 ;;;###autoload
 370 (defun facemenu-set-background (color &optional start end)
 371   "Set the background COLOR of the region or next character typed.
 372 This command reads the color in the minibuffer.
 373
 374 If the region is active (normally true except in Transient Mark mode)
 375 and there is no prefix argument, this command sets the region to the
 376 requested face.
 377
 378 Otherwise, this command specifies the face for the next character
 379 inserted.  Moving point or switching buffers before
 380 typing a character to insert cancels the specification."
 381   (interactive (list (progn
 382                        (barf-if-buffer-read-only)
 383                        (facemenu-read-color "Background color: "))
 384                      (if (and mark-active (not current-prefix-arg))
 385                          (region-beginning))
 386                      (if (and mark-active (not current-prefix-arg))
 387                          (region-end))))
 388   (facemenu-set-face-from-menu
 389    (facemenu-add-new-color color 'facemenu-background-menu)
 390    start end))
 391
 392 ;;;###autoload
 393 (defun facemenu-set-face-from-menu (face start end)
 394   "Set the FACE of the region or next character typed.
 395 This function is designed to be called from a menu; FACE is determined
 396 using the event type of the menu entry.  If FACE is a symbol whose
 397 name starts with \"fg:\" or \"bg:\", then this functions sets the
 398 foreground or background to the color specified by the rest of the
 399 symbol's name.  Any other symbol is considered the name of a face.
 400
 401 If the region is active (normally true except in Transient Mark mode)
 402 and there is no prefix argument, this command sets the region to the
 403 requested face.
 404
 405 Otherwise, this command specifies the face for the next character
 406 inserted.  Moving point or switching buffers before typing a character
 407 to insert cancels the specification."
 408   (interactive (list last-command-event
 409                      (if (and mark-active (not current-prefix-arg))
 410                          (region-beginning))
 411                      (if (and mark-active (not current-prefix-arg))
 412                          (region-end))))
 413   (barf-if-buffer-read-only)
 414   (facemenu-add-face
 415    (let ((fn (symbol-name face)))
 416      (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn)
 417          (list (list (if (string= (match-string 1 fn) "f")
 418                          :foreground
 419                        :background)
 420                      (match-string 2 fn)))
 421        face))
 422    start end))
 423
 424 ;;;###autoload
 425 (defun facemenu-set-invisible (start end)
 426   "Make the region invisible.
 427 This sets the `invisible' text property; it can be undone with
 428 `facemenu-remove-special'."
 429   (interactive "r")
 430   (add-text-properties start end '(invisible t)))
 431
 432 ;;;###autoload
 433 (defun facemenu-set-intangible (start end)
 434   "Make the region intangible: disallow moving into it.
 435 This sets the `intangible' text property; it can be undone with
 436 `facemenu-remove-special'."
 437   (interactive "r")
 438   (add-text-properties start end '(intangible t)))
 439
 440 ;;;###autoload
 441 (defun facemenu-set-read-only (start end)
 442   "Make the region unmodifiable.
 443 This sets the `read-only' text property; it can be undone with
 444 `facemenu-remove-special'."
 445   (interactive "r")
 446   (add-text-properties start end '(read-only t)))
 447
 448 ;;;###autoload
 449 (defun facemenu-remove-face-props (start end)
 450   "Remove `face' and `mouse-face' text properties."
 451   (interactive "*r") ; error if buffer is read-only despite the next line.
 452   (let ((inhibit-read-only t))
 453     (remove-text-properties
 454      start end '(face nil mouse-face nil))))
 455
 456 ;;;###autoload
 457 (defun facemenu-remove-all (start end)
 458   "Remove all text properties from the region."
 459   (interactive "*r") ; error if buffer is read-only despite the next line.
 460   (let ((inhibit-read-only t))
 461     (set-text-properties start end nil)))
 462
 463 ;;;###autoload
 464 (defun facemenu-remove-special (start end)
 465   "Remove all the \"special\" text properties from the region.
 466 These special properties include `invisible', `intangible' and `read-only'."
 467   (interactive "*r") ; error if buffer is read-only despite the next line.
 468   (let ((inhibit-read-only t))
 469     (remove-text-properties
 470      start end '(invisible nil intangible nil read-only nil))))
 471 \f
 472 ;;;###autoload
 473 (defun facemenu-read-color (&optional prompt)
 474   "Read a color using the minibuffer."
 475   (let* ((completion-ignore-case t)
 476          (col (completing-read (or prompt "Color: ")
 477                                (or facemenu-color-alist
 478                                    (defined-colors))
 479                                nil t)))
 480     (if (equal "" col)
 481         nil
 482       col)))
 483
 484 ;;;###autoload
 485 (defun list-colors-display (&optional list buffer-name)
 486   "Display names of defined colors, and show what they look like.
 487 If the optional argument LIST is non-nil, it should be a list of
 488 colors to display.  Otherwise, this command computes a list of
 489 colors that the current display can handle.  If the optional
 490 argument BUFFER-NAME is nil, it defaults to *Colors*."
 491   (interactive)
 492   (when (and (null list) (> (display-color-cells) 0))
 493     (setq list (list-colors-duplicates (defined-colors)))
 494     (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
 495       ;; Don't show more than what the display can handle.
 496       (let ((lc (nthcdr (1- (display-color-cells)) list)))
 497         (if lc
 498             (setcdr lc nil)))))
 499   (with-output-to-temp-buffer (or buffer-name "*Colors*")
 500     (save-excursion
 501       (set-buffer standard-output)
 502       (setq truncate-lines t)
 503       (if temp-buffer-show-function
 504           (list-colors-print list)
 505         ;; Call list-colors-print from temp-buffer-show-hook
 506         ;; to get the right value of window-width in list-colors-print
 507         ;; after the buffer is displayed.
 508         (add-hook 'temp-buffer-show-hook
 509                   (lambda () (list-colors-print list)) nil t)))))
 510
 511 (defun list-colors-print (list)
 512   (dolist (color list)
 513     (if (consp color)
 514         (if (cdr color)
 515             (setq color (sort color (lambda (a b)
 516                                       (string< (downcase a)
 517                                                (downcase b))))))
 518       (setq color (list color)))
 519     (put-text-property
 520      (prog1 (point)
 521        (insert (car color))
 522        (indent-to 22))
 523      (point)
 524      'face (cons 'background-color (car color)))
 525     (put-text-property
 526      (prog1 (point)
 527        (insert " " (if (cdr color)
 528                        (mapconcat 'identity (cdr color) ", ")
 529                      (car color))))
 530      (point)
 531      'face (cons 'foreground-color (car color)))
 532     (indent-to (max (- (window-width) 8) 44))
 533     (insert (apply 'format "#%02x%02x%02x"
 534                    (mapcar (lambda (c) (lsh c -8))
 535                            (color-values (car color)))))
 536
 537     (insert "\n"))
 538   (goto-char (point-min)))
 539
 540 (defun list-colors-duplicates (&optional list)
 541   "Return a list of colors with grouped duplicate colors.
 542 If a color has no duplicates, then the element of the returned list
 543 has the form '(COLOR-NAME).  The element of the returned list with
 544 duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
 545 This function uses the predicate `facemenu-color-equal' to compare
 546 color names.  If the optional argument LIST is non-nil, it should
 547 be a list of colors to display.  Otherwise, this function uses
 548 a list of colors that the current display can handle."
 549   (let* ((list (mapcar 'list (or list (defined-colors))))
 550          (l list))
 551     (while (cdr l)
 552       (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
 553                (not (if (boundp 'w32-default-color-map)
 554                         (not (assoc (car (car l)) w32-default-color-map)))))
 555           (progn
 556             (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
 557             (setcdr l (cdr (cdr l))))
 558         (setq l (cdr l))))
 559     list))
 560
 561 (defun facemenu-color-equal (a b)
 562   "Return t if colors A and B are the same color.
 563 A and B should be strings naming colors.
 564 This function queries the display system to find out what the color
 565 names mean.  It returns nil if the colors differ or if it can't
 566 determine the correct answer."
 567   (cond ((equal a b) t)
 568         ((equal (color-values a) (color-values b)))))
 569
 570 (defun facemenu-add-face (face &optional start end)
 571   "Add FACE to text between START and END.
 572 If START is nil or START to END is empty, add FACE to next typed character
 573 instead.  For each section of that region that has a different face property,
 574 FACE will be consed onto it, and other faces that are completely hidden by
 575 that will be removed from the list.
 576 If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
 577 they are used to set the face information.
 578
 579 As a special case, if FACE is `default', then the region is left with NO face
 580 text property.  Otherwise, selecting the default face would not have any
 581 effect.  See `facemenu-remove-face-function'."
 582   (interactive "*xFace: \nr")
 583   (if (and (eq face 'default)
 584            (not (eq facemenu-remove-face-function t)))
 585       (if facemenu-remove-face-function
 586           (funcall facemenu-remove-face-function start end)
 587         (if (and start (< start end))
 588             (remove-text-properties start end '(face default))
 589           (setq self-insert-face 'default
 590                 self-insert-face-command this-command)))
 591     (if facemenu-add-face-function
 592         (save-excursion
 593           (if end (goto-char end))
 594           (save-excursion
 595             (if start (goto-char start))
 596             (insert-before-markers
 597              (funcall facemenu-add-face-function face end)))
 598           (if facemenu-end-add-face
 599               (insert (if (stringp facemenu-end-add-face)
 600                           facemenu-end-add-face
 601                         (funcall facemenu-end-add-face face)))))
 602       (if (and start (< start end))
 603           (let ((part-start start) part-end)
 604             (while (not (= part-start end))
 605               (setq part-end (next-single-property-change part-start 'face
 606                                                           nil end))
 607               (let ((prev (get-text-property part-start 'face)))
 608                 (put-text-property part-start part-end 'face
 609                                    (if (null prev)
 610                                        face
 611                                      (facemenu-active-faces
 612                                       (cons face
 613                                             (if (listp prev)
 614                                                 prev
 615                                               (list prev)))))))
 616               (setq part-start part-end)))
 617         (setq self-insert-face (if (eq last-command self-insert-face-command)
 618                                    (cons face (if (listp self-insert-face)
 619                                                   self-insert-face
 620                                                 (list self-insert-face)))
 621                                  face)
 622               self-insert-face-command this-command))))
 623   (unless (facemenu-enable-faces-p)
 624     (message "Font-lock mode will override any faces you set in this buffer")))
 625
 626 (defun facemenu-active-faces (face-list &optional frame)
 627   "Return from FACE-LIST those faces that would be used for display.
 628 This means each face attribute is not specified in a face earlier in FACE-LIST
 629 and such a face is therefore active when used to display text.
 630 If the optional argument FRAME is given, use the faces in that frame; otherwise
 631 use the selected frame.  If t, then the global, non-frame faces are used."
 632   (let* ((mask-atts (copy-sequence
 633                      (if (consp (car face-list))
 634                          (face-attributes-as-vector (car face-list))
 635                        (or (internal-lisp-face-p (car face-list) frame)
 636                            (check-face (car face-list))))))
 637          (active-list (list (car face-list)))
 638          (face-list (cdr face-list))
 639          (mask-len (length mask-atts)))
 640     (while face-list
 641       (if (let ((face-atts
 642                  (if (consp (car face-list))
 643                      (face-attributes-as-vector (car face-list))
 644                    (or (internal-lisp-face-p (car face-list) frame)
 645                        (check-face (car face-list)))))
 646                 (i mask-len)
 647                 (useful nil))
 648             (while (>= (setq i (1- i)) 0)
 649               (and (not (memq (aref face-atts i) '(nil unspecified)))
 650                    (memq (aref mask-atts i) '(nil unspecified))
 651                    (aset mask-atts i (setq useful t))))
 652             useful)
 653           (setq active-list (cons (car face-list) active-list)))
 654       (setq face-list (cdr face-list)))
 655     (nreverse active-list)))
 656
 657 (defun facemenu-add-new-face (face)
 658   "Add FACE (a face) to the Face menu.
 659
 660 This is called whenever you create a new face."
 661   (let* (name
 662          symbol
 663          menu docstring
 664          (key (cdr (assoc face facemenu-keybindings)))
 665          function menu-val)
 666     (if (symbolp face)
 667         (setq name (symbol-name face)
 668               symbol face)
 669       (setq name face
 670             symbol (intern name)))
 671     (setq menu 'facemenu-face-menu)
 672     (setq docstring
 673           (format "Select face `%s' for subsequent insertion."
 674                   name))
 675     (cond ((facemenu-iterate ; check if equivalent face is already in the menu
 676             (lambda (m) (and (listp m)
 677                              (symbolp (car m))
 678                              (face-equal (car m) symbol)))
 679             (cdr (symbol-function menu))))
 680           ;; Faces with a keyboard equivalent.  These go at the front.
 681           (key
 682            (setq function (intern (concat "facemenu-set-" name)))
 683            (fset function
 684                  `(lambda ()
 685                     ,docstring
 686                     (interactive)
 687                     (facemenu-set-face
 688                      (quote ,symbol)
 689                      (if (and mark-active (not current-prefix-arg))
 690                          (region-beginning))
 691                      (if (and mark-active (not current-prefix-arg))
 692                          (region-end)))))
 693            (define-key 'facemenu-keymap key (cons name function))
 694            (define-key menu key (cons name function)))
 695           ;; Faces with no keyboard equivalent.  Figure out where to put it:
 696           ((or (eq t facemenu-listed-faces)
 697                (memq symbol facemenu-listed-faces))
 698            (setq key (vector symbol)
 699                  function 'facemenu-set-face-from-menu
 700                  menu-val (symbol-function menu))
 701            (if (and facemenu-new-faces-at-end
 702                     (> (length menu-val) 3))
 703                (define-key-after menu-val key (cons name function)
 704                  (car (nth (- (length menu-val) 3) menu-val)))
 705              (define-key menu key (cons name function))))))
 706   nil) ; Return nil for facemenu-iterate
 707
 708 (defun facemenu-add-new-color (color menu)
 709   "Add COLOR (a color name string) to the appropriate Face menu.
 710 MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
 711 Return the event type (a symbol) of the added menu entry.
 712
 713 This is called whenever you use a new color."
 714   (let (symbol docstring)
 715     (unless (color-defined-p color)
 716       (error "Color `%s' undefined" color))
 717     (cond ((eq menu 'facemenu-foreground-menu)
 718            (setq docstring
 719                  (format "Select foreground color %s for subsequent insertion."
 720                          color)
 721                  symbol (intern (concat "fg:" color))))
 722           ((eq menu 'facemenu-background-menu)
 723            (setq docstring
 724                  (format "Select background color %s for subsequent insertion."
 725                          color)
 726                  symbol (intern (concat "bg:" color))))
 727           (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
 728     (unless (facemenu-iterate ; Check if color is already in the menu.
 729              (lambda (m) (and (listp m)
 730                               (eq (car m) symbol)))
 731              (cdr (symbol-function menu)))
 732       ;; Color is not in the menu.  Figure out where to put it.
 733       (let ((key (vector symbol))
 734             (function 'facemenu-set-face-from-menu)
 735             (menu-val (symbol-function menu)))
 736         (if (and facemenu-new-faces-at-end
 737                  (> (length menu-val) 3))
 738             (define-key-after menu-val key (cons color function)
 739               (car (nth (- (length menu-val) 3) menu-val)))
 740           (define-key menu key (cons color function)))))
 741     symbol))
 742
 743 (defun facemenu-complete-face-list (&optional oldlist)
 744   "Return list of all faces that look different.
 745 Starts with given ALIST of faces, and adds elements only if they display
 746 differently from any face already on the list.
 747 The faces on ALIST will end up at the end of the returned list, in reverse
 748 order."
 749   (let ((list (nreverse (mapcar 'car oldlist))))
 750     (facemenu-iterate
 751      (lambda (new-face)
 752        (if (not (memq new-face list))
 753            (setq list (cons new-face list)))
 754        nil)
 755      (nreverse (face-list)))
 756     list))
 757
 758 (defun facemenu-iterate (func list)
 759   "Apply FUNC to each element of LIST until one returns non-nil.
 760 Returns the non-nil value it found, or nil if all were nil."
 761   (while (and list (not (funcall func (car list))))
 762     (setq list (cdr list)))
 763   (car list))
 764
 765 (facemenu-update)
 766
 767 (provide 'facemenu)
 768
 769 ;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
 770 ;;; facemenu.el ends here