code.delx.au - gnu-emacs/blob - 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, the name of a face.
 138 The \"basic \" faces in `facemenu-keybindings' are automatically
 139 added to the Face menu, and need not be in this list.
 140
 141 This value takes effect when you load facemenu.el.  If the
 142 list includes symbols which are not defined as faces, they
 143 are ignored; however, subsequently defining or creating
 144 those faces adds them to the menu then.  You can call
 145 `facemenu-update' to recalculate the menu contents, such as
 146 if you change the value of this variable,
 147
 148 If this variable is t, all faces that you apply to text
 149 using the face menu commands (even by name), and all faces
 150 that you define or create, are added to the menu.  You may
 151 find it useful to set this variable to t temporarily while
 152 you define some faces, so that they will be added.  However,
 153 if the value is no longer t and you call `facemenu-update',
 154 it will remove any faces not explicitly in the list."
 155   :type '(choice (const :tag "List all faces" t)
 156                  (const :tag "None" nil)
 157                  (repeat symbol))
 158   :group 'facemenu
 159   :version "22.1")
 160
 161 ;;;###autoload
 162 (defvar facemenu-face-menu
 163   (let ((map (make-sparse-keymap "Face")))
 164     (define-key map "o" (cons "Other..." 'facemenu-set-face))
 165     map)
 166   "Menu keymap for faces.")
 167 ;;;###autoload
 168 (defalias 'facemenu-face-menu facemenu-face-menu)
 169 (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
 170
 171 ;;;###autoload
 172 (defvar facemenu-foreground-menu
 173   (let ((map (make-sparse-keymap "Foreground Color")))
 174     (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
 175     map)
 176   "Menu keymap for foreground colors.")
 177 ;;;###autoload
 178 (defalias 'facemenu-foreground-menu facemenu-foreground-menu)
 179 (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
 180
 181 ;;;###autoload
 182 (defvar facemenu-background-menu
 183   (let ((map (make-sparse-keymap "Background Color")))
 184     (define-key map "o" (cons "Other..." 'facemenu-set-background))
 185     map)
 186   "Menu keymap for background colors.")
 187 ;;;###autoload
 188 (defalias 'facemenu-background-menu facemenu-background-menu)
 189 (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
 190
 191 ;;; Condition for enabling menu items that set faces.
 192 (defun facemenu-enable-faces-p ()
 193   (not (and font-lock-mode font-lock-defaults)))
 194
 195 ;;;###autoload
 196 (defvar facemenu-special-menu
 197   (let ((map (make-sparse-keymap "Special")))
 198     (define-key map [?s] (cons (purecopy "Remove Special")
 199                                'facemenu-remove-special))
 200     (define-key map [?t] (cons (purecopy "Intangible")
 201                                'facemenu-set-intangible))
 202     (define-key map [?v] (cons (purecopy "Invisible")
 203                                'facemenu-set-invisible))
 204     (define-key map [?r] (cons (purecopy "Read-Only")
 205                                'facemenu-set-read-only))
 206     map)
 207   "Menu keymap for non-face text-properties.")
 208 ;;;###autoload
 209 (defalias 'facemenu-special-menu facemenu-special-menu)
 210
 211 ;;;###autoload
 212 (defvar facemenu-justification-menu
 213   (let ((map (make-sparse-keymap "Justification")))
 214     (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
 215     (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
 216     (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
 217     (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
 218     (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
 219     map)
 220   "Submenu for text justification commands.")
 221 ;;;###autoload
 222 (defalias 'facemenu-justification-menu facemenu-justification-menu)
 223
 224 ;;;###autoload
 225 (defvar facemenu-indentation-menu
 226   (let ((map (make-sparse-keymap "Indentation")))
 227     (define-key map [decrease-right-margin]
 228       (cons (purecopy "Indent Right Less") 'decrease-right-margin))
 229     (define-key map [increase-right-margin]
 230       (cons (purecopy "Indent Right More") 'increase-right-margin))
 231     (define-key map [decrease-left-margin]
 232       (cons (purecopy "Indent Less") 'decrease-left-margin))
 233     (define-key map [increase-left-margin]
 234       (cons (purecopy "Indent More") 'increase-left-margin))
 235     map)
 236   "Submenu for indentation commands.")
 237 ;;;###autoload
 238 (defalias 'facemenu-indentation-menu facemenu-indentation-menu)
 239
 240 ;; This is split up to avoid an overlong line in loaddefs.el.
 241 ;;;###autoload
 242 (defvar facemenu-menu nil
 243   "Facemenu top-level menu keymap.")
 244 ;;;###autoload
 245 (setq facemenu-menu (make-sparse-keymap "Text Properties"))
 246 ;;;###autoload
 247 (let ((map facemenu-menu))
 248   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
 249   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
 250   (define-key map [dp] (cons (purecopy "Describe Properties")
 251                              'describe-text-properties))
 252   (define-key map [ra] (cons (purecopy "Remove Text Properties")
 253                              'facemenu-remove-all))
 254   (define-key map [rm] (cons (purecopy "Remove Face Properties")
 255                              'facemenu-remove-face-props))
 256   (define-key map [s1] (list (purecopy "--"))))
 257 ;;;###autoload
 258 (let ((map facemenu-menu))
 259   (define-key map [in] (cons (purecopy "Indentation")
 260                              'facemenu-indentation-menu))
 261   (define-key map [ju] (cons (purecopy "Justification")
 262                              'facemenu-justification-menu))
 263   (define-key map [s2] (list (purecopy "--")))
 264   (define-key map [sp] (cons (purecopy "Special Properties")
 265                              'facemenu-special-menu))
 266   (define-key map [bg] (cons (purecopy "Background Color")
 267                              'facemenu-background-menu))
 268   (define-key map [fg] (cons (purecopy "Foreground Color")
 269                              'facemenu-foreground-menu))
 270   (define-key map [fc] (cons (purecopy "Face")
 271                              'facemenu-face-menu)))
 272 ;;;###autoload
 273 (defalias 'facemenu-menu facemenu-menu)
 274
 275 (defvar facemenu-keymap
 276   (let ((map (make-sparse-keymap "Set face")))
 277     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
 278     map)
 279   "Keymap for face-changing commands.
 280 `Facemenu-update' fills in the keymap according to the bindings
 281 requested in `facemenu-keybindings'.")
 282 (defalias 'facemenu-keymap facemenu-keymap)
 283
 284
 285 (defcustom facemenu-add-face-function nil
 286   "Function called at beginning of text to change or nil.
 287 This function is passed the FACE to set and END of text to change, and must
 288 return a string which is inserted.  It may set `facemenu-end-add-face'."
 289   :type '(choice (const :tag "None" nil)
 290                  function)
 291   :group 'facemenu)
 292
 293 (defcustom facemenu-end-add-face nil
 294   "String to insert or function called at end of text to change or nil.
 295 This function is passed the FACE to set, and must return a string which is
 296 inserted."
 297   :type '(choice (const :tag "None" nil)
 298                  string
 299                  function)
 300   :group 'facemenu)
 301
 302 (defcustom facemenu-remove-face-function nil
 303   "When non-nil, this is a function called to remove faces.
 304 This function is passed the START and END of text to change.
 305 May also be t meaning to use `facemenu-add-face-function'."
 306   :type '(choice (const :tag "None" nil)
 307                  (const :tag "Use add-face" t)
 308                  function)
 309   :group 'facemenu)
 310
 311 ;;; Internal Variables
 312
 313 (defvar facemenu-color-alist nil
 314   "Alist of colors, used for completion.
 315 If this is nil, then the value of (defined-colors) is used.")
 316
 317 (defun facemenu-update ()
 318   "Add or update the \"Face\" menu in the menu bar.
 319 You can call this to update things if you change any of the menu configuration
 320 variables."
 321   (interactive)
 322
 323   ;; Add each defined face to the menu.
 324   (facemenu-iterate 'facemenu-add-new-face
 325                     (facemenu-complete-face-list facemenu-keybindings)))
 326
 327 ;;;###autoload
 328 (defun facemenu-set-face (face &optional start end)
 329   "Apply FACE to the region or next character typed.
 330
 331 If the region is active (normally true except in Transient
 332 Mark mode) and nonempty, and there is no prefix argument,
 333 this command applies FACE to the region.  Otherwise, it applies FACE
 334 to the faces to use for the next character
 335 inserted.  (Moving point or switching buffers before typing
 336 a character to insert cancels the specification.)
 337
 338 If FACE is `default', to \"apply\" it means clearing
 339 the list of faces to be used.  For any other value of FACE,
 340 to \"apply\" it means putting FACE at the front of the list
 341 of faces to be used, and removing any faces further
 342 along in the list that would be completely overridden by
 343 preceding faces (including FACE).
 344
 345 This command can also add FACE to the menu of faces,
 346 if `facemenu-listed-faces' says to do that."
 347   (interactive (list (progn
 348                        (barf-if-buffer-read-only)
 349                        (read-face-name "Use face"))
 350                      (if (and mark-active (not current-prefix-arg))
 351                          (region-beginning))
 352                      (if (and mark-active (not current-prefix-arg))
 353                          (region-end))))
 354   (facemenu-add-new-face face)
 355   (facemenu-add-face face start end))
 356
 357 ;;;###autoload
 358 (defun facemenu-set-foreground (color &optional start end)
 359   "Set the foreground COLOR of the region or next character typed.
 360 This command reads the color in the minibuffer.
 361
 362 If the region is active (normally true except in Transient Mark mode)
 363 and there is no prefix argument, this command sets the region to the
 364 requested face.
 365
 366 Otherwise, this command specifies the face for the next character
 367 inserted.  Moving point or switching buffers before
 368 typing a character to insert cancels the specification."
 369   (interactive (list (progn
 370                        (barf-if-buffer-read-only)
 371                        (facemenu-read-color "Foreground color: "))
 372                      (if (and mark-active (not current-prefix-arg))
 373                          (region-beginning))
 374                      (if (and mark-active (not current-prefix-arg))
 375                          (region-end))))
 376   (facemenu-set-face-from-menu
 377    (facemenu-add-new-color color 'facemenu-foreground-menu)
 378    start end))
 379
 380 ;;;###autoload
 381 (defun facemenu-set-background (color &optional start end)
 382   "Set the background COLOR of the region or next character typed.
 383 This command reads the color in the minibuffer.
 384
 385 If the region is active (normally true except in Transient Mark mode)
 386 and there is no prefix argument, this command sets the region to the
 387 requested face.
 388
 389 Otherwise, this command specifies the face for the next character
 390 inserted.  Moving point or switching buffers before
 391 typing a character to insert cancels the specification."
 392   (interactive (list (progn
 393                        (barf-if-buffer-read-only)
 394                        (facemenu-read-color "Background color: "))
 395                      (if (and mark-active (not current-prefix-arg))
 396                          (region-beginning))
 397                      (if (and mark-active (not current-prefix-arg))
 398                          (region-end))))
 399   (facemenu-set-face-from-menu
 400    (facemenu-add-new-color color 'facemenu-background-menu)
 401    start end))
 402
 403 ;;;###autoload
 404 (defun facemenu-set-face-from-menu (face start end)
 405   "Set the FACE of the region or next character typed.
 406 This function is designed to be called from a menu; FACE is determined
 407 using the event type of the menu entry.  If FACE is a symbol whose
 408 name starts with \"fg:\" or \"bg:\", then this functions sets the
 409 foreground or background to the color specified by the rest of the
 410 symbol's name.  Any other symbol is considered the name of a face.
 411
 412 If the region is active (normally true except in Transient Mark mode)
 413 and there is no prefix argument, this command sets the region to the
 414 requested face.
 415
 416 Otherwise, this command specifies the face for the next character
 417 inserted.  Moving point or switching buffers before typing a character
 418 to insert cancels the specification."
 419   (interactive (list last-command-event
 420                      (if (and mark-active (not current-prefix-arg))
 421                          (region-beginning))
 422                      (if (and mark-active (not current-prefix-arg))
 423                          (region-end))))
 424   (barf-if-buffer-read-only)
 425   (facemenu-add-face
 426    (let ((fn (symbol-name face)))
 427      (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn)
 428          (list (list (if (string= (match-string 1 fn) "f")
 429                          :foreground
 430                        :background)
 431                      (match-string 2 fn)))
 432        face))
 433    start end))
 434
 435 ;;;###autoload
 436 (defun facemenu-set-invisible (start end)
 437   "Make the region invisible.
 438 This sets the `invisible' text property; it can be undone with
 439 `facemenu-remove-special'."
 440   (interactive "r")
 441   (add-text-properties start end '(invisible t)))
 442
 443 ;;;###autoload
 444 (defun facemenu-set-intangible (start end)
 445   "Make the region intangible: disallow moving into it.
 446 This sets the `intangible' text property; it can be undone with
 447 `facemenu-remove-special'."
 448   (interactive "r")
 449   (add-text-properties start end '(intangible t)))
 450
 451 ;;;###autoload
 452 (defun facemenu-set-read-only (start end)
 453   "Make the region unmodifiable.
 454 This sets the `read-only' text property; it can be undone with
 455 `facemenu-remove-special'."
 456   (interactive "r")
 457   (add-text-properties start end '(read-only t)))
 458
 459 ;;;###autoload
 460 (defun facemenu-remove-face-props (start end)
 461   "Remove `face' and `mouse-face' text properties."
 462   (interactive "*r") ; error if buffer is read-only despite the next line.
 463   (let ((inhibit-read-only t))
 464     (remove-text-properties
 465      start end '(face nil mouse-face nil))))
 466
 467 ;;;###autoload
 468 (defun facemenu-remove-all (start end)
 469   "Remove all text properties from the region."
 470   (interactive "*r") ; error if buffer is read-only despite the next line.
 471   (let ((inhibit-read-only t))
 472     (set-text-properties start end nil)))
 473
 474 ;;;###autoload
 475 (defun facemenu-remove-special (start end)
 476   "Remove all the \"special\" text properties from the region.
 477 These special properties include `invisible', `intangible' and `read-only'."
 478   (interactive "*r") ; error if buffer is read-only despite the next line.
 479   (let ((inhibit-read-only t))
 480     (remove-text-properties
 481      start end '(invisible nil intangible nil read-only nil))))
 482 \f
 483 ;;;###autoload
 484 (defun facemenu-read-color (&optional prompt)
 485   "Read a color using the minibuffer."
 486   (let* ((completion-ignore-case t)
 487          (col (completing-read (or prompt "Color: ")
 488                                (or facemenu-color-alist
 489                                    (defined-colors))
 490                                nil t)))
 491     (if (equal "" col)
 492         nil
 493       col)))
 494
 495 ;;;###autoload
 496 (defun list-colors-display (&optional list buffer-name)
 497   "Display names of defined colors, and show what they look like.
 498 If the optional argument LIST is non-nil, it should be a list of
 499 colors to display.  Otherwise, this command computes a list of
 500 colors that the current display can handle.  If the optional
 501 argument BUFFER-NAME is nil, it defaults to *Colors*."
 502   (interactive)
 503   (when (and (null list) (> (display-color-cells) 0))
 504     (setq list (list-colors-duplicates (defined-colors)))
 505     (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
 506       ;; Don't show more than what the display can handle.
 507       (let ((lc (nthcdr (1- (display-color-cells)) list)))
 508         (if lc
 509             (setcdr lc nil)))))
 510   (with-output-to-temp-buffer (or buffer-name "*Colors*")
 511     (save-excursion
 512       (set-buffer standard-output)
 513       (setq truncate-lines t)
 514       (if temp-buffer-show-function
 515           (list-colors-print list)
 516         ;; Call list-colors-print from temp-buffer-show-hook
 517         ;; to get the right value of window-width in list-colors-print
 518         ;; after the buffer is displayed.
 519         (add-hook 'temp-buffer-show-hook
 520                   (lambda () (list-colors-print list)) nil t)))))
 521
 522 (defun list-colors-print (list)
 523   (dolist (color list)
 524     (if (consp color)
 525         (if (cdr color)
 526             (setq color (sort color (lambda (a b)
 527                                       (string< (downcase a)
 528                                                (downcase b))))))
 529       (setq color (list color)))
 530     (put-text-property
 531      (prog1 (point)
 532        (insert (car color))
 533        (indent-to 22))
 534      (point)
 535      'face (cons 'background-color (car color)))
 536     (put-text-property
 537      (prog1 (point)
 538        (insert " " (if (cdr color)
 539                        (mapconcat 'identity (cdr color) ", ")
 540                      (car color))))
 541      (point)
 542      'face (cons 'foreground-color (car color)))
 543     (indent-to (max (- (window-width) 8) 44))
 544     (insert (apply 'format "#%02x%02x%02x"
 545                    (mapcar (lambda (c) (lsh c -8))
 546                            (color-values (car color)))))
 547
 548     (insert "\n"))
 549   (goto-char (point-min)))
 550
 551 (defun list-colors-duplicates (&optional list)
 552   "Return a list of colors with grouped duplicate colors.
 553 If a color has no duplicates, then the element of the returned list
 554 has the form '(COLOR-NAME).  The element of the returned list with
 555 duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...).
 556 This function uses the predicate `facemenu-color-equal' to compare
 557 color names.  If the optional argument LIST is non-nil, it should
 558 be a list of colors to display.  Otherwise, this function uses
 559 a list of colors that the current display can handle."
 560   (let* ((list (mapcar 'list (or list (defined-colors))))
 561          (l list))
 562     (while (cdr l)
 563       (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
 564                (not (if (boundp 'w32-default-color-map)
 565                         (not (assoc (car (car l)) w32-default-color-map)))))
 566           (progn
 567             (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
 568             (setcdr l (cdr (cdr l))))
 569         (setq l (cdr l))))
 570     list))
 571
 572 (defun facemenu-color-equal (a b)
 573   "Return t if colors A and B are the same color.
 574 A and B should be strings naming colors.
 575 This function queries the display system to find out what the color
 576 names mean.  It returns nil if the colors differ or if it can't
 577 determine the correct answer."
 578   (cond ((equal a b) t)
 579         ((equal (color-values a) (color-values b)))))
 580
 581 (defun facemenu-add-face (face &optional start end)
 582   "Add FACE to text between START and END.
 583 If START is nil or START to END is empty, add FACE to next typed character
 584 instead.  For each section of that region that has a different face property,
 585 FACE will be consed onto it, and other faces that are completely hidden by
 586 that will be removed from the list.
 587 If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
 588 they are used to set the face information.
 589
 590 As a special case, if FACE is `default', then the region is left with NO face
 591 text property.  Otherwise, selecting the default face would not have any
 592 effect.  See `facemenu-remove-face-function'."
 593   (interactive "*xFace: \nr")
 594   (if (and (eq face 'default)
 595            (not (eq facemenu-remove-face-function t)))
 596       (if facemenu-remove-face-function
 597           (funcall facemenu-remove-face-function start end)
 598         (if (and start (< start end))
 599             (remove-text-properties start end '(face default))
 600           (setq self-insert-face 'default
 601                 self-insert-face-command this-command)))
 602     (if facemenu-add-face-function
 603         (save-excursion
 604           (if end (goto-char end))
 605           (save-excursion
 606             (if start (goto-char start))
 607             (insert-before-markers
 608              (funcall facemenu-add-face-function face end)))
 609           (if facemenu-end-add-face
 610               (insert (if (stringp facemenu-end-add-face)
 611                           facemenu-end-add-face
 612                         (funcall facemenu-end-add-face face)))))
 613       (if (and start (< start end))
 614           (let ((part-start start) part-end)
 615             (while (not (= part-start end))
 616               (setq part-end (next-single-property-change part-start 'face
 617                                                           nil end))
 618               (let ((prev (get-text-property part-start 'face)))
 619                 (put-text-property part-start part-end 'face
 620                                    (if (null prev)
 621                                        face
 622                                      (facemenu-active-faces
 623                                       (cons face
 624                                             (if (listp prev)
 625                                                 prev
 626                                               (list prev)))
 627                                       ;; Specify the selected frame
 628                                       ;; because nil would mean to use
 629                                       ;; the new-frame default settings,
 630                                       ;; and those are usually nil.
 631                                       (selected-frame)))))
 632               (setq part-start part-end)))
 633         (setq self-insert-face (if (eq last-command self-insert-face-command)
 634                                    (cons face (if (listp self-insert-face)
 635                                                   self-insert-face
 636                                                 (list self-insert-face)))
 637                                  face)
 638               self-insert-face-command this-command))))
 639   (unless (facemenu-enable-faces-p)
 640     (message "Font-lock mode will override any faces you set in this buffer")))
 641
 642 (defun facemenu-active-faces (face-list &optional frame)
 643   "Return from FACE-LIST those faces that would be used for display.
 644 This means each face attribute is not specified in a face earlier in FACE-LIST
 645 and such a face is therefore active when used to display text.
 646 If the optional argument FRAME is given, use the faces in that frame; otherwise
 647 use the selected frame.  If t, then the global, non-frame faces are used."
 648   (let* ((mask-atts (copy-sequence
 649                      (if (consp (car face-list))
 650                          (face-attributes-as-vector (car face-list))
 651                        (or (internal-lisp-face-p (car face-list) frame)
 652                            (check-face (car face-list))))))
 653          (active-list (list (car face-list)))
 654          (face-list (cdr face-list))
 655          (mask-len (length mask-atts)))
 656     (while face-list
 657       (if (let ((face-atts
 658                  (if (consp (car face-list))
 659                      (face-attributes-as-vector (car face-list))
 660                    (or (internal-lisp-face-p (car face-list) frame)
 661                        (check-face (car face-list)))))
 662                 (i mask-len)
 663                 (useful nil))
 664             (while (>= (setq i (1- i)) 0)
 665               (and (not (memq (aref face-atts i) '(nil unspecified)))
 666                    (memq (aref mask-atts i) '(nil unspecified))
 667                    (aset mask-atts i (setq useful t))))
 668             useful)
 669           (setq active-list (cons (car face-list) active-list)))
 670       (setq face-list (cdr face-list)))
 671     (nreverse active-list)))
 672
 673 (defun facemenu-add-new-face (face)
 674   "Add FACE (a face) to the Face menu if `facemenu-listed-faces' says so.
 675 This is called whenever you create a new face, and at other times."
 676   (let* (name
 677          symbol
 678          menu docstring
 679          (key (cdr (assoc face facemenu-keybindings)))
 680          function menu-val)
 681     (if (symbolp face)
 682         (setq name (symbol-name face)
 683               symbol face)
 684       (setq name face
 685             symbol (intern name)))
 686     (setq menu 'facemenu-face-menu)
 687     (setq docstring
 688           (format "Select face `%s' for subsequent insertion."
 689                   name))
 690     (cond ((facemenu-iterate ; check if equivalent face is already in the menu
 691             (lambda (m) (and (listp m)
 692                              (symbolp (car m))
 693                              ;; Avoid error in face-equal
 694                              ;; when a non-face is erroneously present.
 695                              (facep (car m))
 696                              (face-equal (car m) symbol)))
 697             (cdr (symbol-function menu))))
 698           ;; Faces with a keyboard equivalent.  These go at the front.
 699           (key
 700            (setq function (intern (concat "facemenu-set-" name)))
 701            (fset function
 702                  `(lambda ()
 703                     ,docstring
 704                     (interactive)
 705                     (facemenu-set-face
 706                      (quote ,symbol)
 707                      (if (and mark-active (not current-prefix-arg))
 708                          (region-beginning))
 709                      (if (and mark-active (not current-prefix-arg))
 710                          (region-end)))))
 711            (define-key 'facemenu-keymap key (cons name function))
 712            (define-key menu key (cons name function)))
 713           ;; Faces with no keyboard equivalent.  Figure out where to put it:
 714           ((or (eq t facemenu-listed-faces)
 715                (memq symbol facemenu-listed-faces))
 716            (setq key (vector symbol)
 717                  function 'facemenu-set-face-from-menu
 718                  menu-val (symbol-function menu))
 719            (if (and facemenu-new-faces-at-end
 720                     (> (length menu-val) 3))
 721                (define-key-after menu-val key (cons name function)
 722                  (car (nth (- (length menu-val) 3) menu-val)))
 723              (define-key menu key (cons name function))))))
 724   nil) ; Return nil for facemenu-iterate
 725
 726 (defun facemenu-add-new-color (color menu)
 727   "Add COLOR (a color name string) to the appropriate Face menu.
 728 MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
 729 Return the event type (a symbol) of the added menu entry.
 730
 731 This is called whenever you use a new color."
 732   (let (symbol docstring)
 733     (unless (color-defined-p color)
 734       (error "Color `%s' undefined" color))
 735     (cond ((eq menu 'facemenu-foreground-menu)
 736            (setq docstring
 737                  (format "Select foreground color %s for subsequent insertion."
 738                          color)
 739                  symbol (intern (concat "fg:" color))))
 740           ((eq menu 'facemenu-background-menu)
 741            (setq docstring
 742                  (format "Select background color %s for subsequent insertion."
 743                          color)
 744                  symbol (intern (concat "bg:" color))))
 745           (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
 746     (unless (facemenu-iterate ; Check if color is already in the menu.
 747              (lambda (m) (and (listp m)
 748                               (eq (car m) symbol)))
 749              (cdr (symbol-function menu)))
 750       ;; Color is not in the menu.  Figure out where to put it.
 751       (let ((key (vector symbol))
 752             (function 'facemenu-set-face-from-menu)
 753             (menu-val (symbol-function menu)))
 754         (if (and facemenu-new-faces-at-end
 755                  (> (length menu-val) 3))
 756             (define-key-after menu-val key (cons color function)
 757               (car (nth (- (length menu-val) 3) menu-val)))
 758           (define-key menu key (cons color function)))))
 759     symbol))
 760
 761 (defun facemenu-complete-face-list (&optional oldlist)
 762   "Return list of all faces that look different.
 763 Starts with given ALIST of faces, and adds elements only if they display
 764 differently from any face already on the list.
 765 The faces on ALIST will end up at the end of the returned list, in reverse
 766 order."
 767   (let ((list (nreverse (mapcar 'car oldlist))))
 768     (facemenu-iterate
 769      (lambda (new-face)
 770        (if (not (memq new-face list))
 771            (setq list (cons new-face list)))
 772        nil)
 773      (nreverse (face-list)))
 774     list))
 775
 776 (defun facemenu-iterate (func list)
 777   "Apply FUNC to each element of LIST until one returns non-nil.
 778 Returns the non-nil value it found, or nil if all were nil."
 779   (while (and list (not (funcall func (car list))))
 780     (setq list (cdr list)))
 781   (car list))
 782
 783 (facemenu-update)
 784
 785 (provide 'facemenu)
 786
 787 ;;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
 788 ;;; facemenu.el ends here