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