Commit | Line | Data |
---|---|---|
be010748 | 1 | ;;; facemenu.el --- create a face menu for interactively adding fonts to text |
b578f267 | 2 | |
ab422c4d | 3 | ;; Copyright (C) 1994-1996, 2001-2013 Free Software Foundation, Inc. |
4e8aa578 | 4 | |
5762abec | 5 | ;; Author: Boris Goldowsky <boris@gnu.org> |
4e8aa578 | 6 | ;; Keywords: faces |
bd78fa1d | 7 | ;; Package: emacs |
4e8aa578 RS |
8 | |
9 | ;; This file is part of GNU Emacs. | |
10 | ||
eb3fa2cf | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
4e8aa578 | 12 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
4e8aa578 RS |
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 | |
eb3fa2cf | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
4e8aa578 RS |
23 | |
24 | ;;; Commentary: | |
b578f267 | 25 | |
bf7d4561 BG |
26 | ;; This file defines a menu of faces (bold, italic, etc) which allows you to |
27 | ;; set the face used for a region of the buffer. Some faces also have | |
af1eab21 | 28 | ;; keybindings, which are shown in the menu. |
88d690a9 RS |
29 | ;; |
30 | ;; The menu also contains submenus for indentation and justification-changing | |
31 | ;; commands. | |
4e8aa578 | 32 | |
4e8aa578 | 33 | ;;; Usage: |
bf7d4561 BG |
34 | ;; Selecting a face from the menu or typing the keyboard equivalent will |
35 | ;; change the region to use that face. If you use transient-mark-mode and the | |
36 | ;; region is not active, the face will be remembered and used for the next | |
37 | ;; insertion. It will be forgotten if you move point or make other | |
38 | ;; modifications before inserting or typing anything. | |
4e8aa578 | 39 | ;; |
71296446 | 40 | ;; Faces can be selected from the keyboard as well. |
6be7d8db RS |
41 | ;; The standard keybindings are M-o (or ESC o) + letter: |
42 | ;; M-o i = "set italic", M-o b = "set bold", etc. | |
4e8aa578 RS |
43 | |
44 | ;;; Customization: | |
45 | ;; An alternative set of keybindings that may be easier to type can be set up | |
88d690a9 RS |
46 | ;; using "Alt" or "Hyper" keys. This requires that you either have or create |
47 | ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key | |
48 | ;; labeled "Alt", but to make it act as an Alt key I have to put this command | |
49 | ;; into my .xinitrc: | |
50 | ;; xmodmap -e "add Mod3 = Alt_L" | |
51 | ;; Or, I can make it into a Hyper key with this: | |
4e8aa578 | 52 | ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" |
88d690a9 RS |
53 | ;; Check with local X-perts for how to do it on your system. |
54 | ;; Then you can define your keybindings with code like this in your .emacs: | |
4e8aa578 RS |
55 | ;; (setq facemenu-keybindings |
56 | ;; '((default . [?\H-d]) | |
57 | ;; (bold . [?\H-b]) | |
58 | ;; (italic . [?\H-i]) | |
88d690a9 | 59 | ;; (bold-italic . [?\H-l]) |
4e8aa578 | 60 | ;; (underline . [?\H-u]))) |
9086c730 | 61 | ;; (facemenu-update) |
4e8aa578 | 62 | ;; (setq facemenu-keymap global-map) |
88d690a9 RS |
63 | ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color |
64 | ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color | |
4e8aa578 | 65 | ;; |
88d690a9 RS |
66 | ;; The order of the faces that appear in the menu and their keybindings can be |
67 | ;; controlled by setting the variables `facemenu-keybindings' and | |
b6a67507 CY |
68 | ;; `facemenu-new-faces-at-end'. List faces that you want to use in documents |
69 | ;; in `facemenu-listed-faces'. | |
4e8aa578 RS |
70 | |
71 | ;;; Known Problems: | |
88d690a9 RS |
72 | ;; Bold and Italic do not combine to create bold-italic if you select them |
73 | ;; both, although most other combinations (eg bold + underline + some color) | |
74 | ;; do the intuitive thing. | |
75 | ;; | |
4e8aa578 RS |
76 | ;; There is at present no way to display what the faces look like in |
77 | ;; the menu itself. | |
78 | ;; | |
79 | ;; `list-faces-display' shows the faces in a different order than | |
80 | ;; this menu, which could be confusing. I do /not/ sort the list | |
81 | ;; alphabetically, because I like the default order: it puts the most | |
82 | ;; basic, common fonts first. | |
83 | ;; | |
84 | ;; Please send me any other problems, comments or ideas. | |
85 | ||
86 | ;;; Code: | |
87 | ||
71296446 | 88 | (eval-when-compile |
0e520006 PA |
89 | (require 'help) |
90 | (require 'button)) | |
91 | ||
9086c730 RS |
92 | ;; Global bindings: |
93 | (define-key global-map [C-down-mouse-2] 'facemenu-menu) | |
6be7d8db | 94 | (define-key global-map "\M-o" 'facemenu-keymap) |
4e8aa578 | 95 | |
487e6fcb | 96 | (defgroup facemenu nil |
8e51619c | 97 | "Create a face menu for interactively adding fonts to text." |
487e6fcb RS |
98 | :group 'faces |
99 | :prefix "facemenu-") | |
100 | ||
101 | (defcustom facemenu-keybindings | |
6bdad9ae | 102 | (mapcar 'purecopy |
4e8aa578 RS |
103 | '((default . "d") |
104 | (bold . "b") | |
105 | (italic . "i") | |
88d690a9 | 106 | (bold-italic . "l") ; {bold} intersect {italic} = {l} |
6bdad9ae | 107 | (underline . "u"))) |
220c969f | 108 | "Alist of interesting faces and keybindings. |
4e8aa578 RS |
109 | Each element is itself a list: the car is the name of the face, |
110 | the next element is the key to use as a keyboard equivalent of the menu item; | |
9086c730 | 111 | the binding is made in `facemenu-keymap'. |
4e8aa578 RS |
112 | |
113 | The faces specifically mentioned in this list are put at the top of | |
b6a67507 CY |
114 | the menu, in the order specified. All other faces which are defined |
115 | in `facemenu-listed-faces' are listed after them, but get no | |
116 | keyboard equivalents. | |
4e8aa578 RS |
117 | |
118 | If you change this variable after loading facemenu.el, you will need to call | |
487e6fcb RS |
119 | `facemenu-update' to make it take effect." |
120 | :type '(repeat (cons face string)) | |
121 | :group 'facemenu) | |
4e8aa578 | 122 | |
487e6fcb | 123 | (defcustom facemenu-new-faces-at-end t |
9201cc28 | 124 | "Where in the menu to insert newly-created faces. |
88d690a9 | 125 | This should be nil to put them at the top of the menu, or t to put them |
487e6fcb RS |
126 | just before \"Other\" at the end." |
127 | :type 'boolean | |
128 | :group 'facemenu) | |
88d690a9 | 129 | |
b6a67507 | 130 | (defcustom facemenu-listed-faces nil |
9201cc28 | 131 | "List of faces to include in the Face menu. |
d7beaf53 | 132 | Each element should be a symbol, the name of a face. |
b6a67507 | 133 | The \"basic \" faces in `facemenu-keybindings' are automatically |
d7beaf53 RS |
134 | added to the Face menu, and need not be in this list. |
135 | ||
136 | This value takes effect when you load facemenu.el. If the | |
137 | list includes symbols which are not defined as faces, they | |
138 | are ignored; however, subsequently defining or creating | |
139 | those faces adds them to the menu then. You can call | |
140 | `facemenu-update' to recalculate the menu contents, such as | |
141 | if you change the value of this variable, | |
142 | ||
143 | If this variable is t, all faces that you apply to text | |
144 | using the face menu commands (even by name), and all faces | |
145 | that you define or create, are added to the menu. You may | |
146 | find it useful to set this variable to t temporarily while | |
147 | you define some faces, so that they will be added. However, | |
148 | if the value is no longer t and you call `facemenu-update', | |
149 | it will remove any faces not explicitly in the list." | |
b6a67507 CY |
150 | :type '(choice (const :tag "List all faces" t) |
151 | (const :tag "None" nil) | |
152 | (repeat symbol)) | |
153 | :group 'facemenu | |
154 | :version "22.1") | |
88d690a9 RS |
155 | |
156 | (defvar facemenu-face-menu | |
bf7d4561 | 157 | (let ((map (make-sparse-keymap "Face"))) |
1e8780b1 | 158 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
bf7d4561 BG |
159 | map) |
160 | "Menu keymap for faces.") | |
88d690a9 | 161 | (defalias 'facemenu-face-menu facemenu-face-menu) |
6c763f36 | 162 | (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p)) |
bf7d4561 | 163 | |
71296446 | 164 | (defvar facemenu-foreground-menu |
bf7d4561 | 165 | (let ((map (make-sparse-keymap "Foreground Color"))) |
1e8780b1 | 166 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground)) |
bf7d4561 BG |
167 | map) |
168 | "Menu keymap for foreground colors.") | |
88d690a9 | 169 | (defalias 'facemenu-foreground-menu facemenu-foreground-menu) |
6c763f36 | 170 | (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p)) |
bf7d4561 BG |
171 | |
172 | (defvar facemenu-background-menu | |
173 | (let ((map (make-sparse-keymap "Background Color"))) | |
1e8780b1 | 174 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background)) |
bf7d4561 | 175 | map) |
7e6cb513 | 176 | "Menu keymap for background colors.") |
88d690a9 | 177 | (defalias 'facemenu-background-menu facemenu-background-menu) |
6c763f36 RS |
178 | (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p)) |
179 | ||
180 | ;;; Condition for enabling menu items that set faces. | |
181 | (defun facemenu-enable-faces-p () | |
673c1168 CY |
182 | ;; Enable the facemenu if facemenu-add-face-function is defined |
183 | ;; (e.g. in Tex-mode and SGML mode), or if font-lock is off. | |
184 | (or (not (and font-lock-mode font-lock-defaults)) | |
185 | facemenu-add-face-function)) | |
bf7d4561 | 186 | |
71296446 | 187 | (defvar facemenu-special-menu |
bf7d4561 | 188 | (let ((map (make-sparse-keymap "Special"))) |
2d07ff84 DL |
189 | (define-key map [?s] (cons (purecopy "Remove Special") |
190 | 'facemenu-remove-special)) | |
191 | (define-key map [?t] (cons (purecopy "Intangible") | |
192 | 'facemenu-set-intangible)) | |
193 | (define-key map [?v] (cons (purecopy "Invisible") | |
194 | 'facemenu-set-invisible)) | |
195 | (define-key map [?r] (cons (purecopy "Read-Only") | |
196 | 'facemenu-set-read-only)) | |
bf7d4561 BG |
197 | map) |
198 | "Menu keymap for non-face text-properties.") | |
88d690a9 RS |
199 | (defalias 'facemenu-special-menu facemenu-special-menu) |
200 | ||
201 | (defvar facemenu-justification-menu | |
202 | (let ((map (make-sparse-keymap "Justification"))) | |
2d07ff84 DL |
203 | (define-key map [?c] (cons (purecopy "Center") 'set-justification-center)) |
204 | (define-key map [?b] (cons (purecopy "Full") 'set-justification-full)) | |
205 | (define-key map [?r] (cons (purecopy "Right") 'set-justification-right)) | |
206 | (define-key map [?l] (cons (purecopy "Left") 'set-justification-left)) | |
207 | (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none)) | |
88d690a9 RS |
208 | map) |
209 | "Submenu for text justification commands.") | |
210 | (defalias 'facemenu-justification-menu facemenu-justification-menu) | |
211 | ||
212 | (defvar facemenu-indentation-menu | |
213 | (let ((map (make-sparse-keymap "Indentation"))) | |
71296446 | 214 | (define-key map [decrease-right-margin] |
2d07ff84 | 215 | (cons (purecopy "Indent Right Less") 'decrease-right-margin)) |
f34eaa2c | 216 | (define-key map [increase-right-margin] |
2d07ff84 | 217 | (cons (purecopy "Indent Right More") 'increase-right-margin)) |
f34eaa2c | 218 | (define-key map [decrease-left-margin] |
2d07ff84 | 219 | (cons (purecopy "Indent Less") 'decrease-left-margin)) |
f34eaa2c | 220 | (define-key map [increase-left-margin] |
2d07ff84 | 221 | (cons (purecopy "Indent More") 'increase-left-margin)) |
88d690a9 RS |
222 | map) |
223 | "Submenu for indentation commands.") | |
224 | (defalias 'facemenu-indentation-menu facemenu-indentation-menu) | |
bf7d4561 | 225 | |
f34eaa2c | 226 | ;; This is split up to avoid an overlong line in loaddefs.el. |
f34eaa2c | 227 | (defvar facemenu-menu nil |
535d2617 | 228 | "Facemenu top-level menu keymap.") |
f34eaa2c | 229 | (setq facemenu-menu (make-sparse-keymap "Text Properties")) |
f34eaa2c | 230 | (let ((map facemenu-menu)) |
2d07ff84 DL |
231 | (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display)) |
232 | (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) | |
cea5ec30 RS |
233 | (define-key map [dp] (cons (purecopy "Describe Properties") |
234 | 'describe-text-properties)) | |
b322f63a LMI |
235 | (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties") |
236 | 'facemenu-remove-all | |
237 | :enable 'mark-active)) | |
238 | (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties") | |
239 | 'facemenu-remove-face-props | |
240 | :enable 'mark-active)) | |
2d07ff84 | 241 | (define-key map [s1] (list (purecopy "--")))) |
f34eaa2c | 242 | (let ((map facemenu-menu)) |
71296446 | 243 | (define-key map [in] (cons (purecopy "Indentation") |
2d07ff84 DL |
244 | 'facemenu-indentation-menu)) |
245 | (define-key map [ju] (cons (purecopy "Justification") | |
246 | 'facemenu-justification-menu)) | |
247 | (define-key map [s2] (list (purecopy "--"))) | |
71296446 | 248 | (define-key map [sp] (cons (purecopy "Special Properties") |
2d07ff84 | 249 | 'facemenu-special-menu)) |
71296446 | 250 | (define-key map [bg] (cons (purecopy "Background Color") |
2d07ff84 | 251 | 'facemenu-background-menu)) |
71296446 | 252 | (define-key map [fg] (cons (purecopy "Foreground Color") |
2d07ff84 | 253 | 'facemenu-foreground-menu)) |
71296446 | 254 | (define-key map [fc] (cons (purecopy "Face") |
2d07ff84 | 255 | 'facemenu-face-menu))) |
88d690a9 | 256 | (defalias 'facemenu-menu facemenu-menu) |
bf7d4561 | 257 | |
71296446 | 258 | (defvar facemenu-keymap |
88d690a9 | 259 | (let ((map (make-sparse-keymap "Set face"))) |
2d07ff84 | 260 | (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
ef49d20f | 261 | (define-key map "\M-o" 'font-lock-fontify-block) |
88d690a9 | 262 | map) |
9dc90430 | 263 | "Keymap for face-changing commands. |
bf7d4561 | 264 | `Facemenu-update' fills in the keymap according to the bindings |
535d2617 | 265 | requested in `facemenu-keybindings'.") |
88d690a9 | 266 | (defalias 'facemenu-keymap facemenu-keymap) |
bf7d4561 | 267 | |
cb5bec6e | 268 | |
487e6fcb | 269 | (defcustom facemenu-add-face-function nil |
7e6cb513 | 270 | "Function called at beginning of text to change or nil. |
cb5bec6e | 271 | This function is passed the FACE to set and END of text to change, and must |
487e6fcb RS |
272 | return a string which is inserted. It may set `facemenu-end-add-face'." |
273 | :type '(choice (const :tag "None" nil) | |
274 | function) | |
275 | :group 'facemenu) | |
cb5bec6e | 276 | |
487e6fcb | 277 | (defcustom facemenu-end-add-face nil |
7e6cb513 | 278 | "String to insert or function called at end of text to change or nil. |
cb5bec6e | 279 | This function is passed the FACE to set, and must return a string which is |
487e6fcb RS |
280 | inserted." |
281 | :type '(choice (const :tag "None" nil) | |
282 | string | |
283 | function) | |
284 | :group 'facemenu) | |
cb5bec6e | 285 | |
487e6fcb | 286 | (defcustom facemenu-remove-face-function nil |
9086c730 | 287 | "When non-nil, this is a function called to remove faces. |
cb5bec6e | 288 | This function is passed the START and END of text to change. |
7e6cb513 | 289 | May also be t meaning to use `facemenu-add-face-function'." |
487e6fcb RS |
290 | :type '(choice (const :tag "None" nil) |
291 | (const :tag "Use add-face" t) | |
292 | function) | |
293 | :group 'facemenu) | |
cb5bec6e | 294 | |
bf7d4561 BG |
295 | ;;; Internal Variables |
296 | ||
297 | (defvar facemenu-color-alist nil | |
bf7d4561 | 298 | "Alist of colors, used for completion. |
a926c9ce | 299 | If this is nil, then the value of (defined-colors) is used.") |
4a24b314 | 300 | |
4e8aa578 | 301 | (defun facemenu-update () |
bf7d4561 BG |
302 | "Add or update the \"Face\" menu in the menu bar. |
303 | You can call this to update things if you change any of the menu configuration | |
304 | variables." | |
4e8aa578 | 305 | (interactive) |
4e8aa578 | 306 | |
bf7d4561 BG |
307 | ;; Add each defined face to the menu. |
308 | (facemenu-iterate 'facemenu-add-new-face | |
309 | (facemenu-complete-face-list facemenu-keybindings))) | |
4a24b314 | 310 | |
4e8aa578 | 311 | (defun facemenu-set-face (face &optional start end) |
cd7890bd RS |
312 | "Apply FACE to the region or next character typed. |
313 | ||
314 | If the region is active (normally true except in Transient | |
315 | Mark mode) and nonempty, and there is no prefix argument, | |
316 | this command applies FACE to the region. Otherwise, it applies FACE | |
317 | to the faces to use for the next character | |
318 | inserted. (Moving point or switching buffers before typing | |
319 | a character to insert cancels the specification.) | |
320 | ||
321 | If FACE is `default', to \"apply\" it means clearing | |
322 | the list of faces to be used. For any other value of FACE, | |
323 | to \"apply\" it means putting FACE at the front of the list | |
324 | of faces to be used, and removing any faces further | |
325 | along in the list that would be completely overridden by | |
326 | preceding faces (including FACE). | |
327 | ||
328 | This command can also add FACE to the menu of faces, | |
329 | if `facemenu-listed-faces' says to do that." | |
7d8177cf RS |
330 | (interactive (list (progn |
331 | (barf-if-buffer-read-only) | |
332 | (read-face-name "Use face")) | |
333 | (if (and mark-active (not current-prefix-arg)) | |
334 | (region-beginning)) | |
335 | (if (and mark-active (not current-prefix-arg)) | |
336 | (region-end)))) | |
88d690a9 | 337 | (facemenu-add-new-face face) |
7d8177cf | 338 | (facemenu-add-face face start end)) |
4a24b314 RS |
339 | |
340 | (defun facemenu-set-foreground (color &optional start end) | |
7e6cb513 | 341 | "Set the foreground COLOR of the region or next character typed. |
af1eab21 | 342 | This command reads the color in the minibuffer. |
7d8177cf RS |
343 | |
344 | If the region is active (normally true except in Transient Mark mode) | |
345 | and there is no prefix argument, this command sets the region to the | |
346 | requested face. | |
347 | ||
348 | Otherwise, this command specifies the face for the next character | |
349 | inserted. Moving point or switching buffers before | |
71296446 | 350 | typing a character to insert cancels the specification." |
7d8177cf RS |
351 | (interactive (list (progn |
352 | (barf-if-buffer-read-only) | |
9317e499 | 353 | (read-color "Foreground color: ")) |
7d8177cf RS |
354 | (if (and mark-active (not current-prefix-arg)) |
355 | (region-beginning)) | |
356 | (if (and mark-active (not current-prefix-arg)) | |
357 | (region-end)))) | |
b97c98ad LK |
358 | (facemenu-set-face-from-menu |
359 | (facemenu-add-new-color color 'facemenu-foreground-menu) | |
360 | start end)) | |
4a24b314 RS |
361 | |
362 | (defun facemenu-set-background (color &optional start end) | |
7e6cb513 | 363 | "Set the background COLOR of the region or next character typed. |
af1eab21 | 364 | This command reads the color in the minibuffer. |
7d8177cf RS |
365 | |
366 | If the region is active (normally true except in Transient Mark mode) | |
367 | and there is no prefix argument, this command sets the region to the | |
368 | requested face. | |
369 | ||
370 | Otherwise, this command specifies the face for the next character | |
371 | inserted. Moving point or switching buffers before | |
71296446 | 372 | typing a character to insert cancels the specification." |
7d8177cf RS |
373 | (interactive (list (progn |
374 | (barf-if-buffer-read-only) | |
9317e499 | 375 | (read-color "Background color: ")) |
7d8177cf RS |
376 | (if (and mark-active (not current-prefix-arg)) |
377 | (region-beginning)) | |
378 | (if (and mark-active (not current-prefix-arg)) | |
379 | (region-end)))) | |
b97c98ad LK |
380 | (facemenu-set-face-from-menu |
381 | (facemenu-add-new-color color 'facemenu-background-menu) | |
382 | start end)) | |
4e8aa578 RS |
383 | |
384 | (defun facemenu-set-face-from-menu (face start end) | |
7e6cb513 | 385 | "Set the FACE of the region or next character typed. |
b97c98ad LK |
386 | This function is designed to be called from a menu; FACE is determined |
387 | using the event type of the menu entry. If FACE is a symbol whose | |
388 | name starts with \"fg:\" or \"bg:\", then this functions sets the | |
389 | foreground or background to the color specified by the rest of the | |
390 | symbol's name. Any other symbol is considered the name of a face. | |
f34eaa2c | 391 | |
7d8177cf RS |
392 | If the region is active (normally true except in Transient Mark mode) |
393 | and there is no prefix argument, this command sets the region to the | |
394 | requested face. | |
f34eaa2c KH |
395 | |
396 | Otherwise, this command specifies the face for the next character | |
b97c98ad LK |
397 | inserted. Moving point or switching buffers before typing a character |
398 | to insert cancels the specification." | |
4a24b314 | 399 | (interactive (list last-command-event |
f34eaa2c KH |
400 | (if (and mark-active (not current-prefix-arg)) |
401 | (region-beginning)) | |
402 | (if (and mark-active (not current-prefix-arg)) | |
403 | (region-end)))) | |
88d690a9 | 404 | (barf-if-buffer-read-only) |
b97c98ad LK |
405 | (facemenu-add-face |
406 | (let ((fn (symbol-name face))) | |
407 | (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn) | |
408 | (list (list (if (string= (match-string 1 fn) "f") | |
409 | :foreground | |
410 | :background) | |
411 | (match-string 2 fn))) | |
412 | face)) | |
413 | start end)) | |
4e8aa578 RS |
414 | |
415 | (defun facemenu-set-invisible (start end) | |
416 | "Make the region invisible. | |
417 | This sets the `invisible' text property; it can be undone with | |
f34eaa2c | 418 | `facemenu-remove-special'." |
4e8aa578 | 419 | (interactive "r") |
0e3edd7b | 420 | (add-text-properties start end '(invisible t))) |
4e8aa578 RS |
421 | |
422 | (defun facemenu-set-intangible (start end) | |
423 | "Make the region intangible: disallow moving into it. | |
424 | This sets the `intangible' text property; it can be undone with | |
f34eaa2c | 425 | `facemenu-remove-special'." |
4e8aa578 | 426 | (interactive "r") |
0e3edd7b | 427 | (add-text-properties start end '(intangible t))) |
4e8aa578 RS |
428 | |
429 | (defun facemenu-set-read-only (start end) | |
430 | "Make the region unmodifiable. | |
431 | This sets the `read-only' text property; it can be undone with | |
f34eaa2c | 432 | `facemenu-remove-special'." |
4e8aa578 | 433 | (interactive "r") |
0e3edd7b | 434 | (add-text-properties start end '(read-only t))) |
4e8aa578 | 435 | |
a32d7856 KH |
436 | (defun facemenu-remove-face-props (start end) |
437 | "Remove `face' and `mouse-face' text properties." | |
4e8aa578 RS |
438 | (interactive "*r") ; error if buffer is read-only despite the next line. |
439 | (let ((inhibit-read-only t)) | |
71296446 | 440 | (remove-text-properties |
a32d7856 | 441 | start end '(face nil mouse-face nil)))) |
4e8aa578 | 442 | |
f34eaa2c KH |
443 | (defun facemenu-remove-all (start end) |
444 | "Remove all text properties from the region." | |
445 | (interactive "*r") ; error if buffer is read-only despite the next line. | |
446 | (let ((inhibit-read-only t)) | |
447 | (set-text-properties start end nil))) | |
448 | ||
f34eaa2c KH |
449 | (defun facemenu-remove-special (start end) |
450 | "Remove all the \"special\" text properties from the region. | |
451 | These special properties include `invisible', `intangible' and `read-only'." | |
452 | (interactive "*r") ; error if buffer is read-only despite the next line. | |
453 | (let ((inhibit-read-only t)) | |
71296446 | 454 | (remove-text-properties |
f34eaa2c | 455 | start end '(invisible nil intangible nil read-only nil)))) |
0af1db42 | 456 | \f |
9317e499 | 457 | (defalias 'facemenu-read-color 'read-color) |
4e8aa578 | 458 | |
f0bf7c8e JL |
459 | (defcustom list-colors-sort nil |
460 | "Color sort order for `list-colors-display'. | |
461 | `nil' means default implementation-dependent order (defined in `x-colors'). | |
462 | `name' sorts by color name. | |
463 | `rgb' sorts by red, green, blue components. | |
8fd02581 | 464 | `(rgb-dist . COLOR)' sorts by the RGB distance to the specified color. |
f0bf7c8e | 465 | `hsv' sorts by hue, saturation, value. |
8fd02581 | 466 | `(hsv-dist . COLOR)' sorts by the HSV distance to the specified color |
d80d54b2 JL |
467 | and excludes grayscale colors. |
468 | `luminance' sorts by relative luminance in the CIE XYZ color space." | |
f0bf7c8e JL |
469 | :type '(choice (const :tag "Unsorted" nil) |
470 | (const :tag "Color Name" name) | |
471 | (const :tag "Red-Green-Blue" rgb) | |
472 | (cons :tag "Distance on RGB cube" | |
473 | (const :tag "Distance from Color" rgb-dist) | |
474 | (color :tag "Source Color Name")) | |
475 | (const :tag "Hue-Saturation-Value" hsv) | |
476 | (cons :tag "Distance on HSV cylinder" | |
477 | (const :tag "Distance from Color" hsv-dist) | |
d80d54b2 JL |
478 | (color :tag "Source Color Name")) |
479 | (const :tag "Luminance" luminance)) | |
f0bf7c8e JL |
480 | :group 'facemenu |
481 | :version "24.1") | |
482 | ||
483 | (defun list-colors-sort-key (color) | |
484 | "Return a list of keys for sorting colors depending on `list-colors-sort'. | |
485 | COLOR is the name of the color. When return value is nil, | |
486 | filter out the color from the output." | |
6d713256 | 487 | (require 'color) |
f0bf7c8e JL |
488 | (cond |
489 | ((null list-colors-sort) color) | |
490 | ((eq list-colors-sort 'name) | |
491 | (downcase color)) | |
492 | ((eq list-colors-sort 'rgb) | |
493 | (color-values color)) | |
494 | ((eq (car-safe list-colors-sort) 'rgb-dist) | |
495 | (color-distance color (cdr list-colors-sort))) | |
496 | ((eq list-colors-sort 'hsv) | |
6d713256 | 497 | (apply 'color-rgb-to-hsv (color-name-to-rgb color))) |
f0bf7c8e | 498 | ((eq (car-safe list-colors-sort) 'hsv-dist) |
6d713256 | 499 | (let* ((c-rgb (color-name-to-rgb color)) |
f0bf7c8e JL |
500 | (c-hsv (apply 'color-rgb-to-hsv c-rgb)) |
501 | (o-hsv (apply 'color-rgb-to-hsv | |
6d713256 | 502 | (color-name-to-rgb (cdr list-colors-sort))))) |
f0bf7c8e JL |
503 | (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale |
504 | (eq (nth 1 c-rgb) (nth 2 c-rgb))) | |
505 | ;; 3D Euclidean distance (sqrt is not needed for sorting) | |
506 | (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue | |
507 | (nth 0 o-hsv)))))) 2) | |
508 | (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2) | |
d80d54b2 JL |
509 | (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))) |
510 | ((eq list-colors-sort 'luminance) | |
511 | (let ((c-rgb (color-name-to-rgb color))) | |
512 | (+ (* (nth 0 c-rgb) 0.21266729) | |
513 | (* (nth 1 c-rgb) 0.7151522) | |
514 | (* (nth 2 c-rgb) 0.0721750)))))) | |
6f320937 CY |
515 | |
516 | (defun list-colors-display (&optional list buffer-name callback) | |
7c49006b RS |
517 | "Display names of defined colors, and show what they look like. |
518 | If the optional argument LIST is non-nil, it should be a list of | |
066a23af | 519 | colors to display. Otherwise, this command computes a list of |
ea32ef46 GM |
520 | colors that the current display can handle. Customize |
521 | `list-colors-sort' to change the order in which colors are shown. | |
6f320937 | 522 | |
ea32ef46 | 523 | If the optional argument BUFFER-NAME is nil, it defaults to *Colors*. |
6f320937 CY |
524 | |
525 | If the optional argument CALLBACK is non-nil, it should be a | |
526 | function to call each time the user types RET or clicks on a | |
ea32ef46 | 527 | color. The function should accept a single argument, the color name." |
88d690a9 | 528 | (interactive) |
6062889d | 529 | (when (and (null list) (> (display-color-cells) 0)) |
066a23af | 530 | (setq list (list-colors-duplicates (defined-colors))) |
f0bf7c8e JL |
531 | (when list-colors-sort |
532 | ;; Schwartzian transform with `(color key1 key2 key3 ...)'. | |
533 | (setq list (mapcar | |
534 | 'car | |
535 | (sort (delq nil (mapcar | |
536 | (lambda (c) | |
537 | (let ((key (list-colors-sort-key | |
538 | (car c)))) | |
539 | (when key | |
540 | (cons c (if (consp key) key | |
541 | (list key)))))) | |
542 | list)) | |
543 | (lambda (a b) | |
544 | (let* ((a-keys (cdr a)) | |
545 | (b-keys (cdr b)) | |
546 | (a-key (car a-keys)) | |
547 | (b-key (car b-keys))) | |
548 | ;; Skip common keys at the beginning of key lists. | |
549 | (while (and a-key b-key (equal a-key b-key)) | |
550 | (setq a-keys (cdr a-keys) a-key (car a-keys) | |
551 | b-keys (cdr b-keys) b-key (car b-keys))) | |
552 | (cond | |
553 | ((and (numberp a-key) (numberp b-key)) | |
554 | (< a-key b-key)) | |
555 | ((and (stringp a-key) (stringp b-key)) | |
556 | (string< a-key b-key))))))))) | |
d2596700 MB |
557 | (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color)) |
558 | ;; Don't show more than what the display can handle. | |
559 | (let ((lc (nthcdr (1- (display-color-cells)) list))) | |
560 | (if lc | |
561 | (setcdr lc nil))))) | |
df7f0d0b CY |
562 | (unless buffer-name |
563 | (setq buffer-name "*Colors*")) | |
564 | (with-help-window buffer-name | |
565 | (with-current-buffer standard-output | |
6f320937 | 566 | (erase-buffer) |
fe0fb33e CY |
567 | (list-colors-print list callback) |
568 | (set-buffer-modified-p nil) | |
df7f0d0b | 569 | (setq truncate-lines t))) |
fe0fb33e CY |
570 | (when callback |
571 | (pop-to-buffer buffer-name) | |
572 | (message "Click on a color to select it."))) | |
6f320937 CY |
573 | |
574 | (defun list-colors-print (list &optional callback) | |
575 | (let ((callback-fn | |
576 | (if callback | |
577 | `(lambda (button) | |
578 | (funcall ,callback (button-get button 'color-name)))))) | |
579 | (dolist (color list) | |
580 | (if (consp color) | |
581 | (if (cdr color) | |
582 | (setq color (sort color (lambda (a b) | |
583 | (string< (downcase a) | |
584 | (downcase b)))))) | |
585 | (setq color (list color))) | |
586 | (let* ((opoint (point)) | |
587 | (color-values (color-values (car color))) | |
588 | (light-p (>= (apply 'max color-values) | |
fe0fb33e | 589 | (* (car (color-values "white")) .5)))) |
6f320937 CY |
590 | (insert (car color)) |
591 | (indent-to 22) | |
592 | (put-text-property opoint (point) 'face `(:background ,(car color))) | |
593 | (put-text-property | |
594 | (prog1 (point) | |
89877f5f | 595 | (insert " ") |
fe0fb33e CY |
596 | ;; Insert all color names. |
597 | (insert (mapconcat 'identity color ","))) | |
6f320937 CY |
598 | (point) |
599 | 'face (list :foreground (car color))) | |
fe0fb33e CY |
600 | (insert (propertize " " 'display '(space :align-to (- right 9)))) |
601 | (insert " ") | |
f0bf7c8e JL |
602 | (insert (propertize |
603 | (apply 'format "#%02x%02x%02x" | |
604 | (mapcar (lambda (c) (lsh c -8)) | |
605 | color-values)) | |
606 | 'mouse-face 'highlight | |
607 | 'help-echo | |
608 | (let ((hsv (apply 'color-rgb-to-hsv | |
6d713256 | 609 | (color-name-to-rgb (car color))))) |
f0bf7c8e JL |
610 | (format "H:%d S:%d V:%d" |
611 | (nth 0 hsv) (nth 1 hsv) (nth 2 hsv))))) | |
6f320937 CY |
612 | (when callback |
613 | (make-text-button | |
614 | opoint (point) | |
615 | 'follow-link t | |
616 | 'mouse-face (list :background (car color) | |
617 | :foreground (if light-p "black" "white")) | |
618 | 'color-name (car color) | |
619 | 'action callback-fn))) | |
620 | (insert "\n")) | |
621 | (goto-char (point-min)))) | |
622 | ||
066a23af JL |
623 | |
624 | (defun list-colors-duplicates (&optional list) | |
625 | "Return a list of colors with grouped duplicate colors. | |
626 | If a color has no duplicates, then the element of the returned list | |
627 | has the form '(COLOR-NAME). The element of the returned list with | |
628 | duplicate colors has the form '(COLOR-NAME DUPLICATE-COLOR-NAME ...). | |
629 | This function uses the predicate `facemenu-color-equal' to compare | |
630 | color names. If the optional argument LIST is non-nil, it should | |
631 | be a list of colors to display. Otherwise, this function uses | |
632 | a list of colors that the current display can handle." | |
633 | (let* ((list (mapcar 'list (or list (defined-colors)))) | |
634 | (l list)) | |
635 | (while (cdr l) | |
636 | (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l)))) | |
343a34ff JB |
637 | ;; On MS-Windows, there are logical colors that might have |
638 | ;; the same value but different names and meanings. For | |
639 | ;; example, `SystemMenuText' (the color w32 uses for the | |
640 | ;; text in menu entries) and `SystemWindowText' (the default | |
641 | ;; color w32 uses for the text in windows and dialogs) may | |
642 | ;; be the same display color and be adjacent in the list. | |
958ad486 JB |
643 | ;; These system colors all have names prefixed with "System", |
644 | ;; which is hardcoded in w32fns.c (SYSTEM_COLOR_PREFIX). | |
343a34ff JB |
645 | ;; This makes them different to any other color. Bug#9722 |
646 | (not (and (eq system-type 'windows-nt) | |
647 | (string-match-p "^System" (car (car l)))))) | |
066a23af JL |
648 | (progn |
649 | (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l)))) | |
650 | (setcdr l (cdr (cdr l)))) | |
651 | (setq l (cdr l)))) | |
652 | list)) | |
88d690a9 RS |
653 | |
654 | (defun facemenu-color-equal (a b) | |
655 | "Return t if colors A and B are the same color. | |
7c49006b | 656 | A and B should be strings naming colors. |
f795f633 EZ |
657 | This function queries the display system to find out what the color |
658 | names mean. It returns nil if the colors differ or if it can't | |
7c49006b | 659 | determine the correct answer." |
88d690a9 | 660 | (cond ((equal a b) t) |
f795f633 | 661 | ((equal (color-values a) (color-values b))))) |
88d690a9 | 662 | |
a2e5caf7 SM |
663 | |
664 | (defvar facemenu-self-insert-data nil) | |
665 | ||
666 | (defun facemenu-post-self-insert-function () | |
667 | (when (and (car facemenu-self-insert-data) | |
668 | (eq last-command (cdr facemenu-self-insert-data))) | |
669 | (put-text-property (1- (point)) (point) | |
670 | 'face (car facemenu-self-insert-data)) | |
671 | (setq facemenu-self-insert-data nil)) | |
672 | (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) | |
673 | ||
674 | (defun facemenu-set-self-insert-face (face) | |
675 | "Arrange for the next self-inserted char to have face `face'." | |
676 | (setq facemenu-self-insert-data (cons face this-command)) | |
677 | (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) | |
678 | ||
cb5bec6e | 679 | (defun facemenu-add-face (face &optional start end) |
4a24b314 | 680 | "Add FACE to text between START and END. |
7e6cb513 | 681 | If START is nil or START to END is empty, add FACE to next typed character |
cb5bec6e RS |
682 | instead. For each section of that region that has a different face property, |
683 | FACE will be consed onto it, and other faces that are completely hidden by | |
684 | that will be removed from the list. | |
af1eab21 | 685 | If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil, |
cb5bec6e | 686 | they are used to set the face information. |
bf7d4561 BG |
687 | |
688 | As a special case, if FACE is `default', then the region is left with NO face | |
689 | text property. Otherwise, selecting the default face would not have any | |
cb5bec6e RS |
690 | effect. See `facemenu-remove-face-function'." |
691 | (interactive "*xFace: \nr") | |
a2e5caf7 SM |
692 | (cond |
693 | ((and (eq face 'default) | |
694 | (not (eq facemenu-remove-face-function t))) | |
695 | (if facemenu-remove-face-function | |
696 | (funcall facemenu-remove-face-function start end) | |
cb5bec6e | 697 | (if (and start (< start end)) |
a2e5caf7 SM |
698 | (remove-text-properties start end '(face default)) |
699 | (facemenu-set-self-insert-face 'default)))) | |
700 | (facemenu-add-face-function | |
701 | (save-excursion | |
702 | (if end (goto-char end)) | |
703 | (save-excursion | |
704 | (if start (goto-char start)) | |
705 | (insert-before-markers | |
706 | (funcall facemenu-add-face-function face end))) | |
707 | (if facemenu-end-add-face | |
708 | (insert (if (stringp facemenu-end-add-face) | |
709 | facemenu-end-add-face | |
710 | (funcall facemenu-end-add-face face)))))) | |
711 | ((and start (< start end)) | |
712 | (let ((part-start start) part-end) | |
713 | (while (not (= part-start end)) | |
714 | (setq part-end (next-single-property-change part-start 'face | |
715 | nil end)) | |
716 | (let ((prev (get-text-property part-start 'face))) | |
717 | (put-text-property part-start part-end 'face | |
718 | (if (null prev) | |
719 | face | |
720 | (facemenu-active-faces | |
721 | (cons face | |
722 | (if (listp prev) | |
723 | prev | |
724 | (list prev))) | |
725 | ;; Specify the selected frame | |
726 | ;; because nil would mean to use | |
727 | ;; the new-frame default settings, | |
728 | ;; and those are usually nil. | |
729 | (selected-frame))))) | |
730 | (setq part-start part-end)))) | |
731 | (t | |
732 | (facemenu-set-self-insert-face | |
733 | (if (eq last-command (cdr facemenu-self-insert-data)) | |
734 | (cons face (if (listp (car facemenu-self-insert-data)) | |
735 | (car facemenu-self-insert-data) | |
736 | (list (car facemenu-self-insert-data)))) | |
737 | face)))) | |
97a7aa7b RS |
738 | (unless (facemenu-enable-faces-p) |
739 | (message "Font-lock mode will override any faces you set in this buffer"))) | |
4a24b314 | 740 | |
5a79ed26 KH |
741 | (defun facemenu-active-faces (face-list &optional frame) |
742 | "Return from FACE-LIST those faces that would be used for display. | |
743 | This means each face attribute is not specified in a face earlier in FACE-LIST | |
744 | and such a face is therefore active when used to display text. | |
745 | If the optional argument FRAME is given, use the faces in that frame; otherwise | |
746 | use the selected frame. If t, then the global, non-frame faces are used." | |
7d8177cf RS |
747 | (let* ((mask-atts (copy-sequence |
748 | (if (consp (car face-list)) | |
f790dddf | 749 | (face-attributes-as-vector (car face-list)) |
7d8177cf RS |
750 | (or (internal-lisp-face-p (car face-list) frame) |
751 | (check-face (car face-list)))))) | |
5a79ed26 KH |
752 | (active-list (list (car face-list))) |
753 | (face-list (cdr face-list)) | |
754 | (mask-len (length mask-atts))) | |
755 | (while face-list | |
7d8177cf RS |
756 | (if (let ((face-atts |
757 | (if (consp (car face-list)) | |
f790dddf | 758 | (face-attributes-as-vector (car face-list)) |
7d8177cf RS |
759 | (or (internal-lisp-face-p (car face-list) frame) |
760 | (check-face (car face-list))))) | |
761 | (i mask-len) | |
762 | (useful nil)) | |
240c0c90 | 763 | (while (>= (setq i (1- i)) 0) |
7d8177cf RS |
764 | (and (not (memq (aref face-atts i) '(nil unspecified))) |
765 | (memq (aref mask-atts i) '(nil unspecified)) | |
5a79ed26 KH |
766 | (aset mask-atts i (setq useful t)))) |
767 | useful) | |
768 | (setq active-list (cons (car face-list) active-list))) | |
769 | (setq face-list (cdr face-list))) | |
770 | (nreverse active-list))) | |
4a24b314 | 771 | |
9bf4c4e5 | 772 | (defun facemenu-add-new-face (face) |
cd7890bd RS |
773 | "Add FACE (a face) to the Face menu if `facemenu-listed-faces' says so. |
774 | This is called whenever you create a new face, and at other times." | |
7d8177cf RS |
775 | (let* (name |
776 | symbol | |
9bf4c4e5 RS |
777 | menu docstring |
778 | (key (cdr (assoc face facemenu-keybindings))) | |
88d690a9 | 779 | function menu-val) |
9bf4c4e5 RS |
780 | (if (symbolp face) |
781 | (setq name (symbol-name face) | |
782 | symbol face) | |
783 | (setq name face | |
1d792b18 | 784 | symbol (intern name))) |
9bf4c4e5 RS |
785 | (setq menu 'facemenu-face-menu) |
786 | (setq docstring | |
1e8780b1 | 787 | (purecopy (format "Select face `%s' for subsequent insertion. |
3187841b RS |
788 | If the mark is active and there is no prefix argument, |
789 | apply face `%s' to the region instead. | |
790 | This command was defined by `facemenu-add-new-face'." | |
1e8780b1 | 791 | name name))) |
b6a67507 CY |
792 | (cond ((facemenu-iterate ; check if equivalent face is already in the menu |
793 | (lambda (m) (and (listp m) | |
794 | (symbolp (car m)) | |
f3359de1 RS |
795 | ;; Avoid error in face-equal |
796 | ;; when a non-face is erroneously present. | |
797 | (facep (car m)) | |
b6a67507 CY |
798 | (face-equal (car m) symbol))) |
799 | (cdr (symbol-function menu)))) | |
800 | ;; Faces with a keyboard equivalent. These go at the front. | |
801 | (key | |
88d690a9 RS |
802 | (setq function (intern (concat "facemenu-set-" name))) |
803 | (fset function | |
536f1a10 RS |
804 | `(lambda () |
805 | ,docstring | |
806 | (interactive) | |
af1eab21 RS |
807 | (facemenu-set-face |
808 | (quote ,symbol) | |
809 | (if (and mark-active (not current-prefix-arg)) | |
810 | (region-beginning)) | |
811 | (if (and mark-active (not current-prefix-arg)) | |
812 | (region-end))))) | |
88d690a9 RS |
813 | (define-key 'facemenu-keymap key (cons name function)) |
814 | (define-key menu key (cons name function))) | |
b6a67507 CY |
815 | ;; Faces with no keyboard equivalent. Figure out where to put it: |
816 | ((or (eq t facemenu-listed-faces) | |
817 | (memq symbol facemenu-listed-faces)) | |
7d8177cf | 818 | (setq key (vector symbol) |
88d690a9 RS |
819 | function 'facemenu-set-face-from-menu |
820 | menu-val (symbol-function menu)) | |
821 | (if (and facemenu-new-faces-at-end | |
b6a67507 | 822 | (> (length menu-val) 3)) |
88d690a9 | 823 | (define-key-after menu-val key (cons name function) |
9bf4c4e5 RS |
824 | (car (nth (- (length menu-val) 3) menu-val))) |
825 | (define-key menu key (cons name function)))))) | |
826 | nil) ; Return nil for facemenu-iterate | |
827 | ||
019b1899 | 828 | (defun facemenu-add-new-color (color menu) |
9bf4c4e5 | 829 | "Add COLOR (a color name string) to the appropriate Face menu. |
019b1899 | 830 | MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'. |
b97c98ad | 831 | Return the event type (a symbol) of the added menu entry. |
9bf4c4e5 RS |
832 | |
833 | This is called whenever you use a new color." | |
06b60517 | 834 | (let (symbol) |
019b1899 LK |
835 | (unless (color-defined-p color) |
836 | (error "Color `%s' undefined" color)) | |
9bf4c4e5 | 837 | (cond ((eq menu 'facemenu-foreground-menu) |
06b60517 | 838 | (setq symbol (intern (concat "fg:" color)))) |
9bf4c4e5 | 839 | ((eq menu 'facemenu-background-menu) |
06b60517 | 840 | (setq symbol (intern (concat "bg:" color)))) |
019b1899 | 841 | (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'"))) |
b97c98ad LK |
842 | (unless (facemenu-iterate ; Check if color is already in the menu. |
843 | (lambda (m) (and (listp m) | |
844 | (eq (car m) symbol))) | |
845 | (cdr (symbol-function menu))) | |
846 | ;; Color is not in the menu. Figure out where to put it. | |
847 | (let ((key (vector symbol)) | |
848 | (function 'facemenu-set-face-from-menu) | |
849 | (menu-val (symbol-function menu))) | |
850 | (if (and facemenu-new-faces-at-end | |
851 | (> (length menu-val) 3)) | |
852 | (define-key-after menu-val key (cons color function) | |
853 | (car (nth (- (length menu-val) 3) menu-val))) | |
854 | (define-key menu key (cons color function))))) | |
019b1899 | 855 | symbol)) |
bf7d4561 | 856 | |
bf7d4561 | 857 | (defun facemenu-complete-face-list (&optional oldlist) |
7cd49450 | 858 | "Return list of all faces that look different. |
71296446 | 859 | Starts with given ALIST of faces, and adds elements only if they display |
bf7d4561 | 860 | differently from any face already on the list. |
71296446 | 861 | The faces on ALIST will end up at the end of the returned list, in reverse |
bf7d4561 BG |
862 | order." |
863 | (let ((list (nreverse (mapcar 'car oldlist)))) | |
71296446 JB |
864 | (facemenu-iterate |
865 | (lambda (new-face) | |
bf7d4561 BG |
866 | (if (not (memq new-face list)) |
867 | (setq list (cons new-face list))) | |
868 | nil) | |
869 | (nreverse (face-list))) | |
870 | list)) | |
871 | ||
7e6cb513 | 872 | (defun facemenu-iterate (func list) |
4e8aa578 RS |
873 | "Apply FUNC to each element of LIST until one returns non-nil. |
874 | Returns the non-nil value it found, or nil if all were nil." | |
7e6cb513 SM |
875 | (while (and list (not (funcall func (car list)))) |
876 | (setq list (cdr list))) | |
877 | (car list)) | |
4e8aa578 RS |
878 | |
879 | (facemenu-update) | |
4e8aa578 | 880 | |
1ff4ace5 | 881 | (provide 'facemenu) |
ab5796a9 | 882 | |
4e8aa578 | 883 | ;;; facemenu.el ends here |