Mercurial > hg > xemacs-beta

comparison lisp/packages/edit-faces.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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*"))