|
0
|
1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
|
|
70
|
2 ;; Copyright (c) 1994, 1995 Free Software Foundation, Inc.
|
|
0
|
3
|
|
|
4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
|
|
5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu>
|
|
|
6 ;; Keywords: faces
|
|
|
7
|
|
70
|
8 ;; This file is part of GNU Emacs.
|
|
0
|
9
|
|
70
|
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
|
|
0
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
70
|
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.
|
|
0
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
70
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
0
|
23
|
|
70
|
24 ;;; Synched up with: FSF 19.30.
|
|
0
|
25
|
|
|
26 ;;; Commentary:
|
|
|
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
|
|
|
30 ;; "fg:" or "bg:", as in "fg:red", are treated specially.
|
|
|
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
|
|
|
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.
|
|
|
39
|
|
70
|
40 ;;; Installation:
|
|
|
41 ;; Just do a (require 'facemenu).
|
|
|
42 ;; If you want the menu bound to a mouse button under XEmacs, do
|
|
|
43 ;; (define-key global-map '(control button2) 'facemenu-menu)
|
|
|
44
|
|
0
|
45 ;;; Usage:
|
|
|
46 ;; Selecting a face from the menu or typing the keyboard equivalent will
|
|
|
47 ;; change the region to use that face. If you use transient-mark-mode and the
|
|
|
48 ;; region is not active, the face will be remembered and used for the next
|
|
|
49 ;; insertion. It will be forgotten if you move point or make other
|
|
|
50 ;; modifications before inserting or typing anything.
|
|
|
51 ;;
|
|
|
52 ;; Faces can be selected from the keyboard as well.
|
|
|
53 ;; The standard keybindings are M-g (or ESC g) + letter:
|
|
|
54 ;; M-g i = "set italic", M-g b = "set bold", etc.
|
|
|
55
|
|
|
56 ;;
|
|
|
57 ;; The order of the faces that appear in the menu and their keybindings can be
|
|
|
58 ;; controlled by setting the variables `facemenu-keybindings' and
|
|
|
59 ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents
|
|
|
60 ;; (eg, `region') in `facemenu-unlisted-faces'.
|
|
|
61
|
|
|
62 ;;; Known Problems:
|
|
|
63 ;; Bold and Italic do not combine to create bold-italic if you select them
|
|
|
64 ;; both, although most other combinations (eg bold + underline + some color)
|
|
|
65 ;; do the intuitive thing.
|
|
|
66 ;;
|
|
|
67 ;; There is at present no way to display what the faces look like in
|
|
|
68 ;; the menu itself.
|
|
|
69 ;;
|
|
|
70 ;; `list-faces-display' shows the faces in a different order than
|
|
|
71 ;; this menu, which could be confusing. I do /not/ sort the list
|
|
|
72 ;; alphabetically, because I like the default order: it puts the most
|
|
|
73 ;; basic, common fonts first.
|
|
|
74 ;;
|
|
|
75 ;; Please send me any other problems, comments or ideas.
|
|
|
76
|
|
|
77 ;;; Code:
|
|
|
78
|
|
|
79 (provide 'facemenu)
|
|
|
80
|
|
|
81 (require 'easymenu)
|
|
|
82
|
|
|
83 ;;; Provide some binding for startup:
|
|
|
84 ;;; XEmacs -- goto-line is a *much* better binding for M-g.
|
|
|
85 ;;;dont ###autoload (define-key global-map "\M-g" 'facemenu-keymap)
|
|
|
86
|
|
|
87 (defvar facemenu-key "\M-g"
|
|
|
88 "Prefix key to use for facemenu commands.")
|
|
|
89
|
|
|
90 (defvar facemenu-keybindings
|
|
|
91 '((default . "d")
|
|
|
92 (bold . "b")
|
|
|
93 (italic . "i")
|
|
|
94 (bold-italic . "l") ; {bold} intersect {italic} = {l}
|
|
|
95 (underline . "u"))
|
|
|
96 "Alist of interesting faces and keybindings.
|
|
|
97 Each element is itself a list: the car is the name of the face,
|
|
|
98 the next element is the key to use as a keyboard equivalent of the menu item;
|
|
|
99 the binding is made in facemenu-keymap.
|
|
|
100
|
|
|
101 The faces specifically mentioned in this list are put at the top of
|
|
|
102 the menu, in the order specified. All other faces which are defined,
|
|
|
103 except for those in `facemenu-unlisted-faces', are listed after them,
|
|
|
104 but get no keyboard equivalents.
|
|
|
105
|
|
|
106 If you change this variable after loading facemenu.el, you will need to call
|
|
|
107 `facemenu-update' to make it take effect.")
|
|
|
108
|
|
|
109 (defvar facemenu-new-faces-at-end t
|
|
|
110 "Where in the menu to insert newly-created faces.
|
|
|
111 This should be nil to put them at the top of the menu, or t to put them
|
|
|
112 just before \"Other\" at the end.")
|
|
|
113
|
|
|
114 (defvar facemenu-unlisted-faces
|
|
|
115 '(modeline region secondary-selection highlight scratch-face
|
|
|
116 gui-button-face isearch hyperlink
|
|
|
117 modeline modeline-buffer-id modeline-mousable modeline-mousable-minor-mode
|
|
|
118 pointer primary-selection secondary-selection list-mode-item-selected
|
|
|
119 text-cursor zmacs-region
|
|
|
120 left-margin right-margin)
|
|
|
121 "List of faces not to include in the Face menu.
|
|
|
122 You can set this list before loading facemenu.el, or add a face to it before
|
|
|
123 creating that face if you do not want it to be listed. If you change the
|
|
|
124 variable so as to eliminate faces that have already been added to the menu,
|
|
|
125 call `facemenu-update' to recalculate the menu contents.
|
|
|
126
|
|
|
127 If this variable is t, no faces will be added to the menu. This is useful for
|
|
|
128 temporarily turning off the feature that automatically adds faces to the menu
|
|
|
129 when they are created.")
|
|
|
130
|
|
|
131 (defvar facemenu-relevant-face-attributes
|
|
|
132 '(foreground background font underline highlight dim blinking reverse)
|
|
|
133 "List of face attributes that facemenu fiddles with.
|
|
|
134 This is only relevant for XEmacs.")
|
|
|
135
|
|
|
136 (easy-menu-define facemenu-face-menu ()
|
|
|
137 "Menu for faces"
|
|
|
138 `("Face"
|
|
|
139 ["Other..." facemenu-set-face t]))
|
|
|
140
|
|
|
141 (easy-menu-define facemenu-foreground-menu ()
|
|
|
142 "Menu for foreground colors"
|
|
|
143 `("Foreground Color"
|
|
|
144 ["Other..." facemenu-set-foreground t]))
|
|
|
145
|
|
|
146 (easy-menu-define facemenu-background-menu ()
|
|
|
147 "Menu for background colors"
|
|
|
148 `("Background Color"
|
|
|
149 ["Other..." facemenu-set-background t]))
|
|
|
150
|
|
|
151 (easy-menu-define facemenu-size-menu ()
|
|
|
152 "Menu for font sizes."
|
|
|
153 '("Size"
|
|
|
154 ["Default" facemenu-set-size-default t]
|
|
|
155 ["Bigger" facemenu-make-larger t]
|
|
|
156 ["Smaller" facemenu-make-smaller t]
|
|
|
157 ["Much Bigger" facemenu-make-much-larger t]
|
|
|
158 ["Much Smaller" facemenu-make-much-smaller t]))
|
|
|
159
|
|
|
160 (easy-menu-define facemenu-special-menu ()
|
|
|
161 "Menu for non-face text-properties."
|
|
|
162 '("Special"
|
|
|
163 ["Read-Only" facemenu-set-read-only t]
|
|
|
164 ["Invisible" facemenu-set-invisible t]
|
|
|
165 ["Intangible" facemenu-set-intangible t]
|
|
|
166 ["Remove Special" facemenu-remove-special t]))
|
|
|
167
|
|
|
168 (easy-menu-define facemenu-justification-menu ()
|
|
|
169 "Menu for text justification commands."
|
|
|
170 '("Justification"
|
|
|
171 ["Center" set-justification-center t]
|
|
|
172 ["Full" set-justification-full t]
|
|
|
173 ["Right" set-justification-right t]
|
|
|
174 ["Unfilled" set-justification-none t]))
|
|
|
175
|
|
|
176 (easy-menu-define facemenu-indentation-menu
|
|
|
177 ()
|
|
|
178 "Submenu for indentation commands."
|
|
|
179 '("Indentation"
|
|
|
180 ["Indent More" increase-left-margin t]
|
|
|
181 ["Indent Less" decrease-left-margin t]
|
|
|
182 ["Indent Right More" increase-right-margin t]
|
|
|
183 ["Indent Right Less" decrease-right-margin t]))
|
|
|
184
|
|
|
185 ;;;###autoload
|
|
|
186 (defvar facemenu-menu nil
|
|
|
187 "Facemenu top-level menu keymap.")
|
|
|
188
|
|
|
189 (defun facemenu-update-facemenu-menu ()
|
|
|
190 (easy-menu-define facemenu-menu ()
|
|
|
191 "Facemenu top-level menu"
|
|
|
192 (list "Text Properties"
|
|
|
193 facemenu-face-menu
|
|
|
194 facemenu-foreground-menu
|
|
|
195 facemenu-background-menu
|
|
|
196 facemenu-size-menu
|
|
|
197 facemenu-special-menu
|
|
|
198 "---"
|
|
|
199 facemenu-justification-menu
|
|
|
200 facemenu-indentation-menu
|
|
|
201 "---"
|
|
|
202 ["Remove Properties" facemenu-remove-props t]
|
|
|
203 ["List Properties" list-text-properties-at t]
|
|
|
204 ["Display Faces" list-faces-display t]
|
|
|
205 ["Display Colors" list-colors-display t])))
|
|
|
206
|
|
|
207 ;;;###autoload
|
|
|
208 (defvar facemenu-keymap
|
|
|
209 (let ((map (make-sparse-keymap "Set face")))
|
|
|
210 (define-key map ?o 'facemenu-set-face)
|
|
|
211 map)
|
|
|
212 "Keymap for face-changing commands.
|
|
|
213 `Facemenu-update' fills in the keymap according to the bindings
|
|
|
214 requested in `facemenu-keybindings'.")
|
|
|
215 (defalias 'facemenu-keymap facemenu-keymap)
|
|
|
216
|
|
|
217 ;;; Internal Variables
|
|
|
218
|
|
|
219 (defvar facemenu-color-alist nil
|
|
|
220 ;; Don't initialize here; that doesn't work if preloaded.
|
|
|
221 "Alist of colors, used for completion.
|
|
|
222 If null, `facemenu-read-color' will set it.")
|
|
|
223
|
|
|
224 (defun facemenu-update ()
|
|
|
225 "Add or update the \"Face\" menu in the menu bar.
|
|
|
226 You can call this to update things if you change any of the menu configuration
|
|
|
227 variables."
|
|
|
228 (interactive)
|
|
|
229
|
|
|
230 ;; Add each defined face to the menu.
|
|
|
231 (facemenu-iterate 'facemenu-add-new-face
|
|
|
232 (facemenu-complete-face-list facemenu-keybindings))
|
|
|
233 (facemenu-update-facemenu-menu)
|
|
|
234
|
|
|
235 ;; Global bindings:
|
|
|
236 (if (string-match "XEmacs" emacs-version)
|
|
|
237 (easy-menu-change '("Edit") (car facemenu-menu) (cdr facemenu-menu))
|
|
|
238 (define-key global-map [C-down-mouse-2] 'facemenu-menu))
|
|
|
239 (if facemenu-key (define-key global-map facemenu-key 'facemenu-keymap)))
|
|
|
240
|
|
|
241 (fset 'facemenu-region-active-p
|
|
|
242 (if (string-match "XEmacs" emacs-version)
|
|
|
243 'region-active-p
|
|
|
244 #'(lambda ()
|
|
|
245 mark-active)))
|
|
|
246
|
|
|
247 ;;;###autoload
|
|
|
248 (defun facemenu-set-face (face &optional start end)
|
|
|
249 "Add FACE to the region or next character typed.
|
|
|
250 It will be added to the top of the face list; any faces lower on the list that
|
|
|
251 will not show through at all will be removed.
|
|
|
252
|
|
|
253 Interactively, the face to be used is read with the minibuffer.
|
|
|
254
|
|
|
255 If the region is active and there is no prefix argument,
|
|
|
256 this command sets the region to the requested face.
|
|
|
257
|
|
|
258 Otherwise, this command specifies the face for the next character
|
|
|
259 inserted. Moving point or switching buffers before
|
|
|
260 typing a character to insert cancels the specification."
|
|
|
261 (interactive (list (read-face-name "Use face: ")))
|
|
70
|
262 (setq zmacs-region-stays t)
|
|
0
|
263 (barf-if-buffer-read-only)
|
|
|
264 (facemenu-add-new-face face)
|
|
70
|
265 (facemenu-update-facemenu-menu)
|
|
0
|
266 (if (and (facemenu-region-active-p)
|
|
|
267 (not current-prefix-arg))
|
|
|
268 (let ((start (or start (region-beginning)))
|
|
|
269 (end (or end (region-end))))
|
|
|
270 (facemenu-add-face face start end))
|
|
|
271 (facemenu-self-insert-face face)))
|
|
|
272
|
|
|
273 ;;;###autoload
|
|
|
274 (defun facemenu-set-foreground (color &optional start end)
|
|
|
275 "Set the foreground color of the region or next character typed.
|
|
|
276 The color is prompted for. A face named `fg:color' is used \(or created).
|
|
|
277 If the region is active, it will be set to the requested face. If
|
|
|
278 it is inactive \(even if mark-even-if-inactive is set) the next
|
|
|
279 character that is typed \(via `self-insert-command') will be set to
|
|
|
280 the selected face. Moving point or switching buffers before
|
|
|
281 typing a character cancels the request."
|
|
|
282 (interactive (list (facemenu-read-color "Foreground color: ")))
|
|
|
283 (setq zmacs-region-stays t)
|
|
|
284 (let ((face (intern (concat "fg:" color))))
|
|
|
285 (or (facemenu-get-face face)
|
|
|
286 (error "Unknown color: %s" color))
|
|
|
287 (facemenu-set-face face start end)))
|
|
|
288
|
|
|
289 ;;;###autoload
|
|
|
290 (defun facemenu-set-background (color &optional start end)
|
|
|
291 "Set the background color of the region or next character typed.
|
|
|
292 The color is prompted for. A face named `bg:color' is used \(or created).
|
|
|
293 If the region is active, it will be set to the requested face. If
|
|
|
294 it is inactive \(even if mark-even-if-inactive is set) the next
|
|
|
295 character that is typed \(via `self-insert-command') will be set to
|
|
|
296 the selected face. Moving point or switching buffers before
|
|
|
297 typing a character cancels the request."
|
|
|
298 (interactive (list (facemenu-read-color "Background color: ")))
|
|
|
299 (setq zmacs-region-stays t)
|
|
|
300 (let ((face (intern (concat "bg:" color))))
|
|
|
301 (or (facemenu-get-face face)
|
|
|
302 (error "Unknown color: %s" color))
|
|
|
303 (facemenu-set-face face start end)))
|
|
|
304
|
|
|
305 ;;;###autoload
|
|
70
|
306 (defun facemenu-set-face-from-menu (face)
|
|
0
|
307 "Set the face of the region or next character typed.
|
|
|
308 This function is designed to be called from a menu; the face to use
|
|
|
309 is the menu item's name.
|
|
|
310
|
|
|
311 If the region is active and there is no prefix argument,
|
|
|
312 this command sets the region to the requested face.
|
|
|
313
|
|
|
314 Otherwise, this command specifies the face for the next character
|
|
|
315 inserted. Moving point or switching buffers before
|
|
|
316 typing a character to insert cancels the specification."
|
|
70
|
317 (let ((start (if (and (facemenu-region-active-p)
|
|
|
318 (not current-prefix-arg))
|
|
|
319 (region-beginning)))
|
|
|
320 (end (if (and (facemenu-region-active-p)
|
|
|
321 (not current-prefix-arg))
|
|
|
322 (region-end))))
|
|
|
323 (barf-if-buffer-read-only)
|
|
|
324 (setq zmacs-region-stays t)
|
|
|
325 (facemenu-get-face face)
|
|
|
326 (if start
|
|
|
327 (facemenu-add-face face start end)
|
|
|
328 (facemenu-self-insert-face face))))
|
|
0
|
329
|
|
|
330 (defun facemenu-self-insert-face (face)
|
|
|
331 (setq self-insert-face (cond
|
|
|
332 ((null self-insert-face) face)
|
|
|
333 ((consp self-insert-face)
|
|
|
334 (facemenu-active-faces (cons face self-insert-face)))
|
|
|
335 (t
|
|
|
336 (facemenu-active-faces (list face self-insert-face))))
|
|
|
337 self-insert-face-command this-command))
|
|
|
338
|
|
|
339 (defun facemenu-face-strip-size (face)
|
|
|
340 "Create a symbol from the name of FACE devoid of size information,
|
|
|
341 i.e. remove all larger- and smaller- prefixes."
|
|
|
342 (let* ((face-symbol (face-name face))
|
|
|
343 (face-name (symbol-name face-symbol))
|
|
|
344 (old-name face-name)
|
|
|
345 new-name)
|
|
|
346 (while
|
|
|
347 (not (string-equal
|
|
|
348 old-name
|
|
|
349 (setq new-name (replace-in-string old-name "^larger-" ""))))
|
|
|
350 (setq old-name new-name))
|
|
|
351
|
|
|
352 (while
|
|
|
353 (not (string-equal
|
|
|
354 old-name
|
|
|
355 (setq new-name (replace-in-string old-name "^smaller-" ""))))
|
|
|
356 (setq old-name new-name))
|
|
|
357
|
|
|
358 (if (string-equal new-name face-name)
|
|
|
359 face-symbol
|
|
|
360 (intern new-name))))
|
|
|
361
|
|
|
362 (defun facemenu-face-default-size (face)
|
|
|
363 (cond ((null face) nil)
|
|
|
364 ((consp face) (mapcar 'facemenu-face-strip-size face))
|
|
|
365 (t (facemenu-face-strip-size face))))
|
|
|
366
|
|
|
367 ;;;###autoload
|
|
|
368 (defun facemenu-set-size-default (start end)
|
|
|
369 (interactive "_r")
|
|
|
370 (put-text-property start end 'size nil)
|
|
|
371 (alter-text-property start end 'face 'facemenu-face-default-size))
|
|
|
372
|
|
|
373 (defun facemenu-ensure-size-property (start end)
|
|
|
374 "Ensure that the text between START and END has a 'size text property.
|
|
|
375 If it is not present, it is set to 0."
|
|
|
376 (let ((start start)
|
|
|
377 pos bound)
|
|
|
378 (while (setq pos (text-property-any start end 'size nil))
|
|
|
379 (setq bound (or (text-property-not-all pos end 'size nil) end))
|
|
|
380 (put-text-property pos bound 'size 0))))
|
|
|
381
|
|
|
382 (defun facemenu-sized-face (face size)
|
|
|
383 "Make a face FACE larger or smaller according to SIZE.
|
|
|
384 If SIZE is positive, it calls `make-face-larger' SIZE times,
|
|
|
385 else it calls `make-face-smaller' -SIZE times."
|
|
|
386 (if (zerop size)
|
|
|
387 face
|
|
|
388 (let ((name (symbol-name face))
|
|
|
389 (measure size)
|
|
|
390 (change-face 'make-face-larger))
|
|
|
391
|
|
|
392 (if (> measure 0)
|
|
|
393 (setq prefix "larger-")
|
|
|
394 (setq prefix "smaller-")
|
|
|
395 (setq measure (- measure))
|
|
|
396 (setq size (- size))
|
|
|
397 (setq change-face 'make-face-smaller))
|
|
|
398
|
|
|
399 (while (not (zerop measure))
|
|
|
400 (setq name (concat prefix name))
|
|
|
401 (setq measure (1- measure)))
|
|
|
402
|
|
|
403 (let ((symbol (intern name)))
|
|
|
404 (or (find-face symbol)
|
|
|
405 (let ((face (copy-face face symbol)))
|
|
|
406 (while (not (zerop size))
|
|
|
407 (funcall change-face face)
|
|
|
408 (setq size (1- size)))
|
|
|
409 face))))))
|
|
|
410
|
|
|
411 (defun facemenu-adjust-face-sizes (face)
|
|
|
412 (cond
|
|
|
413 ((null face) (facemenu-sized-face 'default size))
|
|
|
414 ((consp face) (mapcar
|
|
|
415 #'(lambda (face)
|
|
|
416 (facemenu-sized-face (facemenu-face-strip-size face)
|
|
|
417 size))
|
|
|
418 face))
|
|
70
|
419 (t (facemenu-sized-face face size))))
|
|
0
|
420
|
|
|
421 (defun facemenu-adjust-size (from to)
|
|
|
422 "Adjust the size of the text between FROM and TO according
|
|
|
423 to the values of the 'size property in that region."
|
|
|
424 (let ((pos from)
|
|
|
425 bound size)
|
|
|
426 (while (< pos to)
|
|
|
427 (setq size (get-text-property pos 'size))
|
|
|
428 (setq bound (or (text-property-not-all pos to 'size size) to))
|
|
|
429 (alter-text-property pos bound 'face 'facemenu-adjust-face-sizes)
|
|
|
430 (setq pos bound))))
|
|
|
431
|
|
|
432 (defun facemenu-change-size (from to f)
|
|
|
433 (facemenu-ensure-size-property from to)
|
|
|
434 (alter-text-property from to 'size f)
|
|
|
435 (facemenu-adjust-size from to))
|
|
|
436
|
|
|
437 ;;;###autoload
|
|
|
438 (defun facemenu-make-larger (from to)
|
|
|
439 (interactive "_r")
|
|
|
440 (facemenu-change-size from to '1+))
|
|
|
441
|
|
|
442 ;;;###autoload
|
|
|
443 (defun facemenu-make-smaller (from to)
|
|
|
444 (interactive "_r")
|
|
|
445 (facemenu-change-size from to '1-))
|
|
|
446
|
|
|
447 ;;;###autoload
|
|
|
448 (defun facemenu-make-much-larger (from to)
|
|
|
449 (interactive "_r")
|
|
|
450 (facemenu-change-size from to #'(lambda (s) (+ 5 s))))
|
|
|
451
|
|
|
452 ;;;###autoload
|
|
|
453 (defun facemenu-make-much-smaller (from to)
|
|
|
454 (interactive "_r")
|
|
|
455 (facemenu-change-size from to #'(lambda (s) (- s 5))))
|
|
|
456
|
|
|
457 ;;;###autoload
|
|
|
458 (defun facemenu-set-invisible (start end)
|
|
|
459 "Make the region invisible.
|
|
|
460 This sets the `invisible' text property; it can be undone with
|
|
|
461 `facemenu-remove-special'."
|
|
70
|
462 (interactive "r")
|
|
0
|
463 (put-text-property start end 'invisible t))
|
|
|
464
|
|
|
465 ;;;###autoload
|
|
|
466 (defun facemenu-set-intangible (start end)
|
|
|
467 "Make the region intangible: disallow moving into it.
|
|
|
468 This sets the `intangible' text property; it can be undone with
|
|
|
469 `facemenu-remove-special'."
|
|
70
|
470 (interactive "r")
|
|
0
|
471 (put-text-property start end 'intangible t))
|
|
|
472
|
|
|
473 ;;;###autoload
|
|
|
474 (defun facemenu-set-read-only (start end)
|
|
|
475 "Make the region unmodifiable.
|
|
|
476 This sets the `read-only' text property; it can be undone with
|
|
|
477 `facemenu-remove-special'."
|
|
70
|
478 (interactive "r")
|
|
0
|
479 (put-text-property start end 'read-only t))
|
|
|
480
|
|
|
481 ;;;###autoload
|
|
|
482 (defun facemenu-remove-props (start end)
|
|
|
483 "Remove all text properties that facemenu added to region."
|
|
|
484 (interactive "*_r") ; error if buffer is read-only despite the next line.
|
|
|
485 (let ((inhibit-read-only t))
|
|
|
486 (remove-text-properties
|
|
|
487 start end '(face nil invisible nil intangible nil
|
|
|
488 read-only nil category nil size nil))))
|
|
|
489
|
|
|
490 ;;;###autoload
|
|
|
491 (defun facemenu-remove-special (start end)
|
|
|
492 "Remove all the \"special\" text properties from the region.
|
|
|
493 These special properties include `invisible', `intangible' and `read-only'."
|
|
|
494 (interactive "*_r") ; error if buffer is read-only despite the next line.
|
|
|
495 (let ((inhibit-read-only t))
|
|
|
496 (remove-text-properties
|
|
|
497 start end '(invisible nil intangible nil read-only nil))))
|
|
|
498
|
|
|
499 ;;;###autoload
|
|
|
500 (defun list-text-properties-at (p)
|
|
|
501 "Pop up a buffer listing text-properties at LOCATION."
|
|
|
502 (interactive "d")
|
|
70
|
503 (let ((props (text-properties-at p)))
|
|
0
|
504 (if (null props)
|
|
|
505 (message "None")
|
|
70
|
506 (with-output-to-temp-buffer "*Text Properties*"
|
|
|
507 (princ (format "Text properties at %d:\n\n" p))
|
|
|
508 (while props
|
|
|
509 (princ (format "%-20s %S\n"
|
|
|
510 (car props) (car (cdr props))))
|
|
|
511 (setq props (cdr (cdr props))))))))
|
|
0
|
512
|
|
|
513 ;;;###autoload
|
|
|
514 (defun facemenu-read-color (&optional prompt)
|
|
|
515 "Read a color using the minibuffer."
|
|
|
516 (if (string-match "XEmacs" emacs-version)
|
|
|
517 (read-color prompt)
|
|
|
518 (let ((col (completing-read
|
|
|
519 (or prompt "Color: ")
|
|
|
520 (or facemenu-color-alist
|
|
|
521 (if (or (eq window-system 'x) (eq window-system 'win32))
|
|
|
522 (mapcar 'list (x-defined-colors))))
|
|
|
523 nil t)))
|
|
|
524 (if (equal "" col)
|
|
|
525 nil
|
|
|
526 col))))
|
|
|
527
|
|
|
528 (defun facemenu-canonicalize-color (c)
|
|
|
529 (downcase (replace-in-string c " " "")))
|
|
|
530
|
|
|
531 (defun facemenu-unique (list)
|
|
|
532 "Uniquify LIST, deleting elements using `delete'.
|
|
|
533 Return the list with subsequent duplicate items removed by side effects."
|
|
|
534 (let ((list list))
|
|
|
535 (while list
|
|
|
536 (setq list (setcdr list (delete (car list) (cdr list))))))
|
|
|
537 list)
|
|
|
538
|
|
|
539 ;;;###autoload
|
|
|
540 (defun list-colors-display (&optional list)
|
|
|
541 "Display names of defined colors, and show what they look like.
|
|
|
542 If the optional argument LIST is non-nil, it should be a list of
|
|
|
543 colors to display. Otherwise, this command computes a list
|
|
|
544 of colors that the current display can handle."
|
|
|
545 (interactive)
|
|
|
546 (if (string-match "XEmacs" emacs-version)
|
|
|
547 (setq list
|
|
|
548 (facemenu-unique
|
|
|
549 (mapcar 'facemenu-canonicalize-color
|
|
|
550 (mapcar 'car (read-color-completion-table)))))
|
|
|
551 (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32)))
|
|
|
552 (progn
|
|
|
553 (setq list (x-defined-colors))
|
|
|
554 ;; Delete duplicate colors.
|
|
|
555 (let ((l list))
|
|
|
556 (while (cdr l)
|
|
|
557 (if (facemenu-color-equal (car l) (car (cdr l)))
|
|
|
558 (setcdr l (cdr (cdr l)))
|
|
|
559 (setq l (cdr l))))))))
|
|
|
560 (with-output-to-temp-buffer "*Colors*"
|
|
|
561 (save-excursion
|
|
|
562 (set-buffer standard-output)
|
|
|
563 (let ((facemenu-unlisted-faces t)
|
|
|
564 s)
|
|
|
565 (while list
|
|
|
566 (if (not (string-match "[0-9]" (car list)))
|
|
|
567 (progn
|
|
|
568 (setq s (point))
|
|
|
569 (insert (car list))
|
|
|
570 (indent-to 20)
|
|
|
571 (put-text-property s (point) 'face
|
|
|
572 (facemenu-get-face
|
|
|
573 (intern (concat "bg:" (car list)))))
|
|
|
574 (setq s (point))
|
|
|
575 (insert " " (car list) "\n")
|
|
|
576 (put-text-property s (point) 'face
|
|
|
577 (facemenu-get-face
|
|
|
578 (intern (concat "fg:" (car list)))))))
|
|
|
579 (setq list (cdr list)))))))
|
|
|
580
|
|
|
581 (fset 'facemenu-color-values
|
|
|
582 (if (fboundp 'x-color-values)
|
|
|
583 'x-color-values
|
|
|
584 #'(lambda (color)
|
|
|
585 (color-instance-rgb-components
|
|
|
586 (make-color-instance color)))))
|
|
|
587
|
|
|
588 (defun facemenu-color-equal (a b)
|
|
|
589 "Return t if colors A and B are the same color.
|
|
|
590 A and B should be strings naming colors.
|
|
|
591 This function queries the window-system server to find out what the
|
|
|
592 color names mean. It returns nil if the colors differ or if it can't
|
|
|
593 determine the correct answer."
|
|
|
594 (cond ((equal a b) t)
|
|
|
595 ((and (equal (facemenu-color-values a)
|
|
|
596 (facemenu-color-values b))))))
|
|
|
597
|
|
70
|
598 (defun facemenu-add-face (face start end)
|
|
0
|
599 "Add FACE to text between START and END.
|
|
|
600 For each section of that region that has a different face property, FACE will
|
|
|
601 be consed onto it, and other faces that are completely hidden by that will be
|
|
|
602 removed from the list.
|
|
|
603
|
|
|
604 As a special case, if FACE is `default', then the region is left with NO face
|
|
|
605 text property. Otherwise, selecting the default face would not have any
|
|
|
606 effect."
|
|
|
607 (interactive "*_xFace:\nr")
|
|
70
|
608 (if (eq face 'default)
|
|
|
609 (remove-text-properties start end '(face default))
|
|
|
610 (let ((part-start start) part-end)
|
|
|
611 (while (not (= part-start end))
|
|
|
612 (setq part-end (next-single-property-change part-start 'face nil end))
|
|
|
613 (let* ((prev (get-text-property part-start 'face))
|
|
|
614 (size (get-text-property part-start 'size))
|
|
|
615 (face (if size (facemenu-sized-face face size) face)))
|
|
|
616 (put-text-property part-start part-end 'face
|
|
|
617 (if (null prev)
|
|
|
618 face
|
|
|
619 (facemenu-active-faces
|
|
|
620 (cons face
|
|
|
621 (if (listp prev) prev (list prev)))))))
|
|
|
622 (setq part-start part-end)))))
|
|
0
|
623
|
|
|
624 (defun facemenu-face-attributes (face)
|
|
|
625 "Create a vector of the relevant face attributes of face FACE."
|
|
|
626 (if (string-match "XEmacs" emacs-version)
|
|
|
627 (apply 'vector (mapcar #'(lambda (prop)
|
|
|
628 (face-property-instance face prop))
|
|
|
629 facemenu-relevant-face-attributes))
|
|
|
630 (internal-get-face (car face-list))))
|
|
|
631
|
|
|
632 (defun facemenu-active-faces (face-list)
|
|
|
633 "Return from FACE-LIST those faces that would be used for display.
|
|
|
634 This means each face attribute is not specified in a face earlier in FACE-LIST
|
|
|
635 and such a face is therefore active when used to display text."
|
|
|
636 (let* ((mask-atts (copy-sequence (facemenu-face-attributes (car face-list))))
|
|
|
637 (default-atts (facemenu-face-attributes 'default))
|
|
|
638 (active-list (list (car face-list)))
|
|
|
639 (face-list (cdr face-list))
|
|
|
640 (mask-len (length mask-atts)))
|
|
|
641 (while face-list
|
|
|
642 (if (let ((face-atts (facemenu-face-attributes (car face-list)))
|
|
|
643 (i mask-len)
|
|
|
644 (useful nil))
|
|
|
645 (while (>= (setq i (1- i)) 0)
|
|
|
646 (if (and (aref face-atts i)
|
|
|
647 (or (not (aref mask-atts i))
|
|
|
648 (eq (aref mask-atts i) (aref default-atts i)))
|
|
|
649 (not (eq (aref face-atts i) (aref default-atts i))))
|
|
|
650 (aset mask-atts i (setq useful t))))
|
|
|
651 useful)
|
|
|
652 (setq active-list (cons (car face-list) active-list)))
|
|
|
653 (setq face-list (cdr face-list)))
|
|
|
654 (nreverse active-list)))
|
|
|
655
|
|
|
656 (fset 'facemenu-find-face
|
|
|
657 (if (string-match "XEmacs" emacs-version)
|
|
|
658 'find-face
|
|
|
659 'internal-find-face))
|
|
|
660
|
|
|
661 (fset 'facemenu-color-defined-p
|
|
|
662 (if (string-match "XEmacs" emacs-version)
|
|
|
663 #'(lambda (c)
|
|
|
664 (color-instance-p (make-color-instance c nil t)))
|
|
|
665 #'(lambda (c)
|
|
|
666 (and (or (eq window-system 'x) (eq window-system 'win32))
|
|
|
667 (x-color-defined-p color)))))
|
|
|
668
|
|
|
669 (defun facemenu-get-face (symbol)
|
|
|
670 "Make sure FACE exists.
|
|
|
671 If not, it is created. If it is created and is of the form `fg:color', then
|
|
|
672 set the foreground to that color. If of the form `bg:color', set the
|
|
|
673 background. In any case, add it to the appropriate menu. Returns the face,
|
|
|
674 or nil if given a bad color."
|
|
|
675 (if (or (facemenu-find-face symbol)
|
|
|
676 (let* ((face (make-face symbol))
|
|
|
677 (name (symbol-name symbol))
|
|
|
678 (color-name (substring name 3))
|
|
|
679 (color (if (string-match "XEmacs" emacs-version)
|
|
|
680 (make-color-specifier color-name)
|
|
|
681 color-name)))
|
|
|
682 (facemenu-add-new-face symbol)
|
|
|
683 (cond ((string-match "^fg:" name)
|
|
|
684 (set-face-foreground face color)
|
|
|
685 (facemenu-color-defined-p color-name))
|
|
|
686 ((string-match "^bg:" name)
|
|
|
687 (set-face-background face color)
|
|
|
688 (facemenu-color-defined-p color-name))
|
|
|
689 (t))))
|
|
|
690 symbol))
|
|
|
691
|
|
|
692 (defun facemenu-menu-has-face (menu face-name)
|
|
|
693 "Check if menu MENU has an entry for face named by string FACE-NAME.
|
|
|
694 Returns entry if successful."
|
|
|
695 (facemenu-iterate
|
|
|
696 #'(lambda (m)
|
|
|
697 (and (vectorp m)
|
|
|
698 (string-equal face-name (aref m 0))
|
|
|
699 m))
|
|
|
700 (cdr menu)))
|
|
|
701
|
|
|
702 (defun facemenu-insert-menu-entry (menu before-entry name function)
|
|
|
703 "Insert menu item with name NAME and associated function FUNCTION
|
|
|
704 into menu MENU before entry BEFORE-ENTRY."
|
|
|
705 (while (not (eq (cadr menu) before-entry))
|
|
|
706 (setq menu (cdr menu)))
|
|
|
707 (setcdr menu (cons (vector name function t) (cdr menu))))
|
|
|
708
|
|
|
709 (defun facemenu-add-new-face (face)
|
|
|
710 "Add a FACE to the appropriate Face menu.
|
|
|
711 Automatically called when a new face is created."
|
|
|
712 (let* ((name (symbol-name face))
|
|
|
713 (menu (cond ((string-match "^fg:" name)
|
|
|
714 (setq name (substring name 3))
|
|
|
715 'facemenu-foreground-menu)
|
|
|
716 ((string-match "^bg:" name)
|
|
|
717 (setq name (substring name 3))
|
|
|
718 'facemenu-background-menu)
|
|
|
719 (t 'facemenu-face-menu)))
|
|
|
720 (menu-value (symbol-value menu))
|
|
|
721 (key (cdr (assoc face facemenu-keybindings))))
|
|
|
722 (cond ((eq t facemenu-unlisted-faces))
|
|
|
723 ((string-match "^larger-" name))
|
|
|
724 ((string-match "^smaller-" name))
|
|
|
725 ((memq face facemenu-unlisted-faces))
|
|
|
726 (key ; has a keyboard equivalent. These go at the front.
|
|
|
727 (let ((function (intern (concat "facemenu-set-" name))))
|
|
|
728 (fset function
|
|
|
729 (` (lambda ()
|
|
|
730 (interactive "_")
|
|
|
731 (facemenu-set-face (quote (, face))))))
|
|
|
732 (define-key 'facemenu-keymap key function)
|
|
|
733 (if (not (facemenu-menu-has-face menu-value name))
|
|
|
734 (set menu
|
|
|
735 (cons (car menu-value)
|
|
|
736 (cons (vector name function t)
|
|
|
737 (cdr menu-value)))))))
|
|
|
738 ((facemenu-menu-has-face menu-value name))
|
|
|
739 (t ; No keyboard equivalent. Figure out where to put it:
|
|
|
740 (let ((before-entry
|
|
|
741 (or (and facemenu-new-faces-at-end
|
|
|
742 (facemenu-menu-has-face menu-value "Other..."))
|
|
|
743 (cadr menu-value))))
|
|
|
744 (facemenu-insert-menu-entry
|
|
|
745 menu-value before-entry name
|
|
|
746 (` (facemenu-set-face (quote (, face)))))))))
|
|
|
747 nil) ; Return nil for facemenu-iterate
|
|
|
748
|
|
|
749 (defun facemenu-complete-face-list (&optional oldlist)
|
|
|
750 "Return list of all faces that look different.
|
|
|
751 Starts with given ALIST of faces, and adds elements only if they display
|
|
|
752 differently from any face already on the list.
|
|
|
753 The faces on ALIST will end up at the end of the returned list, in reverse
|
|
|
754 order."
|
|
|
755 (let ((list (nreverse (mapcar 'car oldlist))))
|
|
|
756 (facemenu-iterate
|
|
|
757 (lambda (new-face)
|
|
|
758 (if (not (memq new-face list))
|
|
|
759 (setq list (cons new-face list)))
|
|
|
760 nil)
|
|
|
761 (nreverse (face-list)))
|
|
|
762 list))
|
|
|
763
|
|
|
764 (defun facemenu-iterate (func iterate-list)
|
|
|
765 "Apply FUNC to each element of LIST until one returns non-nil.
|
|
|
766 Returns the non-nil value it found, or nil if all were nil."
|
|
|
767 (while (and iterate-list (not (funcall func (car iterate-list))))
|
|
|
768 (setq iterate-list (cdr iterate-list)))
|
|
|
769 (car iterate-list))
|
|
|
770
|
|
|
771 (facemenu-update)
|
|
|
772
|
|
|
773 ;;; facemenu.el ends here
|
