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