|
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)
|
|
|
60 (if current-menubar
|
|
|
61 (progn
|
|
|
62 (set (make-local-variable 'current-menubar)
|
|
|
63 (copy-sequence current-menubar))
|
|
|
64 (add-submenu nil edit-faces-menu))))
|
|
|
65
|
|
|
66 (let ((map edit-faces-mode-map))
|
|
|
67 (define-key map "<" 'ef-smaller)
|
|
|
68 (define-key map ">" 'ef-larger)
|
|
|
69 (define-key map "c" 'ef-copy-other-face)
|
|
|
70 (define-key map "C" 'ef-copy-this-face)
|
|
|
71 (define-key map "s" 'ef-smaller)
|
|
|
72 (define-key map "l" 'ef-larger)
|
|
|
73 (define-key map "b" 'ef-bold)
|
|
|
74 (define-key map "i" 'ef-italic)
|
|
|
75 (define-key map "e" 'ef-font)
|
|
|
76 (define-key map "f" 'ef-font)
|
|
|
77 (define-key map "u" 'ef-underline)
|
|
|
78 (define-key map "t" 'ef-truefont)
|
|
|
79 (define-key map "F" 'ef-foreground)
|
|
|
80 (define-key map "B" 'ef-background)
|
|
|
81 (define-key map "D" 'ef-doc-string)
|
|
|
82 (define-key map "d" 'ef-delete)
|
|
|
83 (define-key map "n" 'ef-next)
|
|
|
84 (define-key map "p" 'ef-prev)
|
|
|
85 (define-key map " " 'ef-next)
|
|
|
86 (define-key map "\C-?" 'ef-prev)
|
|
|
87 (define-key map "g" 'edit-faces) ; refresh display
|
|
|
88 (define-key map "q" 'ef-quit)
|
|
|
89 (define-key map "\C-c\C-c" 'bury-buffer))
|
|
|
90
|
|
|
91 ;;;###autoload
|
|
|
92 (defun edit-faces ()
|
|
|
93 "Alter face characteristics by editing a list of defined faces.
|
|
|
94 Pops up a buffer containing a list of defined faces.
|
|
|
95
|
|
|
96 Editing commands:
|
|
|
97
|
|
|
98 \\{edit-faces-mode-map}"
|
|
|
99 (interactive)
|
|
|
100 (pop-to-buffer (get-buffer-create "*Edit Faces*"))
|
|
|
101 (reset-buffer (current-buffer))
|
|
|
102
|
|
|
103 ;; face-list returns faces in a random order so we sort
|
|
|
104 ;; alphabetically by the name in order to insert some logic into
|
|
|
105 ;; the ordering.
|
|
|
106 (let ((flist (sort (face-list)
|
|
|
107 (function
|
|
|
108 (lambda (x y)
|
|
|
109 (string-lessp (symbol-name x) (symbol-name y))))))
|
|
|
110 face)
|
|
|
111 (ef-update-face-description t) ; insert header line
|
|
|
112 (while (setq face (car flist))
|
|
|
113 (ef-update-face-description face)
|
|
|
114 (setq flist (cdr flist))
|
|
|
115 ))
|
|
|
116 (edit-faces-mode)
|
|
|
117 )
|
|
|
118
|
|
|
119 (defun ef-foreground-callback (event extent user-data)
|
|
|
120 (ef-foreground (ef-face-arg (extent-start-position extent)
|
|
|
121 (extent-object extent))))
|
|
|
122
|
|
|
123 (defun ef-background-callback (event extent user-data)
|
|
|
124 (ef-background (ef-face-arg (extent-start-position extent)
|
|
|
125 (extent-object extent))))
|
|
|
126
|
|
|
127 (defun ef-font-callback (event extent user-data)
|
|
|
128 (ef-font (ef-face-arg (extent-start-position extent)
|
|
|
129 (extent-object extent))))
|
|
|
130
|
|
|
131 (defun ef-doc-string-callback (event extent user-data)
|
|
|
132 (ef-doc-string (ef-face-arg (extent-start-position extent)
|
|
|
133 (extent-object extent))))
|
|
|
134
|
|
|
135 (defun ef-update-face-description (face &optional replace)
|
|
|
136 "Given a face, inserts a description of that face into the current buffer.
|
|
|
137 Inserts a descriptive header if passed `t'."
|
|
|
138 (let ((face-name-fmt "%-25s")
|
|
|
139 (foreground-fmt "%-15s")
|
|
|
140 (background-fmt "%-15s")
|
|
|
141 (font-fmt "%s")
|
|
|
142 (buffer-read-only nil)
|
|
|
143 fg bg font)
|
|
|
144 (if (eq face t)
|
|
|
145 (insert-face (format (concat face-name-fmt " " foreground-fmt " "
|
|
|
146 background-fmt " " font-fmt "\n")
|
|
|
147 "Face" "Foreground" "Background" "Font Spec")
|
|
|
148 'underline)
|
|
|
149 (or replace (setq replace face))
|
|
|
150 (goto-char (point-min))
|
|
|
151 (if (re-search-forward (concat "^" (symbol-name replace) " ") nil 0)
|
|
|
152 (progn
|
|
|
153 (beginning-of-line)
|
|
|
154 (delete-region (point) (progn (forward-line 2) (point)))
|
|
|
155 ))
|
|
|
156 (setq fg (face-foreground-instance face)
|
|
|
157 bg (face-background-instance face)
|
|
|
158 font (face-font-instance face))
|
|
|
159 (let ((st (point))
|
|
|
160 (fn #'(lambda (str callback)
|
|
|
161 (let ((st1 (point)))
|
|
|
162 (insert str)
|
|
|
163 (add-list-mode-item st1 (point) nil callback)))))
|
|
|
164 (funcall fn (format face-name-fmt (symbol-name face)) nil)
|
|
|
165 (insert " ")
|
|
|
166 (funcall fn (format foreground-fmt (color-instance-name fg))
|
|
|
167 'ef-foreground-callback)
|
|
|
168 (insert " ")
|
|
|
169 (funcall fn (format background-fmt (color-instance-name bg))
|
|
|
170 'ef-background-callback)
|
|
|
171 (insert " ")
|
|
|
172 (funcall fn (format font-fmt (font-instance-name font))
|
|
|
173 'ef-font-callback)
|
|
|
174 (insert "\n (")
|
|
|
175 (funcall fn (or (face-doc-string face) "")
|
|
|
176 'ef-doc-string-callback)
|
|
|
177 (insert ")")
|
|
|
178 (add-nonduplicable-text-properties st (point)
|
|
|
179 `(face ,face eface ,face
|
|
|
180 start-open t))
|
|
|
181 (insert "\n")
|
|
|
182 )
|
|
|
183 (and replace (forward-line -1))
|
|
|
184 ))
|
|
|
185 )
|
|
|
186
|
|
|
187 (defun ef-face-arg (&optional pos buffer)
|
|
|
188 (if (and (not pos) (not buffer))
|
|
|
189 (and current-mouse-event
|
|
|
190 (mouse-event-p current-mouse-event)
|
|
|
191 (mouse-set-point current-mouse-event)))
|
|
|
192 (or buffer (setq buffer (current-buffer)))
|
|
|
193 (or pos (setq pos (point buffer)))
|
|
|
194 (let ((face (or (get-char-property pos 'eface buffer)
|
|
|
195 (and (> pos (point-min buffer))
|
|
|
196 (get-char-property (1- pos) 'eface buffer)))))
|
|
|
197 (or face (error "There is no face to edit on this line."))
|
|
|
198 face))
|
|
|
199
|
|
|
200 (defun ef-delete (arg)
|
|
|
201 "Delete the face on the current line from the *Edit Faces* buffer.
|
|
|
202 The face is not altered. The buffer can be regenerated again with
|
|
|
203 M-x edit-faces."
|
|
|
204 (interactive "p")
|
|
|
205 (and current-mouse-event (mouse-event-p current-mouse-event)
|
|
|
206 (mouse-set-point current-mouse-event))
|
|
|
207 (let ( ;; is this worth the bother? (fwd (> arg 0))
|
|
|
208 (count (abs arg))
|
|
|
209 (buffer-read-only nil)
|
|
|
210 ex)
|
|
|
211 (while (not (zerop (prog1 count (setq count (1- count)))))
|
|
|
212 (setq ex (text-property-bounds (point) 'eface nil 'at))
|
|
|
213 (or ex (error "There is no face to delete on this line."))
|
|
|
214 (delete-region (car ex) (cdr ex))
|
|
|
215 (delete-blank-lines))))
|
|
|
216
|
|
|
217 (defun ef-next (arg)
|
|
|
218 "Move forward ARG entries in the face table."
|
|
|
219 (interactive "p")
|
|
|
220 (let ((bounds (next-text-property-bounds arg (point) 'eface)))
|
|
|
221 (if bounds (goto-char (car bounds))
|
|
|
222 (goto-char (if (> arg 0) (point-max) (point-min))))))
|
|
|
223
|
|
|
224 (defun ef-prev (arg)
|
|
|
225 "Move forward ARG entries in the face table."
|
|
|
226 (interactive "p")
|
|
|
227 (ef-next (- arg)))
|
|
|
228
|
|
|
229 (defun ef-smaller (face)
|
|
|
230 (interactive (list (ef-face-arg)))
|
|
|
231 (make-face-smaller face)
|
|
|
232 (ef-update-face-description face))
|
|
|
233
|
|
|
234 (defun ef-larger (face)
|
|
|
235 (interactive (list (ef-face-arg)))
|
|
|
236 (make-face-larger face)
|
|
|
237 (ef-update-face-description face))
|
|
|
238
|
|
|
239 (defun ef-face-font-indirect (face)
|
|
|
240 (let ((font (face-font-instance face)))
|
|
|
241 (or font (face-font-instance 'default))))
|
|
|
242
|
|
|
243 (defun ef-face-bold-p (face)
|
|
|
244 (let ((font (ef-face-font-indirect face)))
|
|
|
245 (not (not (string-match "-bold-" (font-instance-name font))))))
|
|
|
246
|
|
|
247 (defun ef-face-italic-p (face)
|
|
|
248 (let ((font (ef-face-font-indirect face)))
|
|
|
249 (not (not (string-match "-[io]-" (font-instance-name font))))))
|
|
|
250
|
|
|
251 (defun ef-bold (face)
|
|
|
252 (interactive (list (ef-face-arg)))
|
|
|
253 (if (ef-face-bold-p face)
|
|
|
254 (make-face-unbold face)
|
|
|
255 (make-face-bold face))
|
|
|
256 (ef-update-face-description face))
|
|
|
257
|
|
|
258 (defun ef-italic (face)
|
|
|
259 (interactive (list (ef-face-arg)))
|
|
|
260 (if (ef-face-italic-p face)
|
|
|
261 (make-face-unitalic face)
|
|
|
262 (make-face-italic face))
|
|
|
263 (ef-update-face-description face))
|
|
|
264
|
|
|
265 (defun ef-underline (face)
|
|
|
266 (interactive (list (ef-face-arg)))
|
|
|
267 (set-face-underline-p face (not (face-underline-p face)))
|
|
|
268 (ef-update-face-description face))
|
|
|
269
|
|
|
270 (defun ef-truefont (face)
|
|
|
271 (interactive (list (ef-face-arg)))
|
|
|
272 (let ((font (face-font-instance face))
|
|
|
273 (name (symbol-name face)))
|
|
|
274 (if font
|
|
|
275 (message "True font for `%s': %s" name (font-instance-truename font))
|
|
|
276 (message "The face `%s' does not have its own font." name))))
|
|
|
277
|
|
|
278 (defun ef-foreground (face)
|
|
|
279 (interactive
|
|
|
280 (list (ef-face-arg)))
|
|
|
281 (set-face-foreground
|
|
|
282 face
|
|
|
283 (read-color (format "Foreground color for `%s': " (symbol-name face))
|
|
|
284 nil
|
|
|
285 (color-instance-name (face-foreground-instance face))))
|
|
|
286 (ef-update-face-description face))
|
|
|
287
|
|
|
288 (defun ef-background (face)
|
|
|
289 (interactive
|
|
|
290 (list (ef-face-arg)))
|
|
|
291 (set-face-background
|
|
|
292 face
|
|
|
293 (read-color (format "Background color for `%s': " (symbol-name face))
|
|
|
294 nil
|
|
|
295 (color-instance-name (face-background-instance face))))
|
|
|
296 (ef-update-face-description face))
|
|
|
297
|
|
|
298 (defun ef-doc-string (face)
|
|
|
299 (interactive
|
|
|
300 (list (ef-face-arg)))
|
|
|
301 (set-face-doc-string
|
|
|
302 face
|
|
|
303 (read-string (format "Doc string for `%s': " (symbol-name face))
|
|
|
304 (face-doc-string face)))
|
|
|
305 (ef-update-face-description face))
|
|
|
306
|
|
|
307 (defun ef-copy-other-face (src dst)
|
|
|
308 (interactive
|
|
|
309 (let* ((f (ef-face-arg))
|
|
|
310 (name (symbol-name f)))
|
|
|
311 (list (read-face (format "Make `%s' a copy of what face?: " name) t) f)))
|
|
|
312 (copy-face src dst)
|
|
|
313 (ef-update-face-description dst dst))
|
|
|
314
|
|
|
315 (defun ef-copy-this-face (src dst)
|
|
|
316 (interactive
|
|
|
317 (let* ((f (ef-face-arg))
|
|
|
318 (name (symbol-name f)))
|
|
|
319 (list f (read-face (format "Copy `%s' onto what face?: " name)))))
|
|
|
320 (copy-face src dst)
|
|
|
321 (ef-update-face-description dst dst))
|
|
|
322
|
|
|
323 (defun ef-font (face)
|
|
|
324 (interactive
|
|
|
325 (list (ef-face-arg)))
|
|
|
326 (let* ((ofont (face-font-instance face))
|
|
|
327 (font (read-string (format "Font for `%s': " (symbol-name face))
|
|
|
328 (font-instance-name (face-font-instance face))))
|
|
|
329 others)
|
|
|
330 ;; you might think that this could be moved into the loop below, but I
|
|
|
331 ;; think that it's important to see the new font before asking if the
|
|
|
332 ;; change should be global.
|
|
|
333 (set-face-font face (if (and (string= font "")
|
|
|
334 (not (eq face 'default)))
|
|
|
335 nil font))
|
|
|
336 (ef-update-face-description face)
|
|
|
337 (setq others (delq nil (mapcar (lambda (f)
|
|
|
338 (and (equal (face-font-instance f) ofont)
|
|
|
339 f))
|
|
|
340 (face-list))))
|
|
|
341 (if (and others
|
|
|
342 (y-or-n-p "Make the same font change for other faces? "))
|
|
|
343 (while others
|
|
|
344 (setq face (car others)
|
|
|
345 others (cdr others))
|
|
|
346 (set-face-font face font)
|
|
|
347 (ef-update-face-description face)))
|
|
|
348 ))
|
|
|
349
|
|
|
350 (defun ef-quit ()
|
|
|
351 (interactive)
|
|
|
352 (or (one-window-p t 0)
|
|
|
353 (delete-window))
|
|
|
354 (kill-buffer "*Edit Faces*"))
|
