Commit | Line | Data |
---|---|---|
4e8aa578 | 1 | ;;; facemenu.el -- Create a face menu for interactively adding fonts to text |
732be465 | 2 | ;; Copyright (c) 1994, 1995 Free Software Foundation, Inc. |
4e8aa578 RS |
3 | |
4 | ;; Author: Boris Goldowsky <boris@cs.rochester.edu> | |
5 | ;; Keywords: faces | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | ||
23 | ;;; Commentary: | |
bf7d4561 BG |
24 | ;; This file defines a menu of faces (bold, italic, etc) which allows you to |
25 | ;; set the face used for a region of the buffer. Some faces also have | |
26 | ;; keybindings, which are shown in the menu. Faces with names beginning with | |
88d690a9 | 27 | ;; "fg:" or "bg:", as in "fg:red", are treated specially. |
bf7d4561 BG |
28 | ;; Such faces are assumed to consist only of a foreground (if "fg:") or |
29 | ;; background (if "bg:") color. They are thus put into the color submenus | |
88d690a9 RS |
30 | ;; rather than the general Face submenu. These faces can also be |
31 | ;; automatically created by selecting the "Other..." menu items in the | |
32 | ;; "Foreground" and "Background" submenus. | |
33 | ;; | |
34 | ;; The menu also contains submenus for indentation and justification-changing | |
35 | ;; commands. | |
4e8aa578 | 36 | |
4e8aa578 | 37 | ;;; Usage: |
bf7d4561 BG |
38 | ;; Selecting a face from the menu or typing the keyboard equivalent will |
39 | ;; change the region to use that face. If you use transient-mark-mode and the | |
40 | ;; region is not active, the face will be remembered and used for the next | |
41 | ;; insertion. It will be forgotten if you move point or make other | |
42 | ;; modifications before inserting or typing anything. | |
4e8aa578 RS |
43 | ;; |
44 | ;; Faces can be selected from the keyboard as well. | |
88d690a9 RS |
45 | ;; The standard keybindings are M-g (or ESC g) + letter: |
46 | ;; M-g i = "set italic", M-g b = "set bold", etc. | |
4e8aa578 RS |
47 | |
48 | ;;; Customization: | |
49 | ;; An alternative set of keybindings that may be easier to type can be set up | |
88d690a9 RS |
50 | ;; using "Alt" or "Hyper" keys. This requires that you either have or create |
51 | ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key | |
52 | ;; labeled "Alt", but to make it act as an Alt key I have to put this command | |
53 | ;; into my .xinitrc: | |
54 | ;; xmodmap -e "add Mod3 = Alt_L" | |
55 | ;; Or, I can make it into a Hyper key with this: | |
4e8aa578 | 56 | ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" |
88d690a9 RS |
57 | ;; Check with local X-perts for how to do it on your system. |
58 | ;; Then you can define your keybindings with code like this in your .emacs: | |
4e8aa578 RS |
59 | ;; (setq facemenu-keybindings |
60 | ;; '((default . [?\H-d]) | |
61 | ;; (bold . [?\H-b]) | |
62 | ;; (italic . [?\H-i]) | |
88d690a9 | 63 | ;; (bold-italic . [?\H-l]) |
4e8aa578 RS |
64 | ;; (underline . [?\H-u]))) |
65 | ;; (setq facemenu-keymap global-map) | |
66 | ;; (setq facemenu-key nil) | |
88d690a9 RS |
67 | ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color |
68 | ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color | |
69 | ;; (require 'facemenu) | |
4e8aa578 | 70 | ;; |
88d690a9 RS |
71 | ;; The order of the faces that appear in the menu and their keybindings can be |
72 | ;; controlled by setting the variables `facemenu-keybindings' and | |
73 | ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents | |
74 | ;; (eg, `region') in `facemenu-unlisted-faces'. | |
4e8aa578 RS |
75 | |
76 | ;;; Known Problems: | |
88d690a9 RS |
77 | ;; Bold and Italic do not combine to create bold-italic if you select them |
78 | ;; both, although most other combinations (eg bold + underline + some color) | |
79 | ;; do the intuitive thing. | |
80 | ;; | |
4e8aa578 RS |
81 | ;; There is at present no way to display what the faces look like in |
82 | ;; the menu itself. | |
83 | ;; | |
84 | ;; `list-faces-display' shows the faces in a different order than | |
85 | ;; this menu, which could be confusing. I do /not/ sort the list | |
86 | ;; alphabetically, because I like the default order: it puts the most | |
87 | ;; basic, common fonts first. | |
88 | ;; | |
89 | ;; Please send me any other problems, comments or ideas. | |
90 | ||
91 | ;;; Code: | |
92 | ||
93 | (provide 'facemenu) | |
94 | ||
9dc90430 BG |
95 | ;;; Provide some binding for startup: |
96 | ;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap) | |
97 | ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap) | |
98 | ||
d2eafd88 | 99 | (defvar facemenu-key "\M-g" |
9dc90430 | 100 | "Prefix key to use for facemenu commands.") |
4e8aa578 | 101 | |
4e8aa578 RS |
102 | (defvar facemenu-keybindings |
103 | '((default . "d") | |
104 | (bold . "b") | |
105 | (italic . "i") | |
88d690a9 | 106 | (bold-italic . "l") ; {bold} intersect {italic} = {l} |
4e8aa578 RS |
107 | (underline . "u")) |
108 | "Alist of interesting faces and keybindings. | |
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; | |
111 | the binding is made in facemenu-keymap. | |
112 | ||
113 | The faces specifically mentioned in this list are put at the top of | |
114 | the menu, in the order specified. All other faces which are defined, | |
115 | except for those in `facemenu-unlisted-faces', are listed after them, | |
116 | but get no keyboard equivalents. | |
117 | ||
118 | If you change this variable after loading facemenu.el, you will need to call | |
119 | `facemenu-update' to make it take effect.") | |
120 | ||
88d690a9 RS |
121 | (defvar facemenu-new-faces-at-end t |
122 | "Where in the menu to insert newly-created faces. | |
123 | This should be nil to put them at the top of the menu, or t to put them | |
124 | just before \"Other\" at the end.") | |
125 | ||
4e8aa578 | 126 | (defvar facemenu-unlisted-faces |
da627a71 BG |
127 | '(modeline region secondary-selection highlight scratch-face |
128 | font-lock-comment-face font-lock-string-face font-lock-keyword-face | |
129 | font-lock-function-name-face font-lock-variable-name-face | |
130 | font-lock-type-face font-lock-reference-face) | |
88d690a9 | 131 | "List of faces not to include in the Face menu. |
4e8aa578 | 132 | Set this before loading facemenu.el, or call `facemenu-update' after |
88d690a9 | 133 | changing it. |
4e8aa578 | 134 | |
88d690a9 RS |
135 | If this variable is t, no faces will be added to the menu. This is useful for |
136 | temporarily turning off the feature that automatically adds faces to the menu | |
137 | when they are created.") | |
138 | ||
9dc90430 | 139 | ;;;###autoload |
88d690a9 | 140 | (defvar facemenu-face-menu |
bf7d4561 | 141 | (let ((map (make-sparse-keymap "Face"))) |
88d690a9 | 142 | (define-key map "o" (cons "Other..." 'facemenu-set-face)) |
bf7d4561 BG |
143 | map) |
144 | "Menu keymap for faces.") | |
9dc90430 | 145 | ;;;###autoload |
88d690a9 | 146 | (defalias 'facemenu-face-menu facemenu-face-menu) |
bf7d4561 | 147 | |
9dc90430 | 148 | ;;;###autoload |
bf7d4561 BG |
149 | (defvar facemenu-foreground-menu |
150 | (let ((map (make-sparse-keymap "Foreground Color"))) | |
151 | (define-key map "o" (cons "Other" 'facemenu-set-foreground)) | |
152 | map) | |
153 | "Menu keymap for foreground colors.") | |
9dc90430 | 154 | ;;;###autoload |
88d690a9 | 155 | (defalias 'facemenu-foreground-menu facemenu-foreground-menu) |
bf7d4561 | 156 | |
9dc90430 | 157 | ;;;###autoload |
bf7d4561 BG |
158 | (defvar facemenu-background-menu |
159 | (let ((map (make-sparse-keymap "Background Color"))) | |
160 | (define-key map "o" (cons "Other" 'facemenu-set-background)) | |
161 | map) | |
162 | "Menu keymap for background colors") | |
9dc90430 | 163 | ;;;###autoload |
88d690a9 | 164 | (defalias 'facemenu-background-menu facemenu-background-menu) |
bf7d4561 | 165 | |
9dc90430 | 166 | ;;;###autoload |
bf7d4561 BG |
167 | (defvar facemenu-special-menu |
168 | (let ((map (make-sparse-keymap "Special"))) | |
169 | (define-key map [read-only] (cons "Read-Only" 'facemenu-set-read-only)) | |
170 | (define-key map [invisible] (cons "Invisible" 'facemenu-set-invisible)) | |
171 | map) | |
172 | "Menu keymap for non-face text-properties.") | |
9dc90430 | 173 | ;;;###autoload |
88d690a9 RS |
174 | (defalias 'facemenu-special-menu facemenu-special-menu) |
175 | ||
9dc90430 | 176 | ;;;###autoload |
88d690a9 RS |
177 | (defvar facemenu-justification-menu |
178 | (let ((map (make-sparse-keymap "Justification"))) | |
9dc90430 BG |
179 | (define-key map [?c] (cons "Center" 'set-justification-center)) |
180 | (define-key map [?b] (cons "Full" 'set-justification-full)) | |
181 | (define-key map [?r] (cons "Right" 'set-justification-right)) | |
182 | (define-key map [?l] (cons "Left" 'set-justification-left)) | |
183 | (define-key map [?u] (cons "Unfilled" 'set-justification-none)) | |
88d690a9 RS |
184 | map) |
185 | "Submenu for text justification commands.") | |
9dc90430 | 186 | ;;;###autoload |
88d690a9 RS |
187 | (defalias 'facemenu-justification-menu facemenu-justification-menu) |
188 | ||
9dc90430 | 189 | ;;;###autoload |
88d690a9 RS |
190 | (defvar facemenu-indentation-menu |
191 | (let ((map (make-sparse-keymap "Indentation"))) | |
192 | (define-key map [UnIndentRight] | |
193 | (cons "UnIndentRight" 'decrease-right-margin)) | |
194 | (define-key map [IndentRight] | |
195 | (cons "IndentRight" 'increase-right-margin)) | |
196 | (define-key map [Unindent] | |
197 | (cons "UnIndent" 'decrease-left-margin)) | |
198 | (define-key map [Indent] | |
199 | (cons "Indent" 'increase-left-margin)) | |
200 | map) | |
201 | "Submenu for indentation commands.") | |
9dc90430 | 202 | ;;;###autoload |
88d690a9 | 203 | (defalias 'facemenu-indentation-menu facemenu-indentation-menu) |
bf7d4561 | 204 | |
9dc90430 | 205 | ;;;###autoload |
bf7d4561 BG |
206 | (defvar facemenu-menu |
207 | (let ((map (make-sparse-keymap "Face"))) | |
88d690a9 RS |
208 | (define-key map [dc] (cons "Display Colors" 'list-colors-display)) |
209 | (define-key map [df] (cons "Display Faces" 'list-faces-display)) | |
c0a7db84 BG |
210 | (define-key map [dp] (cons "List Properties" 'list-text-properties-at)) |
211 | (define-key map [rm] (cons "Remove Properties" 'facemenu-remove-all)) | |
88d690a9 RS |
212 | (define-key map [s1] (list "-----------------")) |
213 | (define-key map [in] (cons "Indentation" 'facemenu-indentation-menu)) | |
214 | (define-key map [ju] (cons "Justification" 'facemenu-justification-menu)) | |
215 | (define-key map [s2] (list "-----------------")) | |
216 | (define-key map [sp] (cons "Special Props" 'facemenu-special-menu)) | |
217 | (define-key map [bg] (cons "Background Color" 'facemenu-background-menu)) | |
218 | (define-key map [fg] (cons "Foreground Color" 'facemenu-foreground-menu)) | |
219 | (define-key map [fc] (cons "Face" 'facemenu-face-menu)) | |
bf7d4561 | 220 | map) |
535d2617 | 221 | "Facemenu top-level menu keymap.") |
9dc90430 | 222 | ;;;###autoload |
88d690a9 | 223 | (defalias 'facemenu-menu facemenu-menu) |
bf7d4561 | 224 | |
88d690a9 RS |
225 | (defvar facemenu-keymap |
226 | (let ((map (make-sparse-keymap "Set face"))) | |
227 | (define-key map "o" (cons "Other" 'facemenu-set-face)) | |
228 | map) | |
9dc90430 | 229 | "Keymap for face-changing commands. |
bf7d4561 | 230 | `Facemenu-update' fills in the keymap according to the bindings |
535d2617 | 231 | requested in `facemenu-keybindings'.") |
88d690a9 | 232 | (defalias 'facemenu-keymap facemenu-keymap) |
bf7d4561 BG |
233 | |
234 | ;;; Internal Variables | |
235 | ||
236 | (defvar facemenu-color-alist nil | |
237 | ;; Don't initialize here; that doesn't work if preloaded. | |
238 | "Alist of colors, used for completion. | |
239 | If null, `facemenu-read-color' will set it.") | |
4a24b314 | 240 | |
4e8aa578 | 241 | (defun facemenu-update () |
bf7d4561 BG |
242 | "Add or update the \"Face\" menu in the menu bar. |
243 | You can call this to update things if you change any of the menu configuration | |
244 | variables." | |
4e8aa578 RS |
245 | (interactive) |
246 | ||
bf7d4561 | 247 | ;; Global bindings: |
88d690a9 RS |
248 | (define-key global-map [C-down-mouse-2] 'facemenu-menu) |
249 | (if facemenu-key (define-key global-map facemenu-key 'facemenu-keymap)) | |
4e8aa578 | 250 | |
bf7d4561 BG |
251 | ;; Add each defined face to the menu. |
252 | (facemenu-iterate 'facemenu-add-new-face | |
253 | (facemenu-complete-face-list facemenu-keybindings))) | |
4a24b314 | 254 | |
4e8aa578 RS |
255 | ;;;###autoload |
256 | (defun facemenu-set-face (face &optional start end) | |
4a24b314 RS |
257 | "Add FACE to the region or next character typed. |
258 | It will be added to the top of the face list; any faces lower on the list that | |
259 | will not show through at all will be removed. | |
260 | ||
261 | Interactively, the face to be used is prompted for. | |
262 | If the region is active, it will be set to the requested face. If | |
4e8aa578 | 263 | it is inactive \(even if mark-even-if-inactive is set) the next |
88d690a9 | 264 | character that is typed \(or otherwise inserted) will be set to |
4e8aa578 RS |
265 | the the selected face. Moving point or switching buffers before |
266 | typing a character cancels the request." | |
267 | (interactive (list (read-face-name "Use face: "))) | |
88d690a9 RS |
268 | (barf-if-buffer-read-only) |
269 | (facemenu-add-new-face face) | |
4e8aa578 | 270 | (if mark-active |
4a24b314 RS |
271 | (let ((start (or start (region-beginning))) |
272 | (end (or end (region-end)))) | |
273 | (facemenu-add-face face start end)) | |
7fce8c91 | 274 | (facemenu-self-insert-face face))) |
4a24b314 | 275 | |
bf7d4561 | 276 | ;;;###autoload |
4a24b314 RS |
277 | (defun facemenu-set-foreground (color &optional start end) |
278 | "Set the foreground color of the region or next character typed. | |
279 | The color is prompted for. A face named `fg:color' is used \(or created). | |
280 | If the region is active, it will be set to the requested face. If | |
281 | it is inactive \(even if mark-even-if-inactive is set) the next | |
282 | character that is typed \(via `self-insert-command') will be set to | |
283 | the the selected face. Moving point or switching buffers before | |
284 | typing a character cancels the request." | |
285 | (interactive (list (facemenu-read-color "Foreground color: "))) | |
286 | (let ((face (intern (concat "fg:" color)))) | |
287 | (or (facemenu-get-face face) | |
288 | (error "Unknown color: %s" color)) | |
289 | (facemenu-set-face face start end))) | |
290 | ||
bf7d4561 | 291 | ;;;###autoload |
4a24b314 RS |
292 | (defun facemenu-set-background (color &optional start end) |
293 | "Set the background color of the region or next character typed. | |
294 | The color is prompted for. A face named `bg:color' is used \(or created). | |
295 | If the region is active, it will be set to the requested face. If | |
296 | it is inactive \(even if mark-even-if-inactive is set) the next | |
297 | character that is typed \(via `self-insert-command') will be set to | |
298 | the the selected face. Moving point or switching buffers before | |
299 | typing a character cancels the request." | |
300 | (interactive (list (facemenu-read-color "Background color: "))) | |
301 | (let ((face (intern (concat "bg:" color)))) | |
302 | (or (facemenu-get-face face) | |
303 | (error "Unknown color: %s" color)) | |
304 | (facemenu-set-face face start end))) | |
4e8aa578 | 305 | |
9dc90430 | 306 | ;;;###autoload |
4e8aa578 RS |
307 | (defun facemenu-set-face-from-menu (face start end) |
308 | "Set the face of the region or next character typed. | |
309 | This function is designed to be called from a menu; the face to use | |
310 | is the menu item's name. | |
311 | If the region is active, it will be set to the requested face. If | |
312 | it is inactive \(even if mark-even-if-inactive is set) the next | |
88d690a9 | 313 | character that is typed \(or otherwise inserted) will be set to |
4e8aa578 RS |
314 | the the selected face. Moving point or switching buffers before |
315 | typing a character cancels the request." | |
4a24b314 RS |
316 | (interactive (list last-command-event |
317 | (if mark-active (region-beginning)) | |
318 | (if mark-active (region-end)))) | |
88d690a9 | 319 | (barf-if-buffer-read-only) |
4a24b314 | 320 | (facemenu-get-face face) |
4e8aa578 | 321 | (if start |
4a24b314 | 322 | (facemenu-add-face face start end) |
7fce8c91 RS |
323 | (facemenu-self-insert-face face))) |
324 | ||
325 | (defun facemenu-self-insert-face (face) | |
41e5bf66 BG |
326 | (setq self-insert-face (if (eq last-command self-insert-face-command) |
327 | (cons face (if (listp self-insert-face) | |
328 | self-insert-face | |
329 | (list self-insert-face))) | |
330 | face) | |
7fce8c91 | 331 | self-insert-face-command this-command)) |
4e8aa578 | 332 | |
9dc90430 | 333 | ;;;###autoload |
4e8aa578 RS |
334 | (defun facemenu-set-invisible (start end) |
335 | "Make the region invisible. | |
336 | This sets the `invisible' text property; it can be undone with | |
337 | `facemenu-remove-all'." | |
338 | (interactive "r") | |
339 | (put-text-property start end 'invisible t)) | |
340 | ||
9dc90430 | 341 | ;;;###autoload |
4e8aa578 RS |
342 | (defun facemenu-set-intangible (start end) |
343 | "Make the region intangible: disallow moving into it. | |
344 | This sets the `intangible' text property; it can be undone with | |
345 | `facemenu-remove-all'." | |
346 | (interactive "r") | |
347 | (put-text-property start end 'intangible t)) | |
348 | ||
9dc90430 | 349 | ;;;###autoload |
4e8aa578 RS |
350 | (defun facemenu-set-read-only (start end) |
351 | "Make the region unmodifiable. | |
352 | This sets the `read-only' text property; it can be undone with | |
353 | `facemenu-remove-all'." | |
354 | (interactive "r") | |
355 | (put-text-property start end 'read-only t)) | |
356 | ||
9dc90430 | 357 | ;;;###autoload |
4e8aa578 RS |
358 | (defun facemenu-remove-all (start end) |
359 | "Remove all text properties that facemenu added to region." | |
360 | (interactive "*r") ; error if buffer is read-only despite the next line. | |
361 | (let ((inhibit-read-only t)) | |
362 | (remove-text-properties | |
363 | start end '(face nil invisible nil intangible nil | |
364 | read-only nil category nil)))) | |
365 | ||
c0a7db84 BG |
366 | ;;;###autoload |
367 | (defun list-text-properties-at (p) | |
368 | "Pop up a buffer listing text-properties at LOCATION." | |
369 | (interactive "d") | |
370 | (let ((props (text-properties-at p))) | |
371 | (if (null props) | |
372 | (message "None") | |
373 | (with-output-to-temp-buffer "*Text Properties*" | |
374 | (princ (format "Text properties at %d:\n\n" p)) | |
375 | (while props | |
376 | (princ (format "%-20s %S\n" | |
377 | (car props) (car (cdr props)))) | |
378 | (setq props (cdr (cdr props)))))))) | |
379 | ||
bf7d4561 | 380 | ;;;###autoload |
da627a71 | 381 | (defun facemenu-read-color (&optional prompt) |
bf7d4561 | 382 | "Read a color using the minibuffer." |
da627a71 | 383 | (let ((col (completing-read (or prompt "Color: ") |
bf7d4561 BG |
384 | (or facemenu-color-alist |
385 | (if (eq 'x window-system) | |
386 | (mapcar 'list (x-defined-colors)))) | |
387 | nil t))) | |
388 | (if (equal "" col) | |
389 | nil | |
390 | col))) | |
4e8aa578 | 391 | |
88d690a9 RS |
392 | ;;;###autoload |
393 | (defun list-colors-display (&optional list) | |
394 | "Display colors. | |
395 | You can optionally supply a LIST of colors to display, or this function will | |
396 | get a list for the current display, removing alternate names for the same | |
397 | color." | |
398 | (interactive) | |
399 | (if (and (null list) (eq 'x window-system)) | |
400 | (let ((l (setq list (x-defined-colors)))) | |
401 | (while (cdr l) | |
402 | (if (facemenu-color-equal (car l) (car (cdr l))) | |
403 | (setcdr l (cdr (cdr l))) | |
404 | (setq l (cdr l)))))) | |
405 | (with-output-to-temp-buffer "*Colors*" | |
406 | (save-excursion | |
407 | (set-buffer standard-output) | |
408 | (let ((facemenu-unlisted-faces t) | |
409 | s) | |
410 | (while list | |
411 | (setq s (point)) | |
412 | (insert (car list)) | |
413 | (indent-to 20) | |
414 | (put-text-property s (point) 'face | |
415 | (facemenu-get-face | |
416 | (intern (concat "bg:" (car list))))) | |
417 | (setq s (point)) | |
418 | (insert " " (car list) "\n") | |
419 | (put-text-property s (point) 'face | |
420 | (facemenu-get-face | |
421 | (intern (concat "fg:" (car list))))) | |
422 | (setq list (cdr list))))))) | |
423 | ||
424 | (defun facemenu-color-equal (a b) | |
425 | "Return t if colors A and B are the same color. | |
426 | A and B should be strings naming colors. The window-system server is queried | |
427 | to find how they would actually be displayed. Nil is always returned if the | |
428 | correct answer cannot be determined." | |
429 | (cond ((equal a b) t) | |
430 | ((and (eq 'x window-system) | |
431 | (equal (x-color-values a) (x-color-values b)))))) | |
432 | ||
4a24b314 RS |
433 | (defun facemenu-add-face (face start end) |
434 | "Add FACE to text between START and END. | |
435 | For each section of that region that has a different face property, FACE will | |
436 | be consed onto it, and other faces that are completely hidden by that will be | |
bf7d4561 BG |
437 | removed from the list. |
438 | ||
439 | As a special case, if FACE is `default', then the region is left with NO face | |
440 | text property. Otherwise, selecting the default face would not have any | |
441 | effect." | |
4a24b314 | 442 | (interactive "*xFace:\nr") |
bf7d4561 BG |
443 | (if (eq face 'default) |
444 | (remove-text-properties start end '(face default)) | |
445 | (let ((part-start start) part-end) | |
446 | (while (not (= part-start end)) | |
447 | (setq part-end (next-single-property-change part-start 'face nil end)) | |
448 | (let ((prev (get-text-property part-start 'face))) | |
449 | (put-text-property part-start part-end 'face | |
450 | (if (null prev) | |
451 | face | |
452 | (facemenu-discard-redundant-faces | |
453 | (cons face | |
454 | (if (listp prev) prev (list prev))))))) | |
455 | (setq part-start part-end))))) | |
4a24b314 RS |
456 | |
457 | (defun facemenu-discard-redundant-faces (face-list &optional mask) | |
458 | "Remove from FACE-LIST any faces that won't show at all. | |
459 | This means they have no non-nil elements that aren't also non-nil in an | |
460 | earlier face." | |
461 | (let ((useful nil)) | |
462 | (cond ((null face-list) nil) | |
463 | ((null mask) | |
464 | (cons (car face-list) | |
465 | (facemenu-discard-redundant-faces | |
466 | (cdr face-list) | |
467 | (copy-sequence (internal-get-face (car face-list)))))) | |
468 | ((let ((i (length mask)) | |
469 | (face (internal-get-face (car face-list)))) | |
470 | (while (>= (setq i (1- i)) 0) | |
471 | (if (and (aref face i) | |
472 | (not (aref mask i))) | |
473 | (progn (setq useful t) | |
474 | (aset mask i t)))) | |
475 | useful) | |
476 | (cons (car face-list) | |
477 | (facemenu-discard-redundant-faces (cdr face-list) mask))) | |
478 | (t (facemenu-discard-redundant-faces (cdr face-list) mask))))) | |
479 | ||
bf7d4561 BG |
480 | (defun facemenu-get-face (symbol) |
481 | "Make sure FACE exists. | |
482 | If not, it is created. If it is created and is of the form `fg:color', then | |
483 | set the foreground to that color. If of the form `bg:color', set the | |
88d690a9 RS |
484 | background. In any case, add it to the appropriate menu. Returns the face, |
485 | or nil if given a bad color." | |
486 | (if (or (internal-find-face symbol) | |
487 | (let* ((face (make-face symbol)) | |
488 | (name (symbol-name symbol)) | |
489 | (color (substring name 3))) | |
490 | (cond ((string-match "^fg:" name) | |
491 | (set-face-foreground face color) | |
492 | (and (eq 'x window-system) (x-color-defined-p color))) | |
493 | ((string-match "^bg:" name) | |
494 | (set-face-background face color) | |
495 | (and (eq 'x window-system) (x-color-defined-p color))) | |
496 | (t)))) | |
497 | symbol)) | |
bf7d4561 BG |
498 | |
499 | (defun facemenu-add-new-face (face) | |
500 | "Add a FACE to the appropriate Face menu. | |
501 | Automatically called when a new face is created." | |
502 | (let* ((name (symbol-name face)) | |
503 | (menu (cond ((string-match "^fg:" name) | |
504 | (setq name (substring name 3)) | |
88d690a9 | 505 | 'facemenu-foreground-menu) |
bf7d4561 BG |
506 | ((string-match "^bg:" name) |
507 | (setq name (substring name 3)) | |
88d690a9 RS |
508 | 'facemenu-background-menu) |
509 | (t 'facemenu-face-menu))) | |
510 | (key (cdr (assoc face facemenu-keybindings))) | |
511 | function menu-val) | |
512 | (cond ((eq t facemenu-unlisted-faces)) | |
513 | ((memq face facemenu-unlisted-faces)) | |
514 | (key ; has a keyboard equivalent. These go at the front. | |
515 | (setq function (intern (concat "facemenu-set-" name))) | |
516 | (fset function | |
517 | (` (lambda () (interactive) | |
518 | (facemenu-set-face (quote (, face)))))) | |
519 | (define-key 'facemenu-keymap key (cons name function)) | |
520 | (define-key menu key (cons name function))) | |
521 | ((facemenu-iterate ; check if equivalent face is already in the menu | |
522 | (lambda (m) (and (listp m) | |
523 | (symbolp (car m)) | |
524 | (face-equal (car m) face))) | |
525 | (cdr (symbol-function menu)))) | |
526 | (t ; No keyboard equivalent. Figure out where to put it: | |
527 | (setq key (vector face) | |
528 | function 'facemenu-set-face-from-menu | |
529 | menu-val (symbol-function menu)) | |
530 | (if (and facemenu-new-faces-at-end | |
531 | (> (length menu-val) 3)) | |
532 | (define-key-after menu-val key (cons name function) | |
533 | (car (nth (- (length menu-val) 3) menu-val))) | |
534 | (define-key menu key (cons name function)))))) | |
535 | nil) ; Return nil for facemenu-iterate | |
bf7d4561 | 536 | |
bf7d4561 BG |
537 | (defun facemenu-complete-face-list (&optional oldlist) |
538 | "Return list of all faces that are look different. | |
539 | Starts with given ALIST of faces, and adds elements only if they display | |
540 | differently from any face already on the list. | |
541 | The faces on ALIST will end up at the end of the returned list, in reverse | |
542 | order." | |
543 | (let ((list (nreverse (mapcar 'car oldlist)))) | |
544 | (facemenu-iterate | |
545 | (lambda (new-face) | |
546 | (if (not (memq new-face list)) | |
547 | (setq list (cons new-face list))) | |
548 | nil) | |
549 | (nreverse (face-list))) | |
550 | list)) | |
551 | ||
4e8aa578 RS |
552 | (defun facemenu-iterate (func iterate-list) |
553 | "Apply FUNC to each element of LIST until one returns non-nil. | |
554 | Returns the non-nil value it found, or nil if all were nil." | |
555 | (while (and iterate-list (not (funcall func (car iterate-list)))) | |
556 | (setq iterate-list (cdr iterate-list))) | |
557 | (car iterate-list)) | |
558 | ||
559 | (facemenu-update) | |
4e8aa578 RS |
560 | |
561 | ;;; facemenu.el ends here |