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