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