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