|
0
|
1 ;;; edit-faces.el -- interactive face editing mode
|
|
|
2
|
|
|
3 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
|
|
|
4 ;; Copyright (C) 1996 Ben Wing.
|
|
|
5 ;;
|
|
|
6 ;; This file is part of XEmacs.
|
|
|
7 ;;
|
|
|
8 ;; XEmacs is free software; you can redistribute it and/or modify
|
|
|
9 ;; it under the terms of the GNU General Public License as published by
|
|
|
10 ;; the Free Software Foundation; either version 2 of the License, or
|
|
|
11 ;; (at your option) any later version.
|
|
|
12 ;;
|
|
|
13 ;; XEmacs is distributed in the hope that it will be useful,
|
|
|
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
16 ;; GNU General Public License for more details.
|
|
|
17 ;;
|
|
|
18 ;; You should have received a copy of the GNU General Public License
|
|
|
19 ;; along with XEmacs; if not, write to the Free Software
|
|
|
20 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
21
|
|
|
22 ;;; Synched up with: Not in FSF.
|
|
|
23 ;;; #### FSF has facemenu.el. Should merge with.
|
|
|
24
|
|
|
25 ;;; Original author: Stig <stig@hackvan.com>.
|
|
|
26 ;;; Significantly fixed up: Ben Wing <wing@666.com>.
|
|
|
27
|
|
|
28 (defvar edit-faces-menu
|
|
|
29 '("Edit-Faces"
|
|
|
30 ["Copy other face..." ef-copy-other-face t]
|
|
|
31 ["Copy this face..." ef-copy-this-face t]
|
|
|
32 ["Make smaller" ef-smaller t]
|
|
|
33 ["Make larger" ef-larger t]
|
|
|
34 ["Toggle bold" ef-bold t]
|
|
|
35 ["Toggle italic" ef-italic t]
|
|
|
36 ["Toggle underline" ef-underline t]
|
|
|
37 ["Query true font" ef-truefont t]
|
|
|
38 ["Set font" ef-font t]
|
|
|
39 ["Set foreground" ef-foreground t]
|
|
|
40 ["Set background" ef-background t]
|
|
|
41 ["Set doc string" ef-doc-string t]
|
|
|
42 ["Quit" ef-quit t]
|
|
|
43 ))
|
|
|
44
|
|
|
45 (or (find-face 'underline)
|
|
|
46 (progn (make-face 'underline)
|
|
|
47 (set-face-underline-p 'underline t)))
|
|
|
48
|
|
|
49 (define-derived-mode edit-faces-mode list-mode
|
|
|
50 "Edit-Faces"
|
|
|
51 "Major mode for `edit-faces' buffers.
|
|
|
52
|
|
|
53 Editing commands:
|
|
|
54
|
|
|
55 \\{edit-faces-mode-map}"
|
|
|
56 (setq truncate-lines t)
|
|
|
57 ;; auto-show-mode is too confusing in this mode
|
|
|
58 (setq auto-show-mode nil)
|
|
|
59 (setq mode-popup-menu edit-faces-menu)
|
|
2
|
60 (if (featurep 'menubar)
|
|
|
61 (if current-menubar
|
|
|
62 (progn
|
|
|
63 (set (make-local-variable 'current-menubar)
|
|
|
64 (copy-sequence current-menubar))
|
|
|
65 (add-submenu nil edit-faces-menu)))))
|
|
0
|
66
|
|
|
67 (let ((map edit-faces-mode-map))
|
|
|
68 (define-key map "<" 'ef-smaller)
|
|
|
69 (define-key map ">" 'ef-larger)
|
|
|
70 (define-key map "c" 'ef-copy-other-face)
|
|
|
71 (define-key map "C" 'ef-copy-this-face)
|
|
|
72 (define-key map "s" 'ef-smaller)
|
|
|
73 (define-key map "l" 'ef-larger)
|
|
|
74 (define-key map "b" 'ef-bold)
|
|
|
75 (define-key map "i" 'ef-italic)
|
|
|
76 (define-key map "e" 'ef-font)
|
|
|
77 (define-key map "f" 'ef-font)
|
|
|
78 (define-key map "u" 'ef-underline)
|
|
|
79 (define-key map "t" 'ef-truefont)
|
|
|
80 (define-key map "F" 'ef-foreground)
|
|
|
81 (define-key map "B" 'ef-background)
|
|
|
82 (define-key map "D" 'ef-doc-string)
|
|
|
83 (define-key map "d" 'ef-delete)
|
|
|
84 (define-key map "n" 'ef-next)
|
|
|
85 (define-key map "p" 'ef-prev)
|
|
|
86 (define-key map " " 'ef-next)
|
|
|
87 (define-key map "\C-?" 'ef-prev)
|
|
|
88 (define-key map "g" 'edit-faces) ; refresh display
|
|
|
89 (define-key map "q" 'ef-quit)
|
|
|
90 (define-key map "\C-c\C-c" 'bury-buffer))
|
|
|
91
|
|
|
92 ;;;###autoload
|
|
|
93 (defun edit-faces ()
|
|
|
94 "Alter face characteristics by editing a list of defined faces.
|
|
|
95 Pops up a buffer containing a list of defined faces.
|
|
|
96
|
|
|
97 Editing commands:
|
|
|
98
|
|
|
99 \\{edit-faces-mode-map}"
|
|
|
100 (interactive)
|
|
|
101 (pop-to-buffer (get-buffer-create "*Edit Faces*"))
|
|
|
102 (reset-buffer (current-buffer))
|
|
|
103
|
|
|
104 ;; face-list returns faces in a random order so we sort
|
|
|
105 ;; alphabetically by the name in order to insert some logic into
|
|
|
106 ;; the ordering.
|
|
|
107 (let ((flist (sort (face-list)
|
|
|
108 (function
|
|
|
109 (lambda (x y)
|
|
|
110 (string-lessp (symbol-name x) (symbol-name y))))))
|
|
|
111 face)
|
|
|
112 (ef-update-face-description t) ; insert header line
|
|
|
113 (while (setq face (car flist))
|
|
|
114 (ef-update-face-description face)
|
|
|
115 (setq flist (cdr flist))
|
|
|
116 ))
|
|
|
117 (edit-faces-mode)
|
|
|
118 )
|
|
|
119
|
|
|
120 (defun ef-foreground-callback (event extent user-data)
|
|
|
121 (ef-foreground (ef-face-arg (extent-start-position extent)
|
|
|
122 (extent-object extent))))
|
|
|
123
|
|
|
124 (defun ef-background-callback (event extent user-data)
|
|
|
125 (ef-background (ef-face-arg (extent-start-position extent)
|
|
|
126 (extent-object extent))))
|
|
|
127
|
|
|
128 (defun ef-font-callback (event extent user-data)
|
|
|
129 (ef-font (ef-face-arg (extent-start-position extent)
|
|
|
130 (extent-object extent))))
|
|
|
131
|
|
|
132 (defun ef-doc-string-callback (event extent user-data)
|
|
|
133 (ef-doc-string (ef-face-arg (extent-start-position extent)
|
|
|
134 (extent-object extent))))
|
|
|
135
|
|
|
136 (defun ef-update-face-description (face &optional replace)
|
|
|
137 "Given a face, inserts a description of that face into the current buffer.
|
|
|
138 Inserts a descriptive header if passed `t'."
|
|
|
139 (let ((face-name-fmt "%-25s")
|
|
|
140 (foreground-fmt "%-15s")
|
|
|
141 (background-fmt "%-15s")
|
|
|
142 (font-fmt "%s")
|
|
|
143 (buffer-read-only nil)
|
|
|
144 fg bg font)
|
|
|
145 (if (eq face t)
|
|
|
146 (insert-face (format (concat face-name-fmt " " foreground-fmt " "
|
|
|
147 background-fmt " " font-fmt "\n")
|
|
|
148 "Face" "Foreground" "Background" "Font Spec")
|
|
|
149 'underline)
|
|
|
150 (or replace (setq replace face))
|
|
|
151 (goto-char (point-min))
|
|
|
152 (if (re-search-forward (concat "^" (symbol-name replace) " ") nil 0)
|
|
|
153 (progn
|
|
|
154 (beginning-of-line)
|
|
|
155 (delete-region (point) (progn (forward-line 2) (point)))
|
|
|
156 ))
|
|
|
157 (setq fg (face-foreground-instance face)
|
|
|
158 bg (face-background-instance face)
|
|
|
159 font (face-font-instance face))
|
|
|
160 (let ((st (point))
|
|
|
161 (fn #'(lambda (str callback)
|
|
|
162 (let ((st1 (point)))
|
|
|
163 (insert str)
|
|
|
164 (add-list-mode-item st1 (point) nil callback)))))
|
|
|
165 (funcall fn (format face-name-fmt (symbol-name face)) nil)
|
|
|
166 (insert " ")
|
|
|
167 (funcall fn (format foreground-fmt (color-instance-name fg))
|
|
|
168 'ef-foreground-callback)
|
|
|
169 (insert " ")
|
|
|
170 (funcall fn (format background-fmt (color-instance-name bg))
|
|
|
171 'ef-background-callback)
|
|
|
172 (insert " ")
|
|
|
173 (funcall fn (format font-fmt (font-instance-name font))
|
|
|
174 'ef-font-callback)
|
|
|
175 (insert "\n (")
|
|
|
176 (funcall fn (or (face-doc-string face) "")
|
|
|
177 'ef-doc-string-callback)
|
|
|
178 (insert ")")
|
|
|
179 (add-nonduplicable-text-properties st (point)
|
|
|
180 `(face ,face eface ,face
|
|
|
181 start-open t))
|
|
|
182 (insert "\n")
|
|
|
183 )
|
|
|
184 (and replace (forward-line -1))
|
|
|
185 ))
|
|
|
186 )
|
|
|
187
|
|
|
188 (defun ef-face-arg (&optional pos buffer)
|
|
|
189 (if (and (not pos) (not buffer))
|
|
|
190 (and current-mouse-event
|
|
|
191 (mouse-event-p current-mouse-event)
|
|
|
192 (mouse-set-point current-mouse-event)))
|
|
|
193 (or buffer (setq buffer (current-buffer)))
|
|
|
194 (or pos (setq pos (point buffer)))
|
|
|
195 (let ((face (or (get-char-property pos 'eface buffer)
|
|
|
196 (and (> pos (point-min buffer))
|
|
|
197 (get-char-property (1- pos) 'eface buffer)))))
|
|
|
198 (or face (error "There is no face to edit on this line."))
|
|
|
199 face))
|
|
|
200
|
|
|
201 (defun ef-delete (arg)
|
|
|
202 "Delete the face on the current line from the *Edit Faces* buffer.
|
|
|
203 The face is not altered. The buffer can be regenerated again with
|
|
|
204 M-x edit-faces."
|
|
|
205 (interactive "p")
|
|
|
206 (and current-mouse-event (mouse-event-p current-mouse-event)
|
|
|
207 (mouse-set-point current-mouse-event))
|
|
|
208 (let ( ;; is this worth the bother? (fwd (> arg 0))
|
|
|
209 (count (abs arg))
|
|
|
210 (buffer-read-only nil)
|
|
|
211 ex)
|
|
|
212 (while (not (zerop (prog1 count (setq count (1- count)))))
|
|
|
213 (setq ex (text-property-bounds (point) 'eface nil 'at))
|
|
|
214 (or ex (error "There is no face to delete on this line."))
|
|
|
215 (delete-region (car ex) (cdr ex))
|
|
|
216 (delete-blank-lines))))
|
|
|
217
|
|
|
218 (defun ef-next (arg)
|
|
|
219 "Move forward ARG entries in the face table."
|
|
|
220 (interactive "p")
|
|
|
221 (let ((bounds (next-text-property-bounds arg (point) 'eface)))
|
|
|
222 (if bounds (goto-char (car bounds))
|
|
|
223 (goto-char (if (> arg 0) (point-max) (point-min))))))
|
|
|
224
|
|
|
225 (defun ef-prev (arg)
|
|
|
226 "Move forward ARG entries in the face table."
|
|
|
227 (interactive "p")
|
|
|
228 (ef-next (- arg)))
|
|
|
229
|
|
|
230 (defun ef-smaller (face)
|
|
|
231 (interactive (list (ef-face-arg)))
|
|
|
232 (make-face-smaller face)
|
|
|
233 (ef-update-face-description face))
|
|
|
234
|
|
|
235 (defun ef-larger (face)
|
|
|
236 (interactive (list (ef-face-arg)))
|
|
|
237 (make-face-larger face)
|
|
|
238 (ef-update-face-description face))
|
|
|
239
|
|
|
240 (defun ef-face-font-indirect (face)
|
|
|
241 (let ((font (face-font-instance face)))
|
|
|
242 (or font (face-font-instance 'default))))
|
|
|
243
|
|
|
244 (defun ef-face-bold-p (face)
|
|
|
245 (let ((font (ef-face-font-indirect face)))
|
|
|
246 (not (not (string-match "-bold-" (font-instance-name font))))))
|
|
|
247
|
|
|
248 (defun ef-face-italic-p (face)
|
|
|
249 (let ((font (ef-face-font-indirect face)))
|
|
|
250 (not (not (string-match "-[io]-" (font-instance-name font))))))
|
|
|
251
|
|
|
252 (defun ef-bold (face)
|
|
|
253 (interactive (list (ef-face-arg)))
|
|
|
254 (if (ef-face-bold-p face)
|
|
|
255 (make-face-unbold face)
|
|
|
256 (make-face-bold face))
|
|
|
257 (ef-update-face-description face))
|
|
|
258
|
|
|
259 (defun ef-italic (face)
|
|
|
260 (interactive (list (ef-face-arg)))
|
|
|
261 (if (ef-face-italic-p face)
|
|
|
262 (make-face-unitalic face)
|
|
|
263 (make-face-italic face))
|
|
|
264 (ef-update-face-description face))
|
|
|
265
|
|
|
266 (defun ef-underline (face)
|
|
|
267 (interactive (list (ef-face-arg)))
|
|
|
268 (set-face-underline-p face (not (face-underline-p face)))
|
|
|
269 (ef-update-face-description face))
|
|
|
270
|
|
|
271 (defun ef-truefont (face)
|
|
|
272 (interactive (list (ef-face-arg)))
|
|
|
273 (let ((font (face-font-instance face))
|
|
|
274 (name (symbol-name face)))
|
|
|
275 (if font
|
|
|
276 (message "True font for `%s': %s" name (font-instance-truename font))
|
|
|
277 (message "The face `%s' does not have its own font." name))))
|
|
|
278
|
|
|
279 (defun ef-foreground (face)
|
|
|
280 (interactive
|
|
|
281 (list (ef-face-arg)))
|
|
|
282 (set-face-foreground
|
|
|
283 face
|
|
|
284 (read-color (format "Foreground color for `%s': " (symbol-name face))
|
|
|
285 nil
|
|
|
286 (color-instance-name (face-foreground-instance face))))
|
|
|
287 (ef-update-face-description face))
|
|
|
288
|
|
|
289 (defun ef-background (face)
|
|
|
290 (interactive
|
|
|
291 (list (ef-face-arg)))
|
|
|
292 (set-face-background
|
|
|
293 face
|
|
|
294 (read-color (format "Background color for `%s': " (symbol-name face))
|
|
|
295 nil
|
|
|
296 (color-instance-name (face-background-instance face))))
|
|
|
297 (ef-update-face-description face))
|
|
|
298
|
|
|
299 (defun ef-doc-string (face)
|
|
|
300 (interactive
|
|
|
301 (list (ef-face-arg)))
|
|
|
302 (set-face-doc-string
|
|
|
303 face
|
|
|
304 (read-string (format "Doc string for `%s': " (symbol-name face))
|
|
|
305 (face-doc-string face)))
|
|
|
306 (ef-update-face-description face))
|
|
|
307
|
|
|
308 (defun ef-copy-other-face (src dst)
|
|
|
309 (interactive
|
|
|
310 (let* ((f (ef-face-arg))
|
|
|
311 (name (symbol-name f)))
|
|
|
312 (list (read-face (format "Make `%s' a copy of what face?: " name) t) f)))
|
|
|
313 (copy-face src dst)
|
|
|
314 (ef-update-face-description dst dst))
|
|
|
315
|
|
|
316 (defun ef-copy-this-face (src dst)
|
|
|
317 (interactive
|
|
|
318 (let* ((f (ef-face-arg))
|
|
|
319 (name (symbol-name f)))
|
|
|
320 (list f (read-face (format "Copy `%s' onto what face?: " name)))))
|
|
|
321 (copy-face src dst)
|
|
|
322 (ef-update-face-description dst dst))
|
|
|
323
|
|
|
324 (defun ef-font (face)
|
|
|
325 (interactive
|
|
|
326 (list (ef-face-arg)))
|
|
|
327 (let* ((ofont (face-font-instance face))
|
|
|
328 (font (read-string (format "Font for `%s': " (symbol-name face))
|
|
|
329 (font-instance-name (face-font-instance face))))
|
|
|
330 others)
|
|
|
331 ;; you might think that this could be moved into the loop below, but I
|
|
|
332 ;; think that it's important to see the new font before asking if the
|
|
|
333 ;; change should be global.
|
|
|
334 (set-face-font face (if (and (string= font "")
|
|
|
335 (not (eq face 'default)))
|
|
|
336 nil font))
|
|
|
337 (ef-update-face-description face)
|
|
|
338 (setq others (delq nil (mapcar (lambda (f)
|
|
|
339 (and (equal (face-font-instance f) ofont)
|
|
|
340 f))
|
|
|
341 (face-list))))
|
|
|
342 (if (and others
|
|
|
343 (y-or-n-p "Make the same font change for other faces? "))
|
|
|
344 (while others
|
|
|
345 (setq face (car others)
|
|
|
346 others (cdr others))
|
|
|
347 (set-face-font face font)
|
|
|
348 (ef-update-face-description face)))
|
|
|
349 ))
|
|
|
350
|
|
|
351 (defun ef-quit ()
|
|
|
352 (interactive)
|
|
|
353 (or (one-window-p t 0)
|
|
|
354 (delete-window))
|
|
|
355 (kill-buffer "*Edit Faces*"))
|
