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